tree-diff 0.1 → 0.2
raw patch · 15 files changed
+688/−178 lines, 15 filesdep +Diffdep +criteriondep +deepseqdep ~QuickCheckdep ~aesondep ~ansi-terminal
Dependencies added: Diff, criterion, deepseq, primitive, semialign, strict, these
Dependency ranges changed: QuickCheck, aeson, ansi-terminal, base, base-compat, bytestring, generic-deriving, semigroups, tasty
Files
- ChangeLog.md +9/−0
- bench/tree-diff-bench.hs +62/−0
- fixtures/exfoo.expr +6/−6
- src-diff/RefDiffBy.hs +60/−0
- src/Data/TreeDiff.hs +2/−2
- src/Data/TreeDiff/Class.hs +62/−20
- src/Data/TreeDiff/Expr.hs +35/−14
- src/Data/TreeDiff/Golden.hs +11/−7
- src/Data/TreeDiff/List.hs +123/−40
- src/Data/TreeDiff/OMap.hs +158/−0
- src/Data/TreeDiff/Parser.hs +2/−2
- src/Data/TreeDiff/Pretty.hs +51/−34
- src/Data/TreeDiff/Tree.hs +25/−28
- tests/Tests.hs +21/−6
- tree-diff.cabal +61/−19
ChangeLog.md view
@@ -1,3 +1,12 @@+## 0.2++- Change the pretty printing to use less horizontal space.+ `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 - Support GHC-7.4 ... 8.8 (use allow-newer for GHC-8.8-alpha).
+ bench/tree-diff-bench.hs view
@@ -0,0 +1,62 @@+{-# OPTIONS -fno-warn-orphans #-}+module Main (main) where++import Control.DeepSeq (NFData (..))+import Control.Exception (evaluate)+import Criterion.Main (bench, bgroup, defaultMain, nf)++import qualified Data.Algorithm.Diff as Diff++import Data.TreeDiff.List (diffBy)++smallA :: [Int]+smallB :: [Int]++smallA = [0, 5 .. 100]+smallB = [0, 3 .. 72]++bigA :: [Int]+bigA = [0, 5 .. 10000]++bigB :: [Int]+bigB = [0, 3 .. 7200]++main :: IO ()+main = do+ evaluate (rnf smallA)+ evaluate (rnf smallB)++ evaluate (rnf bigA)+ evaluate (rnf bigB)++ defaultMain+ [ bgroup "same"+ [ bgroup "small"+ [ bench "lib" $ nf (uncurry (diffBy (==))) (smallA, smallA)+ , bench "Diff" $ nf (uncurry (Diff.getDiffBy (==))) (smallA, smallA)+ ]+ , bgroup "big"+ [ bench "lib" $ nf (uncurry (diffBy (==))) (bigA, bigA)+ , bench "Diff" $ nf (uncurry (Diff.getDiffBy (==))) (bigA, bigA)+ ]+ ]+ , bgroup "different"+ [ bgroup "small"+ [ bench "lib" $ nf (uncurry (diffBy (==))) (smallA, smallB)+ , bench "Diff" $ nf (uncurry (Diff.getDiffBy (==))) (smallA, smallB)+ ]+ , bgroup "big"+ [ bench "lib" $ nf (uncurry (diffBy (==))) (bigA, bigB)+ , bench "Diff" $ nf (uncurry (Diff.getDiffBy (==))) (bigA, bigB)+ ]+ ]+ ]++-------------------------------------------------------------------------------+-- Orphans+-------------------------------------------------------------------------------++instance (NFData a, NFData b) => NFData (Diff.PolyDiff a b) where+ rnf (Diff.First x) = rnf x+ rnf (Diff.Second y) = rnf y+ rnf (Diff.Both x y) = rnf x `seq` rnf y
fixtures/exfoo.expr view
@@ -1,6 +1,6 @@-Foo- {fooBar = [Just "pub", Just (concat ["night\n", "club"])],- fooInt = 42,- fooNew = True,- fooQuu = _×_ 125.375 Proxy,- fooStr = "Some Name"}+Foo {+ fooBar = [Just "pub", Just (concat ["night\n", "club"])],+ fooInt = 42,+ fooNew = True,+ fooQuu = _×_ 125.375 Proxy,+ fooStr = "Some Name"}
+ src-diff/RefDiffBy.hs view
@@ -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.hs view
@@ -21,7 +21,7 @@ module Data.TreeDiff.Parser, ) where -import Data.TreeDiff.Expr import Data.TreeDiff.Class-import Data.TreeDiff.Pretty+import Data.TreeDiff.Expr import Data.TreeDiff.Parser+import Data.TreeDiff.Pretty
src/Data/TreeDiff/Class.hs view
@@ -24,10 +24,11 @@ import Data.List.Compat (uncons) import Data.Proxy (Proxy (..)) import GHC.Generics- ((:*:) (..), (:+:) (..), Constructor (..), Generic (..), K1 (..), M1 (..),- Selector (..), U1 (..), V1)+ ((:*:) (..), (:+:) (..), Constructor (..), Generic (..), K1 (..),+ M1 (..), Selector (..), U1 (..), V1) import qualified Data.Map as Map+import qualified Data.TreeDiff.OMap as OMap import Data.TreeDiff.Expr @@ -64,8 +65,8 @@ import qualified Data.Time as Time -- bytestring-import qualified Data.ByteString as BS-import qualified Data.ByteString.Lazy as LBS+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.Short as SBS @@ -94,6 +95,30 @@ -- aeson import qualified Data.Aeson as Aeson +-- strict+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_)+-- >>> import Data.Ratio ((%))+-- >>> import Data.Time (Day (..))+-- >>> import Data.Scientific (Scientific)+-- >>> import GHC.Generics (Generic)+-- >>> import qualified Data.ByteString.Char8 as BS8+-- >>> import qualified Data.ByteString.Lazy.Char8 as LBS8+-- >>> import Data.TreeDiff.Pretty++-------------------------------------------------------------------------------+-- Code+-------------------------------------------------------------------------------+ -- | Difference between two 'ToExpr' values. -- -- >>> let x = (1, Just 2) :: (Int, Maybe Int)@@ -105,13 +130,13 @@ -- >>> instance ToExpr Foo -- -- >>> prettyEditExpr $ ediff (Foo (Right 2) [Just True] "fo") (Foo (Right 3) [Just True] "fo")--- Foo {fooBool = [Just True], fooInt = Right -2 +3, fooString = "fo"}+-- Foo {fooInt = Right -2 +3, fooBool = [Just True], fooString = "fo"} -- -- >>> prettyEditExpr $ ediff (Foo (Right 42) [Just True, Just False] "old") (Foo (Right 42) [Nothing, Just False, Just True] "new")--- Foo--- {fooBool = [-Just True, +Nothing, Just False, +Just True],--- fooInt = Right 42,--- fooString = -"old" +"new"}+-- Foo {+-- fooInt = Right 42,+-- fooBool = [-Just True, +Nothing, Just False, +Just True],+-- fooString = -"old" +"new"} -- ediff :: ToExpr a => a -> a -> Edit EditExpr ediff x y = exprDiff (toExpr x) (toExpr y)@@ -179,7 +204,7 @@ App' exprs -> App cn exprs Rec' [] -> App cn [] Rec' [(_,e)] -> App cn [e]- Rec' pairs -> Rec cn (Map.fromList pairs)+ Rec' pairs -> Rec cn (OMap.fromList pairs) where cn = conName z @@ -526,15 +551,32 @@ instance ToExpr Aeson.Value ---------------------------------------------------------------------------------- Doctest+-- strict ------------------------------------------------------------------------------- --- $setup--- >>> :set -XDeriveGeneric--- >>> import Data.Foldable (traverse_)--- >>> import Data.Ratio ((%))--- >>> import Data.Time (Day (..))--- >>> import Data.Scientific (Scientific)--- >>> import Data.TreeDiff.Pretty--- >>> import qualified Data.ByteString.Char8 as BS8--- >>> import qualified Data.ByteString.Lazy.Char8 as LBS8+instance ToExpr a => ToExpr (Strict.Maybe a) where+ toExpr = toExpr . Strict.toLazy++instance (ToExpr a, ToExpr b) => ToExpr (Strict.Either a b) where+ toExpr = toExpr . Strict.toLazy++instance (ToExpr a, ToExpr b) => ToExpr (Strict.These a b) where+ toExpr = toExpr . Strict.toLazy++instance (ToExpr a, ToExpr b) => ToExpr (Strict.Pair a b) where+ toExpr = toExpr . Strict.toLazy++-------------------------------------------------------------------------------+-- these+-------------------------------------------------------------------------------++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/Expr.hs view
@@ -12,11 +12,15 @@ import Prelude () import Prelude.Compat -import Data.Map (Map)+import Control.DeepSeq (NFData (..))+import Data.Semialign (alignWith)+import Data.These (These (..))+ import Data.TreeDiff.List+import Data.TreeDiff.OMap (OMap) -import qualified Data.Map as Map-import qualified Test.QuickCheck as QC+import qualified Data.TreeDiff.OMap as OMap+import qualified Test.QuickCheck as QC -- | Constructor name is a string type ConstructorName = String@@ -29,17 +33,22 @@ -- Having richer structure than just 'Tree' allows to have richer diffs. data Expr = App ConstructorName [Expr] -- ^ application- | Rec ConstructorName (Map FieldName Expr) -- ^ record constructor+ | Rec ConstructorName (OMap FieldName Expr) -- ^ record constructor | Lst [Expr] -- ^ list constructor deriving (Eq, Show) +instance NFData Expr where+ rnf (App n es) = rnf n `seq` rnf es+ rnf (Rec n fs) = rnf n `seq` rnf fs+ rnf (Lst es) = rnf es+ instance QC.Arbitrary Expr where arbitrary = QC.scale (min 25) $ QC.sized arb where arb n | n <= 0 = QC.oneof [ (`App` []) <$> arbName- , (`Rec` mempty) <$> arbName+ , (`Rec` OMap.empty) <$> arbName ]- arb n | otherwise = do+ | otherwise = do n' <- QC.choose (0, n `div` 3) QC.oneof [ App <$> arbName <*> QC.liftArbitrary (arb n')@@ -49,8 +58,8 @@ shrink (Lst es) = es ++ [ Lst es' | es' <- QC.shrink es ]- shrink (Rec n fs) = Map.elems fs- ++ [ Rec n' fs | n' <- QC.shrink n ] + shrink (Rec n fs) = OMap.elems fs+ ++ [ Rec n' fs | n' <- QC.shrink n ] ++ [ Rec n fs' | fs' <- QC.shrink fs ] shrink (App n es) = es ++ [ App n' es | n' <- QC.shrink n ]@@ -72,16 +81,22 @@ where impl ea eb | ea == eb = Cpy (EditExp ea) + -- application impl ea@(App a as) eb@(App b bs)- | a == b = Cpy $ EditApp a (map recurse (diffBy (==) as bs))+ | a == b = Cpy $ EditApp a (map recurse (diffBy (==) as bs)) | otherwise = Swp (EditExp ea) (EditExp eb)++ -- records impl ea@(Rec a as) eb@(Rec b bs)- | a == b = Cpy $ EditRec a $ Map.unions [inter, onlyA, onlyB]+ | a == b = Cpy $ EditRec a $ alignWith cls as bs | otherwise = Swp (EditExp ea) (EditExp eb) where- inter = Map.intersectionWith exprDiff as bs- onlyA = fmap (Del . EditExp) (Map.difference as inter)- onlyB = fmap (Ins . EditExp) (Map.difference bs inter)+ cls :: These Expr Expr -> Edit EditExpr+ cls (This x) = Del (EditExp x)+ cls (That y) = Ins (EditExp y)+ cls (These x y) = exprDiff x y++ -- lists impl (Lst as) (Lst bs) = Cpy $ EditLst (map recurse (diffBy (==) as bs)) @@ -96,7 +111,13 @@ -- | Type used in the result of 'ediff'. data EditExpr = EditApp ConstructorName [Edit EditExpr]- | EditRec ConstructorName (Map FieldName (Edit EditExpr))+ | EditRec ConstructorName (OMap FieldName (Edit EditExpr)) | EditLst [Edit EditExpr] | EditExp Expr -- ^ unchanged tree deriving Show++instance NFData EditExpr where+ rnf (EditApp n es) = rnf n `seq` rnf es+ rnf (EditRec n fs) = rnf n `seq` rnf fs+ rnf (EditLst es) = rnf es+ rnf (EditExp e) = rnf e
src/Data/TreeDiff/Golden.hs view
@@ -1,7 +1,7 @@ -- | "Golden tests" using 'ediff' comparison. module Data.TreeDiff.Golden ( ediffGolden,- ) where+) where import Data.TreeDiff import Prelude ()@@ -10,9 +10,10 @@ import Text.Parsec (eof, parse) import Text.Parsec.Text () -import qualified Data.ByteString as BS-import qualified Data.Text as T-import qualified Data.Text.Encoding as T+import qualified Data.ByteString as BS+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import qualified Text.PrettyPrint.ANSI.Leijen as WL -- | Make a golden tests. --@@ -47,11 +48,14 @@ actual = fmap toExpr x expect = do contents <- BS.readFile fp- case parse (exprParser <* eof) fp $ T.decodeUtf8 contents of+ case parse (exprParser <* eof) fp $ TE.decodeUtf8 contents of Left err -> print err >> fail "parse error" Right r -> return r cmp a b | a == b = return Nothing | otherwise = return $ Just $- setSGRCode [Reset] ++ show (ansiWlEditExprCompact $ ediff a b)- wrt expr = BS.writeFile fp $ T.encodeUtf8 $ T.pack $ show (prettyExpr expr) ++ "\n"+ setSGRCode [Reset] ++ showWL (ansiWlEditExprCompact $ ediff a b)+ wrt expr = BS.writeFile fp $ TE.encodeUtf8 $ T.pack $ showWL (WL.plain (ansiWlExpr expr)) ++ "\n"++showWL :: WL.Doc -> String+showWL doc = WL.displayS (WL.renderSmart 0.4 80 doc) ""
src/Data/TreeDiff/List.hs view
@@ -1,10 +1,18 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE ScopedTypeVariables #-} -- | A list diff.-module Data.TreeDiff.List (diffBy, Edit (..)) where+module Data.TreeDiff.List (+ diffBy,+ Edit (..),+) where -import Data.List.Compat (sortOn)-import qualified Data.Vector as V+import Control.DeepSeq (NFData (..))+import Control.Monad.ST (ST, runST) +import qualified Data.Primitive as P++-- import Debug.Trace+ -- | List edit operations -- -- The 'Swp' constructor is redundant, but it let us spot@@ -14,8 +22,14 @@ | 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+ rnf (Del x) = rnf x+ rnf (Cpy x) = rnf x+ rnf (Swp x y) = rnf x `seq` rnf y+ -- | List difference. -- -- >>> diffBy (==) "hello" "world"@@ -27,47 +41,116 @@ -- prop> \xs ys -> length (diffBy (==) xs ys) >= max (length xs) (length (ys :: String)) -- prop> \xs ys -> length (diffBy (==) xs ys) <= length xs + length (ys :: String) ----- /Note:/ currently this has O(n*m) memory requirements, for the sake--- 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 :: forall a. Show a => (a -> a -> Bool) -> [a] -> [a] -> [Edit a]+diffBy _ [] [] = []+diffBy _ [] ys' = map Ins ys'+diffBy _ xs' [] = map Del xs'+diffBy eq xs' ys'+ | otherwise = reverse (getCell lcs) 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- [ impl xi yi- | xi <- [0 .. xn]- , yi <- [0 .. yn]- ]+ lcs :: Cell [Edit a]+ lcs = runST $ do+ -- traceShowM ("sizes", xn, yn) - lcs :: Int -> Int -> (Int, [Edit a])- lcs xi yi = memo V.! (yi + xi * (yn + 1))+ -- create two buffers.+ buf1 <- P.newArray yn (Cell 0 [])+ buf2 <- P.newArray yn (Cell 0 []) - 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)+ -- fill the first row+ -- 0,0 case is filled already+ yLoop (Cell 0 []) $ \m (Cell w edit) -> do+ let cell = Cell (w + 1) (Ins (P.indexArray ys m) : edit)+ P.writeArray buf1 m cell+ P.writeArray buf2 m cell+ -- traceShowM ("init", m, cell)+ return cell - impl n m = head $ sortOn fst- [ 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)+ -- following rows+ --+ -- cellC cellT+ -- cellL cellX+ (buf1final, _, _) <- xLoop (buf1, buf2, Cell 0 []) $ \n (prev, curr, cellC) -> do+ -- prevZ <- P.unsafeFreezeArray prev+ -- currZ <- P.unsafeFreezeArray prev+ -- traceShowM ("prev", n, prevZ)+ -- traceShowM ("curr", n, currZ) - edit- | eq x y = bimap id (Cpy x :) (lcs (n - 1) (m - 1))- | otherwise = bimap (+1) (Swp x y :) (lcs (n -1 ) (m - 1))+ let cellL :: Cell [Edit a]+ cellL = case cellC of (Cell w edit) -> Cell (w + 1) (Del (P.indexArray xs n) : edit) -bimap :: (a -> c) -> (b -> d) -> (a, b) -> (c, d)-bimap f g (x, y) = (f x, g y)+ -- traceShowM ("cellC, cellL", n, cellC, cellL)++ yLoop (cellC, cellL) $ \m (cellC', cellL') -> do+ -- traceShowM ("inner loop", n, m)+ cellT <- P.readArray prev m++ -- traceShowM ("cellT", n, m, cellT)++ let x, y :: a+ x = P.indexArray xs n+ y = P.indexArray ys m++ -- from diagonal+ let cellX1 :: Cell [Edit a]+ cellX1+ | eq x y = bimap id (Cpy x :) cellC'+ | otherwise = bimap (+1) (Swp x y :) cellC'++ -- from left+ let cellX2 :: Cell [Edit a]+ cellX2 = bimap (+1) (Ins y :) cellL'++ -- from top+ let cellX3 :: Cell [Edit a]+ cellX3 = bimap (+1) (Del x :) cellT++ -- the actual cell is best of three+ let cellX :: Cell [Edit a]+ cellX = bestOfThree cellX1 cellX2 cellX3++ -- traceShowM ("cellX", n, m, cellX)++ -- memoize+ P.writeArray curr m cellX++ return (cellT, cellX)++ return (curr, prev, cellL)++ P.readArray buf1final (yn - 1)++ xLoop :: acc -> (Int -> acc -> ST s acc) -> ST s acc+ xLoop !acc0 f = go acc0 0 where+ go !acc !n | n < xn = do+ acc' <- f n acc+ go acc' (n + 1)+ go !acc _ = return acc++ yLoop :: acc -> (Int -> acc -> ST s acc) -> ST s ()+ yLoop !acc0 f = go acc0 0 where+ go !acc !m | m < yn = do+ acc' <- f m acc+ go acc' (m + 1)+ go _ _ = return ()++data Cell a = Cell !Int !a deriving Show++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/OMap.hs view
@@ -0,0 +1,158 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor #-}+-- | Map which remembers the 'fromList' order.+-- This module is minimal on purpose.+module Data.TreeDiff.OMap (+ -- * Ordered map+ OMap,+ -- * Conversions+ toAscList,+ toList,+ fromList,+ -- * Construction+ empty,+ -- * Query+ elems,+) where++import Data.List (sortBy)+import Data.Ord (comparing)+import Data.Semialign (Semialign (..))+import Data.These (These (..))+import Control.DeepSeq (NFData (..))++#if MIN_VERSION_containers(0,5,0)+import qualified Data.Map.Strict as Map+#else+import qualified Data.Map as Map+#endif++import qualified Test.QuickCheck as QC++-- $setup+-- >>> import Data.Semialign (alignWith)++-------------------------------------------------------------------------------+-- Types+-------------------------------------------------------------------------------++newtype OMap k v = OMap (Map.Map k (Val v))+ deriving (Functor)++-- Value with its index+data Val v = Val !Int v+ deriving (Functor)++-- | Note: The instance uses 'toList', so 'Eq'ual 'OMap's can be shown differently.+instance (Show k, Show v) => Show (OMap k v) where+ showsPrec d m = showParen (d > 10)+ $ showString "fromList "+ . showsPrec d (toList m)++-- |+--+-- >>> xs = toAscList $ fromList [('a', "alpha"), ('b', "beta"), ('g', "gamma")]+-- >>> ys = toAscList $ fromList [('g', "gamma"), ('b', "beta"), ('a', "alpha")]+-- >>> xs == ys+-- True+--+-- >>> zs = toAscList $ fromList [('d', "delta"), ('b', "beta"), ('a', "alpha")]+-- >>> xs == zs+-- False+--+instance (Eq k, Eq v) => Eq (OMap k v) where+ xs == ys = go (toAscList xs) (toAscList ys) where+ go [] [] = True+ go _ [] = False+ go [] _ = False+ go ((k1, v1) : kvs1) ((k2, v2) : kvs2) =+ k1 == k2 && v1 == v2 && go kvs1 kvs2++-------------------------------------------------------------------------------+-- deepseq+-------------------------------------------------------------------------------++instance NFData v => NFData (Val v) where+ rnf (Val _ v) = rnf v++instance (NFData k, NFData v) => NFData (OMap k v) where+ rnf (OMap m) = rnf m++-------------------------------------------------------------------------------+-- QuickCheck+-------------------------------------------------------------------------------++instance (Ord k, QC.Arbitrary k, QC.Arbitrary v) => QC.Arbitrary (OMap k v) where+ arbitrary = QC.arbitrary1+ shrink = QC.shrink1++instance (Ord k, QC.Arbitrary k) => QC.Arbitrary1 (OMap k) where+ liftArbitrary arb = fmap fromList $ QC.liftArbitrary (QC.liftArbitrary arb)+ liftShrink shr m = fmap fromList $ QC.liftShrink (QC.liftShrink shr) $ toList m++-------------------------------------------------------------------------------+-- Combinators+-------------------------------------------------------------------------------++-- |+--+-- >>> empty :: OMap String Integer+-- fromList []+--+empty :: OMap k v+empty = OMap Map.empty++-- | Elements in key ascending order.+elems :: OMap k v -> [v]+elems (OMap m) = map (snd . getVal) $ Map.toAscList m++-- |+--+-- >>> toAscList $ fromList [('a', "alpha"), ('b', "beta"), ('g', "gamma")]+-- [('a',"alpha"),('b',"beta"),('g',"gamma")]+--+-- >>> toAscList $ fromList [('g', "gamma"), ('b', "beta"), ('a', "alpha")]+-- [('a',"alpha"),('b',"beta"),('g',"gamma")]+--+toAscList :: OMap k v -> [(k, v)]+toAscList (OMap m) = map getVal $ Map.toAscList m++-- | /O(n log n)/. List in creation order.+-- Doesn't respect 'Eq' instance.+--+-- >>> toList $ fromList [('a', "alpha"), ('b', "beta"), ('g', "gamma")]+-- [('a',"alpha"),('b',"beta"),('g',"gamma")]+--+-- >>> toList $ fromList [('g', "gamma"), ('b', "beta"), ('a', "alpha")]+-- [('g',"gamma"),('b',"beta"),('a',"alpha")]+--+toList :: OMap k v -> [(k, v)]+toList (OMap m) = map getVal $ sortBy (comparing getIdx) $ Map.toList m++getIdx :: (k, Val v) -> Int+getIdx (_, Val i _) = i++getVal :: (k, Val v) -> (k, v)+getVal (k, Val _ v) = (k, v)++-- |+--+-- >>> fromList [('g', "gamma"), ('b', "beta"), ('a', "alpha")]+-- fromList [('g',"gamma"),('b',"beta"),('a',"alpha")]+--+fromList :: Ord k => [(k, v)] -> OMap k v+fromList kvs = OMap (Map.fromList (zipWith p [0..] kvs)) where+ p i (k, v) = (k, Val i v)++-- |+--+-- >>> let xs = fromList [('a', "alpha"), ('b', "beta")]+-- >>> let ys = fromList [('c', 3 :: Int), ('b', 2)]+-- >>> alignWith id xs ys+-- fromList [('a',This "alpha"),('c',That 3),('b',These "beta" 2)]+--+instance Ord k => Semialign (OMap k) where+ alignWith f (OMap xs) (OMap ys) = OMap (alignWith g xs ys) where+ g (This (Val i x)) = Val i (f (This x))+ g (That (Val j y)) = Val j (f (That y))+ g (These (Val i x) (Val j y)) = Val (min i j) (f (These x y))
src/Data/TreeDiff/Parser.hs view
@@ -18,7 +18,7 @@ import Data.TreeDiff.Expr -import qualified Data.Map as Map+import qualified Data.TreeDiff.OMap as OMap -- | Parsers for 'Expr' using @parsers@ type-classes. --@@ -47,7 +47,7 @@ recP :: forall m. (Monad m, TokenParsing m) => m (Either String Expr) recP = mk <$> litP <*> optional (braces (commaSep fieldP)) where mk n Nothing = Left n- mk n (Just fs) = Right (Rec n (Map.fromList fs))+ mk n (Just fs) = Right (Rec n (OMap.fromList fs)) litP' :: forall m. (Monad m, TokenParsing m) => m Expr litP' = mk <$> recP <|> parens exprParser <|> lstP
src/Data/TreeDiff/Pretty.hs view
@@ -22,7 +22,7 @@ ansiWlBgEditExprCompact, -- * Utilities escapeName,- ) where+) where import Data.Char (isAlphaNum, isPunctuation, isSymbol, ord) import Data.Either (partitionEithers)@@ -30,23 +30,27 @@ import Numeric (showHex) import Text.Read.Compat (readMaybe) --import qualified Data.Map as Map+import qualified Data.TreeDiff.OMap as OMap import qualified Text.PrettyPrint as HJ import qualified Text.PrettyPrint.ANSI.Leijen as WL +-- $setup+-- >>> import qualified Data.TreeDiff.OMap as OMap+-- >>> import Data.TreeDiff.Expr+ -- | Because we don't want to commit to single pretty printing library, -- we use explicit dictionary. data Pretty doc = Pretty- { ppCon :: ConstructorName -> doc- , ppRec :: [(FieldName, doc)] -> doc- , ppLst :: [doc] -> doc- , ppCpy :: doc -> doc- , ppIns :: doc -> doc- , ppDel :: doc -> doc- , ppSep :: [doc] -> doc- , ppParens :: doc -> doc- , ppHang :: doc -> doc -> doc+ { ppCon :: ConstructorName -> doc -- ^ Display 'ConstructorName'+ , ppApp :: doc -> [doc] -> doc -- ^ Display 'App'+ , ppRec :: doc -> [(FieldName, doc)] -> doc -- ^ Display 'Rec'+ , ppLst :: [doc] -> doc -- ^ Display 'Lst'+ , ppCpy :: doc -> doc -- ^ Display unchanged parts+ , ppIns :: doc -> doc -- ^ Display added parts+ , ppDel :: doc -> doc -- ^ Display removed parts+ , ppEdits :: [doc] -> doc -- ^ Combined edits (usually some @sep@ combinator)+ , ppEllip :: doc -- ^ Ellipsis+ , ppParens :: doc -> doc -- ^ Parens an expression } -- | Escape field or constructor name@@ -112,10 +116,9 @@ ppExpr' :: Pretty doc -> Bool -> Expr -> doc ppExpr' p = impl where impl _ (App x []) = ppCon p (escapeName x)- impl b (App x xs) = ppParens' b $ ppHang p (ppCon p (escapeName x)) $- ppSep p $ map (impl True) xs- impl _ (Rec x xs) = ppHang p (ppCon p (escapeName x)) $ ppRec p $- map ppField' $ Map.toList xs+ impl b (App x xs) = ppParens' b $ ppApp p (ppCon p (escapeName x)) (map (impl True) xs)+ impl _ (Rec x xs) = ppRec p (ppCon p (escapeName x)) $+ map ppField' $ OMap.toList xs impl _ (Lst xs) = ppLst p (map (impl False) xs) ppField' (n, e) = (escapeName n, impl False e)@@ -132,8 +135,10 @@ ppEditExprCompact = ppEditExpr' True ppEditExpr' :: Bool -> Pretty doc -> Edit EditExpr -> doc-ppEditExpr' compact p = ppSep p . ppEdit False+ppEditExpr' compact p = go where+ go = ppEdits p . ppEdit False+ ppEdit b (Cpy (EditExp expr)) = [ ppCpy p $ ppExpr' p b expr ] ppEdit b (Cpy expr) = [ ppEExpr b expr ] ppEdit b (Ins expr) = [ ppIns p (ppEExpr b expr) ]@@ -144,19 +149,18 @@ ] ppEExpr _ (EditApp x []) = ppCon p (escapeName x)- ppEExpr b (EditApp x xs) = ppParens' b $ ppHang p (ppCon p (escapeName x)) $- ppSep p $ concatMap (ppEdit True) xs- ppEExpr _ (EditRec x xs) = ppHang p (ppCon p (escapeName x)) $ ppRec p $- justs ++ [ (n, ppCon p "...") | n <- take 1 nothings ]+ ppEExpr b (EditApp x xs) = ppParens' b $ ppApp p (ppCon p (escapeName x)) (concatMap (ppEdit True) xs)+ ppEExpr _ (EditRec x xs) = ppRec p (ppCon p (escapeName x)) $+ justs ++ [ (n, ppEllip p) | n <- take 1 nothings ] where- xs' = map ppField' $ Map.toList xs+ xs' = map ppField' $ OMap.toList xs (nothings, justs) = partitionEithers xs' ppEExpr _ (EditLst xs) = ppLst p (concatMap (ppEdit False) xs) ppEExpr b (EditExp x) = ppExpr' p b x ppField' (n, Cpy (EditExp e)) | compact, not (isScalar e) = Left n- ppField' (n, e) = Right (escapeName n, ppSep p $ ppEdit False e)+ ppField' (n, e) = Right (escapeName n, go e) ppParens' True = ppParens p ppParens' False = id@@ -172,20 +176,29 @@ prettyPretty :: Pretty HJ.Doc prettyPretty = Pretty { ppCon = HJ.text- , ppRec = HJ.braces . HJ.sep . HJ.punctuate HJ.comma- . map (\(fn, d) -> HJ.text fn HJ.<+> HJ.equals HJ.<+> d)- , ppLst = HJ.brackets . HJ.sep . HJ.punctuate HJ.comma+ , ppRec = \c xs -> prettyGroup (c HJ.<+> HJ.char '{') (HJ.char '}')+ $ map (\(fn, d) -> HJ.sep [HJ.text fn HJ.<+> HJ.equals, d]) xs+ , ppLst = prettyGroup (HJ.char '[') (HJ.char ']') , ppCpy = id , ppIns = \d -> HJ.char '+' HJ.<> d , ppDel = \d -> HJ.char '-' HJ.<> d- , ppSep = HJ.sep+ , ppEdits = HJ.sep+ , ppEllip = HJ.text "..."+ , ppApp = \f xs -> HJ.sep [ f, HJ.nest 2 $ HJ.sep xs ] , ppParens = HJ.parens- , ppHang = \d1 d2 -> HJ.hang d1 2 d2 } +prettyGroup :: HJ.Doc -> HJ.Doc -> [HJ.Doc] -> HJ.Doc+prettyGroup l r xs = HJ.cat [l, HJ.sep (map (HJ.nest 2) (prettyPunct (HJ.char ',') r xs))]++prettyPunct :: HJ.Doc -> HJ.Doc -> [HJ.Doc] -> [HJ.Doc]+prettyPunct _ end [] = [end]+prettyPunct _ end [x] = [x HJ.<> end]+prettyPunct sep end (x:xs) = (x HJ.<> sep) : prettyPunct sep end xs+ -- | Pretty print 'Expr' using @pretty@. ----- >>> prettyExpr $ Rec "ex" (Map.fromList [("[]", App "bar" [])])+-- >>> prettyExpr $ Rec "ex" (OMap.fromList [("[]", App "bar" [])]) -- ex {`[]` = bar} prettyExpr :: Expr -> HJ.Doc prettyExpr = ppExpr prettyPretty@@ -206,16 +219,20 @@ ansiWlPretty :: Pretty WL.Doc ansiWlPretty = Pretty { ppCon = WL.text- , ppRec = WL.encloseSep WL.lbrace WL.rbrace WL.comma- . map (\(fn, d) -> WL.text fn WL.<+> WL.equals WL.</> d)- , ppLst = WL.list+ , ppRec = \c xs -> ansiGroup (c WL.<+> WL.lbrace) WL.rbrace+ $ map (\(fn, d) -> WL.text fn WL.<+> WL.equals WL.</> d) xs+ , ppLst = ansiGroup WL.lbracket WL.rbracket , ppCpy = WL.dullwhite , ppIns = \d -> WL.green $ WL.plain $ WL.char '+' WL.<> d , ppDel = \d -> WL.red $ WL.plain $ WL.char '-' WL.<> d- , ppSep = WL.sep+ , ppApp = \f xs -> WL.group $ WL.nest 2 $ f WL.<$> WL.vsep xs+ , ppEdits = WL.sep+ , ppEllip = WL.text "..." , ppParens = WL.parens- , ppHang = \d1 d2 -> WL.hang 2 (d1 WL.</> d2) }++ansiGroup :: WL.Doc -> WL.Doc -> [WL.Doc] -> WL.Doc+ansiGroup l r xs = WL.group $ WL.nest 2 (l WL.<$$> WL.vsep (WL.punctuate WL.comma xs) WL.<> r) -- | Pretty print 'Expr' using @ansi-wl-pprint@. ansiWlExpr :: Expr -> WL.Doc
src/Data/TreeDiff/Tree.hs view
@@ -5,9 +5,30 @@ import Data.Tree (Tree (..)) import Data.TreeDiff.List -#ifdef __DOCTEST__-import qualified Text.PrettyPrint as PP-#endif+-- $setup+-- >>> import Data.Tree (Tree (..))+-- >>> import qualified Text.PrettyPrint as PP+-- >>> :{+-- ppTree :: (a -> PP.Doc) -> Tree a -> PP.Doc+-- ppTree pp = ppT+-- where+-- ppT (Node x []) = pp x+-- ppT (Node x xs) = PP.parens $ PP.hang (pp x) 2 $+-- PP.sep $ map ppT xs+-- ppEditTree :: (a -> PP.Doc) -> Edit (EditTree a) -> PP.Doc+-- ppEditTree pp = PP.sep . ppEdit+-- where+-- ppEdit (Cpy tree) = [ ppTree tree ]+-- ppEdit (Ins tree) = [ PP.char '+' PP.<> ppTree tree ]+-- ppEdit (Del tree) = [ PP.char '-' PP.<> ppTree tree ]+-- ppEdit (Swp a b) =+-- [ PP.char '-' PP.<> ppTree a+-- , PP.char '+' PP.<> ppTree b+-- ]+-- ppTree (EditNode x []) = pp x+-- ppTree (EditNode x xs) = PP.parens $ PP.hang (pp x) 2 $+-- PP.sep $ concatMap ppEdit xs+-- :} -- | A breadth-traversal diff. --@@ -51,7 +72,7 @@ -- >>> ppEditTree PP.char (treeDiff x w) -- (a b (c d +x e) f) ---treeDiff :: Eq a => Tree a -> Tree a -> Edit (EditTree a)+treeDiff :: (Show a, Eq a) => Tree a -> Tree a -> Edit (EditTree a) treeDiff ta@(Node a as) tb@(Node b bs) | a == b = Cpy $ EditNode a (map rec (diffBy (==) as bs)) | otherwise = Swp (treeToEdit ta) (treeToEdit tb)@@ -72,27 +93,3 @@ treeToEdit :: Tree a -> EditTree a treeToEdit = go where go (Node x xs) = EditNode x (map (Cpy . go) xs)--#ifdef __DOCTEST__-ppTree :: (a -> PP.Doc) -> Tree a -> PP.Doc-ppTree pp = ppT- where- ppT (Node x []) = pp x- ppT (Node x xs) = PP.parens $ PP.hang (pp x) 2 $- PP.sep $ map ppT xs--ppEditTree :: (a -> PP.Doc) -> Edit (EditTree a) -> PP.Doc-ppEditTree pp = PP.sep . ppEdit- where- ppEdit (Cpy tree) = [ ppTree tree ]- ppEdit (Ins tree) = [ PP.char '+' PP.<> ppTree tree ]- ppEdit (Del tree) = [ PP.char '-' PP.<> ppTree tree ]- ppEdit (Swp a b) =- [ PP.char '-' PP.<> ppTree a- , PP.char '+' PP.<> ppTree b- ]-- ppTree (EditNode x []) = pp x- ppTree (EditNode x xs) = PP.parens $ PP.hang (pp x) 2 $- PP.sep $ concatMap ppEdit xs-#endif
tests/Tests.hs view
@@ -1,14 +1,12 @@-{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveGeneric #-} module Main (main) where import Data.Proxy (Proxy (..))-import Data.TreeDiff-import Data.TreeDiff.Golden-import Data.TreeDiff.QuickCheck+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)@@ -18,15 +16,32 @@ 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.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 example1" $ diffByModel [7,1,6,0,0] [0,0,6,7,1,0,0]+ , testProperty "diffBy model" diffByModel , goldenTests ] ---------------------------------------------------------------------------------- QuickCheck: ediffEq+-- diffBy+-------------------------------------------------------------------------------++diffByModel :: [Word8] -> [Word8] -> Property+diffByModel xs ys =+ diffBy (==) xs ys === RefDiffBy.diffBy (==) xs ys++-------------------------------------------------------------------------------+-- Roundtrip ------------------------------------------------------------------------------- -- | This property tests that we can parse pretty printed 'Expr'.
tree-diff.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.2 name: tree-diff-version: 0.1+version: 0.2 synopsis: Diffing of (expression) trees. category: Data, Testing description:@@ -37,14 +37,25 @@ license-file: LICENSE author: Oleg Grenrus <oleg.grenrus@iki.fi> maintainer: Oleg.Grenrus <oleg.grenrus@iki.fi>-copyright: (c) 2017-2019 Oleg Grenrus+copyright: (c) 2017-2021 Oleg Grenrus build-type: Simple extra-source-files:- README.md ChangeLog.md+ README.md tested-with:- GHC ==8.8.1 || ==8.6.5 || ==8.4.4 || ==8.2.2 || ==8.0.2 || ==7.10.3 || ==7.8.4 || ==7.6.3 || ==7.4.2+ GHC ==7.4.2+ || ==7.6.3+ || ==7.8.4+ || ==7.10.3+ || ==8.0.2+ || ==8.2.2+ || ==8.4.4+ || ==8.6.5+ || ==8.8.4+ || ==8.10.4+ || ==9.0.1+ , GHCJS ==8.4 extra-source-files: fixtures/exfoo.expr@@ -64,6 +75,7 @@ Data.TreeDiff.Expr Data.TreeDiff.Golden Data.TreeDiff.List+ Data.TreeDiff.OMap Data.TreeDiff.Parser Data.TreeDiff.Pretty Data.TreeDiff.QuickCheck@@ -71,25 +83,30 @@ -- GHC boot libraries build-depends:- , base >=4.5 && <4.13- , bytestring ^>=0.9.2.1 || ^>=0.10.0.2+ , base >=4.5 && <4.16+ , bytestring ^>=0.9.2.1 || ^>=0.10.0.2 || ^>=0.11.0.0 , containers ^>=0.4.2.1 || ^>=0.5.0.0 || ^>=0.6.0.1+ , deepseq ^>=1.3.0.0 || ^>=1.4.0.0 , parsec ^>=3.1.13.0 , pretty ^>=1.1.1.0 , text ^>=1.2.3.0- , time ^>=1.4 || ^>=1.5.0.1 || ^>=1.6.0.1 || ^>=1.8.0.2+ , time ^>=1.4 || ^>=1.5.0.1 || ^>=1.6.0.1 || ^>=1.8.0.2 || ^>=1.9.3 build-depends:- , aeson ^>=1.4.0.0- , ansi-terminal ^>=0.8.2 || ^>=0.9.1+ , aeson ^>=1.4.6.0 || ^>=1.5.6.0+ , ansi-terminal >=0.10 && <0.12 , ansi-wl-pprint ^>=0.6.8.2- , base-compat ^>=0.10.5+ , base-compat ^>=0.10.5 || ^>=0.11.0 , bytestring-builder ^>=0.10.8.2.0 , hashable ^>=1.2.7.0 || ^>=1.3.0.0 , parsers ^>=0.12.10- , QuickCheck ^>=2.12.6.1 || ^>=2.13.1+ , primitive ^>=0.7.1.0+ , QuickCheck ^>=2.14.2 , scientific ^>=0.3.6.2+ , semialign >=1.1 && <1.3+ , strict ^>=0.4.0.1 , tagged ^>=0.8.6+ , these ^>=1.1.1.1 , unordered-containers ^>=0.2.8.0 , uuid-types ^>=1.0.3 , vector ^>=0.12@@ -98,10 +115,10 @@ build-depends: ghc-prim if !impl(ghc >=8.0)- build-depends: semigroups >=0.18.5 && <0.20+ build-depends: semigroups ^>=0.19.1 if !impl(ghc >=7.8)- build-depends: generic-deriving ^>=1.12.4+ build-depends: generic-deriving >=1.13.1 && <1.15 if !impl(ghc >=7.10) build-depends:@@ -122,25 +139,50 @@ hs-source-dirs: src default-language: Haskell2010 -test-suite test+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: , ansi-terminal , ansi-wl-pprint , base , base-compat , parsec+ , primitive , QuickCheck- , tasty ^>=1.2- , tasty-golden ^>=2.3.1.1- , tasty-quickcheck ^>=0.10.1 , tagged , tree-diff- , trifecta ^>=2 if impl(ghc <7.5) build-depends: ghc-prim++ -- extra dependencies+ build-depends:+ , tasty ^>=1.2 || ^>=1.3.1+ , tasty-golden ^>=2.3.1.1+ , tasty-quickcheck ^>=0.10.1+ , trifecta >=2 && <2.2++benchmark tree-diff-bench+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ main-is: tree-diff-bench.hs+ hs-source-dirs: bench+ ghc-options: -Wall -threaded++ -- dependencies from library+ build-depends:+ , base+ , deepseq+ , tree-diff++ -- extra dependencies+ build-depends:+ , criterion ^>=1.5.9.0+ , Diff ^>=0.4.0