tree-diff (empty) → 0
raw patch · 17 files changed
+1517/−0 lines, 17 filesdep +MemoTriedep +QuickCheckdep +aesonbuild-type:Customsetup-changed
Dependencies added: MemoTrie, QuickCheck, aeson, ansi-terminal, ansi-wl-pprint, base, base-compat, bytestring, containers, doctest, generics-sop, hashable, nats, parsec, parsers, pretty, scientific, semigroups, tagged, tasty, tasty-golden, tasty-quickcheck, template-haskell, text, time, transformers, tree-diff, trifecta, unordered-containers, uuid-types, vector, void
Files
- ChangeLog.md +5/−0
- LICENSE +30/−0
- README.md +17/−0
- Setup.hs +33/−0
- fixtures/exfoo.expr +4/−0
- src/Data/TreeDiff.hs +27/−0
- src/Data/TreeDiff/Class.hs +470/−0
- src/Data/TreeDiff/Expr.hs +102/−0
- src/Data/TreeDiff/Golden.hs +56/−0
- src/Data/TreeDiff/List.hs +63/−0
- src/Data/TreeDiff/Parser.hs +112/−0
- src/Data/TreeDiff/Pretty.hs +220/−0
- src/Data/TreeDiff/QuickCheck.hs +14/−0
- src/Data/TreeDiff/Tree.hs +98/−0
- tests/Tests.hs +112/−0
- tests/doctests.hs +12/−0
- tree-diff.cabal +142/−0
+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Revision history for tree-diff++## 0++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2017, Oleg Grenrus++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Oleg Grenrus nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,17 @@+# tree-diff++Diffing of (expression) trees.++## Examples++`tree-diff` displays pretty diffs of tree data:++++Because of its untyped internal type, it copes with type changes:++++As a bonus, multiline `String`s and `Text` are diffed linewise:++
+ Setup.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wall #-}+module Main (main) where++#ifndef MIN_VERSION_cabal_doctest+#define MIN_VERSION_cabal_doctest(x,y,z) 0+#endif++#if MIN_VERSION_cabal_doctest(1,0,0)++import Distribution.Extra.Doctest ( defaultMainWithDoctests )+main :: IO ()+main = defaultMainWithDoctests "doctests"++#else++#ifdef MIN_VERSION_Cabal+-- If the macro is defined, we have new cabal-install,+-- but for some reason we don't have cabal-doctest in package-db+--+-- Probably we are running cabal sdist, when otherwise using new-build+-- workflow+#warning You are configuring this package without cabal-doctest installed. \+ The doctests test-suite will not work as a result. \+ To fix this, install cabal-doctest before configuring.+#endif++import Distribution.Simple++main :: IO ()+main = defaultMain++#endif
+ fixtures/exfoo.expr view
@@ -0,0 +1,4 @@+Foo+ {fooBar = [Just "pub", Just (concat ["night\n", "club"])],+ fooInt = 42,+ fooQuu = _×_ 125.375 Proxy}
+ src/Data/TreeDiff.hs view
@@ -0,0 +1,27 @@+-- | Diffing of (expression) trees.+--+-- Diffing arbitrary Haskell data. First we convert values to untyped+-- haskell-like expression 'Expr' using generically derivable 'ToExpr' class.+-- Then we can diff two 'Expr' values.+-- The conversion and diffing is done by 'ediff' function.+-- See type and function haddocks for an examples.+--+-- Interesting modules:+--+-- * "Data.TreeDiff.Class" for a 'ToExpr' class and 'ediff' utility.+--+-- * "Data.TreeDiff.Golden" for golden tests helper+--+-- * "Data.TreeDiff.QuickCheck" for QuickCheck helper+--+module Data.TreeDiff (+ module Data.TreeDiff.Expr,+ module Data.TreeDiff.Class,+ module Data.TreeDiff.Pretty,+ module Data.TreeDiff.Parser,+ ) where++import Data.TreeDiff.Expr+import Data.TreeDiff.Class+import Data.TreeDiff.Pretty+import Data.TreeDiff.Parser
+ src/Data/TreeDiff/Class.hs view
@@ -0,0 +1,470 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+-- | A 'ToExpr' class.+module Data.TreeDiff.Class (+ ediff,+ ediff',+ ToExpr (..),+ defaultExprViaShow,+ -- * SOP+ sopToExpr,+ ) where++import Data.Foldable (toList)+import Data.Proxy (Proxy (..))+import Data.TreeDiff.Expr+import Data.List.Compat (uncons)+import Generics.SOP+ (All, All2, ConstructorInfo (..), DatatypeInfo (..), FieldInfo (..),+ I (..), K (..), NP (..), SOP (..), constructorInfo, hcliftA2, hcmap,+ hcollapse, mapIK)+import Generics.SOP.GGP (GCode, GDatatypeInfo, GFrom, gdatatypeInfo, gfrom)+import GHC.Generics (Generic)++import qualified Data.Map as Map++-- Instances+import Control.Applicative (Const (..), ZipList (..))+import Data.Fixed (Fixed, HasResolution)+import Data.Functor.Identity (Identity (..))+import Data.Int+import Data.List.NonEmpty (NonEmpty (..))+import Data.Void (Void)+import Data.Word+import Numeric.Natural (Natural)++import qualified Data.Monoid as Mon+import qualified Data.Ratio as Ratio+import qualified Data.Semigroup as Semi++-- containers+import qualified Data.IntMap as IntMap+import qualified Data.IntSet as IntSet+import qualified Data.Sequence as Seq+import qualified Data.Set as Set+import qualified Data.Tree as Tree++-- text+import qualified Data.Text as T+import qualified Data.Text.Lazy as LT++-- time+import qualified Data.Time as Time++-- bytestring+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS++-- scientific+import qualified Data.Scientific as Sci++-- uuid-types+import qualified Data.UUID.Types as UUID++-- vector+import qualified Data.Vector as V+import qualified Data.Vector.Primitive as VP+import qualified Data.Vector.Storable as VS+import qualified Data.Vector.Unboxed as VU++-- tagged+import Data.Tagged (Tagged (..))++-- hashable+import Data.Hashable (Hashed, unhashed)++-- unordered-containers+import qualified Data.HashMap.Strict as HM+import qualified Data.HashSet as HS++-- aeson+import qualified Data.Aeson as Aeson++-- | Difference between two 'ToExpr' values.+--+-- >>> let x = (1, Just 2) :: (Int, Maybe Int)+-- >>> let y = (1, Nothing)+-- >>> prettyEditExpr (ediff x y)+-- _×_ 1 -(Just 2) +Nothing+--+-- >>> data Foo = Foo { fooInt :: Either Char Int, fooBool :: [Maybe Bool], fooString :: String } deriving (Eq, Generic)+-- >>> 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"}+--+-- >>> 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"}+--+ediff :: ToExpr a => a -> a -> Edit EditExpr+ediff x y = exprDiff (toExpr x) (toExpr y)++-- | Compare different types.+--+-- /Note:/ Use with care as you can end up comparing apples with oranges.+--+-- >>> prettyEditExpr $ ediff' ["foo", "bar"] [Just "foo", Nothing]+-- [-"foo", +Just "foo", -"bar", +Nothing]+--+ediff' :: (ToExpr a, ToExpr b) => a -> b -> Edit EditExpr+ediff' x y = exprDiff (toExpr x) (toExpr y)++-- | 'toExpr' converts a Haskell value into+-- untyped Haskell-like syntax tree, 'Expr'.+--+-- >>> toExpr ((1, Just 2) :: (Int, Maybe Int))+-- App "_\215_" [App "1" [],App "Just" [App "2" []]]+--+class ToExpr a where+ toExpr :: a -> Expr+ default toExpr+ :: (Generic a, All2 ToExpr (GCode a), GFrom a, GDatatypeInfo a)+ => a -> Expr+ toExpr x = sopToExpr (gdatatypeInfo (Proxy :: Proxy a)) (gfrom x)++ listToExpr :: [a] -> Expr+ listToExpr = Lst . map toExpr++instance ToExpr Expr where+ toExpr = id++-- | An alternative implementation for literal types. We use 'show'+-- representation of them.+defaultExprViaShow :: Show a => a -> Expr+defaultExprViaShow x = App (show x) []++-- | >>> prettyExpr $ sopToExpr (gdatatypeInfo (Proxy :: Proxy String)) (gfrom "foo")+-- _:_ 'f' "oo"+sopToExpr :: (All2 ToExpr xss) => DatatypeInfo xss -> SOP I xss -> Expr+sopToExpr di (SOP xss) = hcollapse $ hcliftA2+ (Proxy :: Proxy (All ToExpr))+ (\ci xs -> K (sopNPToExpr isNewtype ci xs))+ (constructorInfo di)+ xss+ where+ isNewtype = case di of+ Newtype _ _ _ -> True+ ADT _ _ _ -> False++sopNPToExpr :: All ToExpr xs => Bool -> ConstructorInfo xs -> NP I xs -> Expr+sopNPToExpr _ (Infix cn _ _) xs = App ("_" ++ cn ++ "_") $ hcollapse $+ hcmap (Proxy :: Proxy ToExpr) (mapIK toExpr) xs+sopNPToExpr _ (Constructor cn) xs = App cn $ hcollapse $+ hcmap (Proxy :: Proxy ToExpr) (mapIK toExpr) xs+sopNPToExpr True (Record cn _) xs = App cn $ hcollapse $+ hcmap (Proxy :: Proxy ToExpr) (mapIK toExpr) xs+sopNPToExpr False (Record cn fi) xs = Rec cn $ Map.fromList $ hcollapse $+ hcliftA2 (Proxy :: Proxy ToExpr) mk fi xs+ where+ mk :: ToExpr x => FieldInfo x -> I x -> K (FieldName, Expr) x+ mk (FieldInfo fn) (I x) = K (fn, toExpr x)++-------------------------------------------------------------------------------+-- Instances+-------------------------------------------------------------------------------++instance ToExpr () where toExpr = defaultExprViaShow+instance ToExpr Bool where toExpr = defaultExprViaShow+instance ToExpr Ordering where toExpr = defaultExprViaShow++instance ToExpr Integer where toExpr = defaultExprViaShow+instance ToExpr Natural where toExpr = defaultExprViaShow++instance ToExpr Float where toExpr = defaultExprViaShow+instance ToExpr Double where toExpr = defaultExprViaShow++instance ToExpr Int where toExpr = defaultExprViaShow+instance ToExpr Int8 where toExpr = defaultExprViaShow+instance ToExpr Int16 where toExpr = defaultExprViaShow+instance ToExpr Int32 where toExpr = defaultExprViaShow+instance ToExpr Int64 where toExpr = defaultExprViaShow++instance ToExpr Word where toExpr = defaultExprViaShow+instance ToExpr Word8 where toExpr = defaultExprViaShow+instance ToExpr Word16 where toExpr = defaultExprViaShow+instance ToExpr Word32 where toExpr = defaultExprViaShow+instance ToExpr Word64 where toExpr = defaultExprViaShow++instance ToExpr (Proxy a) where toExpr = defaultExprViaShow++-- | >>> prettyExpr $ toExpr 'a'+-- 'a'+--+-- >>> prettyExpr $ toExpr "Hello world"+-- "Hello world"+--+-- >>> prettyExpr $ toExpr "Hello\nworld"+-- concat ["Hello\n", "world"]+--+-- >>> traverse_ (print . prettyExpr . toExpr) ["", "\n", "foo", "foo\n", "foo\nbar", "foo\nbar\n"]+-- ""+-- "\n"+-- "foo"+-- "foo\n"+-- concat ["foo\n", "bar"]+-- concat ["foo\n", "bar\n"]+--+instance ToExpr Char where+ toExpr = defaultExprViaShow+ listToExpr = stringToExpr "concat" . unconcat uncons++stringToExpr+ :: Show a+ => String -- ^ name of concat+ -> [a]+ -> Expr+stringToExpr _ [] = App "\"\"" []+stringToExpr _ [l] = defaultExprViaShow l+stringToExpr cn ls = App cn [Lst (map defaultExprViaShow ls)]++-- | Split on '\n'.+--+-- prop> \xs -> xs == concat (unconcat uncons xs)+unconcat :: forall a. (a -> Maybe (Char, a)) -> a -> [String]+unconcat uncons_ = go where+ go :: a -> [String]+ go xs = case span_ xs of+ ~(ys, zs)+ | null ys -> []+ | otherwise -> ys : go zs++ span_ :: a -> (String, a)+ span_ xs = case uncons_ xs of+ Nothing -> ("", xs)+ Just ~(x, xs')+ | x == '\n' -> ("\n", xs')+ | otherwise -> case span_ xs' of+ ~(ys, zs) -> (x : ys, zs)++instance ToExpr a => ToExpr (Maybe a) where+ toExpr Nothing = App "Nothing" []+ toExpr (Just x) = App "Just" [toExpr x]++instance (ToExpr a, ToExpr b) => ToExpr (Either a b) where+ toExpr (Left x) = App "Left" [toExpr x]+ toExpr (Right y) = App "Right" [toExpr y]++instance ToExpr a => ToExpr [a] where+ toExpr = listToExpr++instance (ToExpr a, ToExpr b) => ToExpr (a, b) where+ toExpr (a, b) = App "_×_" [toExpr a, toExpr b]+instance (ToExpr a, ToExpr b, ToExpr c) => ToExpr (a, b, c) where+ toExpr (a, b, c) = App "_×_×_" [toExpr a, toExpr b, toExpr c]+instance (ToExpr a, ToExpr b, ToExpr c, ToExpr d) => ToExpr (a, b, c, d) where+ toExpr (a, b, c, d) = App "_×_×_×_" [toExpr a, toExpr b, toExpr c, toExpr d]+instance (ToExpr a, ToExpr b, ToExpr c, ToExpr d, ToExpr e) => ToExpr (a, b, c, d, e) where+ toExpr (a, b, c, d, e) = App "_×_×_×_×_" [toExpr a, toExpr b, toExpr c, toExpr d, toExpr e]++-- | >>> prettyExpr $ toExpr (3 % 12 :: Rational)+-- _%_ 1 4+instance (ToExpr a, Integral a) => ToExpr (Ratio.Ratio a) where+ toExpr r = App "_%_" [ toExpr $ Ratio.numerator r, toExpr $ Ratio.denominator r ]+instance HasResolution a => ToExpr (Fixed a) where toExpr = defaultExprViaShow++-- | >>> prettyExpr $ toExpr $ Identity 'a'+-- Identity 'a'+instance ToExpr a => ToExpr (Identity a) where+ toExpr (Identity x) = App "Identity" [toExpr x]++instance ToExpr a => ToExpr (Const a b)+instance ToExpr a => ToExpr (ZipList a)++instance ToExpr a => ToExpr (NonEmpty a) where+ toExpr (x :| xs) = App "NE.fromList" [toExpr (x : xs)]++instance ToExpr Void where+ toExpr _ = App "error" [toExpr "Void"]++-------------------------------------------------------------------------------+-- Monoid/semigroups+-------------------------------------------------------------------------------++instance ToExpr a => ToExpr (Mon.Dual a) where+instance ToExpr a => ToExpr (Mon.Sum a) where+instance ToExpr a => ToExpr (Mon.Product a) where+instance ToExpr a => ToExpr (Mon.First a) where+instance ToExpr a => ToExpr (Mon.Last a) where++instance ToExpr a => ToExpr (Semi.Option a) where+instance ToExpr a => ToExpr (Semi.Min a) where+instance ToExpr a => ToExpr (Semi.Max a) where+instance ToExpr a => ToExpr (Semi.First a) where+instance ToExpr a => ToExpr (Semi.Last a) where++-------------------------------------------------------------------------------+-- containers+-------------------------------------------------------------------------------++instance ToExpr a => ToExpr (Tree.Tree a) where+ toExpr (Tree.Node x xs) = App "Node" [toExpr x, toExpr xs]++instance (ToExpr k, ToExpr v) => ToExpr (Map.Map k v) where+ toExpr x = App "Map.fromList" [ toExpr $ Map.toList x ]+instance (ToExpr k) => ToExpr (Set.Set k) where+ toExpr x = App "Set.fromList" [ toExpr $ Set.toList x ]+instance (ToExpr v) => ToExpr (IntMap.IntMap v) where+ toExpr x = App "IntMap.fromList" [ toExpr $ IntMap.toList x ]+instance ToExpr IntSet.IntSet where+ toExpr x = App "IntSet.fromList" [ toExpr $ IntSet.toList x ]+instance (ToExpr v) => ToExpr (Seq.Seq v) where+ toExpr x = App "Seq.fromList" [ toExpr $ toList x ]++-------------------------------------------------------------------------------+-- text+-------------------------------------------------------------------------------++-- | >>> traverse_ (print . prettyExpr . toExpr . LT.pack) ["", "\n", "foo", "foo\n", "foo\nbar", "foo\nbar\n"]+-- ""+-- "\n"+-- "foo"+-- "foo\n"+-- LT.concat ["foo\n", "bar"]+-- LT.concat ["foo\n", "bar\n"]+instance ToExpr LT.Text where+ toExpr = stringToExpr "LT.concat" . unconcat LT.uncons++-- | >>> traverse_ (print . prettyExpr . toExpr . T.pack) ["", "\n", "foo", "foo\n", "foo\nbar", "foo\nbar\n"]+-- ""+-- "\n"+-- "foo"+-- "foo\n"+-- T.concat ["foo\n", "bar"]+-- T.concat ["foo\n", "bar\n"]+instance ToExpr T.Text where+ toExpr = stringToExpr "T.concat" . unconcat T.uncons++-------------------------------------------------------------------------------+-- time+-------------------------------------------------------------------------------++-- | >>> prettyExpr $ toExpr $ ModifiedJulianDay 58014+-- Day "2017-09-18"+instance ToExpr Time.Day where+ toExpr d = App "Day" [ toExpr (show d) ]++instance ToExpr Time.UTCTime where+ toExpr t = App "UTCTime" [ toExpr (show t) ]++-------------------------------------------------------------------------------+-- bytestring+-------------------------------------------------------------------------------++-- | >>> traverse_ (print . prettyExpr . toExpr . LBS8.pack) ["", "\n", "foo", "foo\n", "foo\nbar", "foo\nbar\n"]+-- ""+-- "\n"+-- "foo"+-- "foo\n"+-- LBS.concat ["foo\n", "bar"]+-- LBS.concat ["foo\n", "bar\n"]+instance ToExpr LBS.ByteString where+ toExpr = stringToExpr "LBS.concat" . bsUnconcat LBS.null LBS.elemIndex LBS.splitAt++-- | >>> traverse_ (print . prettyExpr . toExpr . BS8.pack) ["", "\n", "foo", "foo\n", "foo\nbar", "foo\nbar\n"]+-- ""+-- "\n"+-- "foo"+-- "foo\n"+-- BS.concat ["foo\n", "bar"]+-- BS.concat ["foo\n", "bar\n"]+instance ToExpr BS.ByteString where+ toExpr = stringToExpr "BS.concat" . bsUnconcat BS.null BS.elemIndex BS.splitAt++bsUnconcat+ :: forall bs int. Num int+ => (bs -> Bool)+ -> (Word8 -> bs -> Maybe int)+ -> (int -> bs -> (bs, bs))+ -> bs+ -> [bs]+bsUnconcat null_ elemIndex_ splitAt_ = go where+ go :: bs -> [bs]+ go bs+ | null_ bs = []+ | otherwise = case elemIndex_ 10 bs of+ Nothing -> [bs]+ Just i -> case splitAt_ (i + 1) bs of+ (bs0, bs1) -> bs0 : go bs1++-------------------------------------------------------------------------------+-- scientific+-------------------------------------------------------------------------------++-- | >>> prettyExpr $ toExpr (123.456 :: Scientific)+-- scientific 123456 `-3`+instance ToExpr Sci.Scientific where+ toExpr s = App "scientific" [ toExpr $ Sci.coefficient s, toExpr $ Sci.base10Exponent s ]++-------------------------------------------------------------------------------+-- uuid-types+-------------------------------------------------------------------------------++-- | >>> prettyExpr $ toExpr UUID.nil+-- UUID "00000000-0000-0000-0000-000000000000"+instance ToExpr UUID.UUID where+ toExpr u = App "UUID" [ toExpr $ UUID.toString u ]++-------------------------------------------------------------------------------+-- vector+-------------------------------------------------------------------------------++instance ToExpr a => ToExpr (V.Vector a) where+ toExpr x = App "V.fromList" [ toExpr $ V.toList x ]+instance (ToExpr a, VU.Unbox a) => ToExpr (VU.Vector a) where+ toExpr x = App "VU.fromList" [ toExpr $ VU.toList x ]+instance (ToExpr a, VS.Storable a) => ToExpr (VS.Vector a) where+ toExpr x = App "VS.fromList" [ toExpr $ VS.toList x ]+instance (ToExpr a, VP.Prim a) => ToExpr (VP.Vector a) where+ toExpr x = App "VP.fromList" [ toExpr $ VP.toList x ]++-------------------------------------------------------------------------------+-- tagged+-------------------------------------------------------------------------------++instance ToExpr a => ToExpr (Tagged t a) where+ toExpr (Tagged x) = App "Tagged" [ toExpr x ]++-------------------------------------------------------------------------------+-- hashable+-------------------------------------------------------------------------------++instance ToExpr a => ToExpr (Hashed a) where+ toExpr x = App "hashed" [ toExpr $ unhashed x ]++-------------------------------------------------------------------------------+-- unordered-containers+-------------------------------------------------------------------------------++instance (ToExpr k, ToExpr v) => ToExpr (HM.HashMap k v) where+ toExpr x = App "HM.fromList" [ toExpr $ HM.toList x ]+instance (ToExpr k) => ToExpr (HS.HashSet k) where+ toExpr x = App "HS.fromList" [ toExpr $ HS.toList x ]++-------------------------------------------------------------------------------+-- aeson+-------------------------------------------------------------------------------++instance ToExpr Aeson.Value++-------------------------------------------------------------------------------+-- Doctest+-------------------------------------------------------------------------------++-- $setup+-- >>> :set -XDeriveGeneric+-- >>> :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
+ src/Data/TreeDiff/Expr.hs view
@@ -0,0 +1,102 @@+-- | This module uses 'Expr' for richer diffs than based on 'Tree'.+module Data.TreeDiff.Expr (+ -- * Types+ Expr (..),+ ConstructorName,+ FieldName,+ EditExpr (..),+ Edit (..),+ exprDiff,+ ) where++import Prelude ()+import Prelude.Compat++import Data.Map (Map)+import Data.TreeDiff.List++import qualified Data.Map as Map+import qualified Test.QuickCheck as QC++-- | Constructor name is a string+type ConstructorName = String+--+-- | Record field name is a string too.+type FieldName = String++-- | A untyped Haskell-like expression.+--+-- Having richer structure than just 'Tree' allows to have richer diffs.+data Expr+ = App ConstructorName [Expr] -- ^ application+ | Rec ConstructorName (Map FieldName Expr) -- ^ record constructor+ | Lst [Expr] -- ^ list constructor+ deriving (Eq, Show)++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+ ]+ arb n | otherwise = do+ n' <- QC.choose (0, n `div` 3)+ QC.oneof+ [ App <$> arbName <*> QC.liftArbitrary (arb n')+ , Rec <$> arbName <*> QC.liftArbitrary (arb n')+ , Lst <$> QC.liftArbitrary (arb n')+ ]++ shrink (Lst es) = es+ ++ [ Lst es' | es' <- QC.shrink es ]+ shrink (Rec n fs) = Map.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 ]+ ++ [ App n es' | es' <- QC.shrink es ]++arbName :: QC.Gen String+arbName = QC.frequency+ [ (10, QC.liftArbitrary $ QC.elements $ ['a'..'z'] ++ ['0' .. '9'] ++ "+-_:")+ , (1, show <$> (QC.arbitrary :: QC.Gen String))+ , (1, QC.arbitrary)+ , (1, QC.elements ["_×_", "_×_×_", "_×_×_×_"])+ ]++-- | Diff two 'Expr'.+--+-- For examples see 'ediff' in "Data.TreeDiff.Class".+exprDiff :: Expr -> Expr -> Edit EditExpr+exprDiff = impl+ where+ impl ea eb | ea == eb = Cpy (EditExp ea)++ impl ea@(App a as) eb@(App b bs)+ | a == b = Cpy $ EditApp a (map recurse (diffBy (==) as bs))+ | otherwise = Swp (EditExp ea) (EditExp eb)+ impl ea@(Rec a as) eb@(Rec b bs)+ | a == b = Cpy $ EditRec a $ Map.unions [inter, onlyA, onlyB]+ | 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)+ impl (Lst as) (Lst bs) =+ Cpy $ EditLst (map recurse (diffBy (==) as bs))++ -- If higher level doesn't match, just swap.+ impl a b = Swp (EditExp a) (EditExp b)++ recurse (Ins x) = Ins (EditExp x)+ recurse (Del y) = Del (EditExp y)+ recurse (Cpy z) = Cpy (EditExp z)+ recurse (Swp x y) = impl x y++-- | Type used in the result of 'ediff'.+data EditExpr+ = EditApp ConstructorName [Edit EditExpr]+ | EditRec ConstructorName (Map FieldName (Edit EditExpr))+ | EditLst [Edit EditExpr]+ | EditExp Expr -- ^ unchanged tree+ deriving Show
+ src/Data/TreeDiff/Golden.hs view
@@ -0,0 +1,56 @@+-- | "Golden tests" using 'ediff' comparison.+module Data.TreeDiff.Golden (+ ediffGolden,+ ) where++import Data.TreeDiff+import Prelude ()+import Prelude.Compat+import System.Console.ANSI (SGR (Reset), setSGRCode)+import Text.Parsec (eof, parse)+import Text.Parsec.Text ()++import qualified Data.Text as T+import qualified Data.Text.IO as T++-- | Make a golden tests.+--+-- 'ediffGolden' is testing framework agnostic, thus the test framework+-- looks intimdating.+--+-- An example using @tasty-golden@,+-- 'goldenTest' is imported from "Test.Tasty.Golden.Advanced"+--+-- @+-- exTest :: TestTree+-- exTest = 'ediffGolden' goldenTest "golden test" "fixtures/ex.expr" $+-- action constructing actual value+-- @+--+-- The 'ediffGolden' will read an 'Expr' from provided path to golden file,+-- and compare it with a 'toExpr' of a result. If values differ,+-- the diff of two will be printed.+--+-- See <https://github.com/phadej/tree-diff/blob/master/tests/Tests.hs>+-- for a proper example.+--+ediffGolden+ :: (Eq a, ToExpr a)+ => (testName -> IO Expr -> IO Expr -> (Expr -> Expr -> IO (Maybe String)) -> (Expr -> IO ()) -> testTree) -- ^ 'goldenTest'+ -> testName -- ^ test name+ -> FilePath -- ^ path to "golden file"+ -> IO a -- ^ result value+ -> testTree+ediffGolden impl testName fp x = impl testName expect actual cmp wrt+ where+ actual = fmap toExpr x+ expect = do+ contents <- T.readFile fp+ case parse (exprParser <* eof) fp 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 (ansiWlEditExpr $ ediff a b)+ wrt expr = T.writeFile fp $ T.pack $ show (prettyExpr expr) ++ "\n"
+ src/Data/TreeDiff/List.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE ScopedTypeVariables #-}+-- | A list diff.+module Data.TreeDiff.List (diffBy, Edit (..)) where++import Data.List.Compat (sortOn)+import qualified Data.MemoTrie as M+import qualified Data.Vector as V++-- | List edit operations+--+-- The 'Swp' constructor is redundant, but it let us spot+-- a recursion point when performing tree diffs.+data Edit a+ = Ins a -- ^ insert+ | Del a -- ^ delete+ | Cpy a -- ^ copy unchanged+ | Swp a a -- ^ swap, i.e. delete + insert+ deriving Show++-- | List difference.+--+-- >>> diffBy (==) "hello" "world"+-- [Swp 'h' 'w',Swp 'e' 'o',Swp 'l' 'r',Cpy 'l',Swp 'o' 'd']+--+-- >>> diffBy (==) "kitten" "sitting"+-- [Swp 'k' 's',Cpy 'i',Cpy 't',Cpy 't',Swp 'e' 'i',Cpy 'n',Ins 'g']+--+-- 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 (V.length xs) (V.length ys)))+ where+ xs = V.fromList xs'+ ys = V.fromList ys'++ lcs = M.memo2 impl++ 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 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)++ edit+ | eq x y = bimap id (Cpy x :) (lcs (n - 1) (m - 1))+ | otherwise = bimap (+1) (Swp x y :) (lcs (n -1 ) (m - 1))++bimap :: (a -> c) -> (b -> d) -> (a, b) -> (c, d)+bimap f g (x, y) = (f x, g y)
+ src/Data/TreeDiff/Parser.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE ScopedTypeVariables #-}+-- | Utilities to parse 'Expr'.+--+-- /Note:/ we don't parse diffs.+module Data.TreeDiff.Parser (+ exprParser+ ) where++import Control.Applicative (optional, (<|>))+import Data.Char (chr, isAlphaNum, isPunctuation, isSymbol)+import Prelude ()+import Prelude.Compat++import Text.Parser.Char+import Text.Parser.Combinators+import Text.Parser.Token+import Text.Parser.Token.Highlight++import Data.TreeDiff.Expr++import qualified Data.Map as Map++-- | Parsers for 'Expr' using @parsers@ type-classes.+--+-- You can use this with your parser-combinator library of choice:+-- @parsec@, @attoparsec@, @trifecta@...+exprParser :: (Monad m, TokenParsing m) => m Expr+exprParser = apprecP <|> lstP++lstP :: forall m. (Monad m, TokenParsing m) => m Expr+lstP = Lst <$> brackets (commaSep exprParser)+ <?> "list"++apprecP :: forall m. (Monad m, TokenParsing m) => m Expr+apprecP = do+ r <- recP+ case r of+ Right e -> return e+ Left n -> App n <$> many litP'++fieldP :: forall m. (Monad m, TokenParsing m) => m (FieldName, Expr)+fieldP = (,) <$> litP <* symbolic '=' <*> exprParser++litP :: forall m. (Monad m, TokenParsing m) => m String+litP = atomP <|> identP <|> stringP++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))++litP' :: forall m. (Monad m, TokenParsing m) => m Expr+litP' = mk <$> recP <|> parens exprParser <|> lstP+ where+ mk (Left n) = App n []+ mk (Right e) = e++identP :: forall m. (Monad m, TokenParsing m) => m String+identP = token (highlight Identifier lit) where+ lit :: m [Char]+ lit = (:) <$> firstLetter <*> many restLetter+ <?> "identifier"++ firstLetter :: m Char+ firstLetter = satisfy (\c -> valid' c && c /= '-' && c /= '+')++ restLetter :: m Char+ restLetter = satisfy valid'++stringP :: forall m. (Monad m, TokenParsing m) => m String+stringP = token (highlight StringLiteral lit) where+ lit :: m [Char]+ lit = mk <$> between (char '"') (char '"' <?> "end of string") (many stringChar)+ <?> "atom"++ mk :: [[Char]] -> String+ mk ss = "\"" ++ concat ss ++ "\""++ stringChar :: m [Char]+ stringChar = stringLetter <|> stringEscape+ <?> "string character"++ stringEscape :: m [Char]+ stringEscape = (\x y -> [x,y]) <$> char '\\' <*> anyChar++ stringLetter :: m [Char]+ stringLetter = return <$> satisfy (\c -> c /= '\\' && c /= '"')++atomP :: forall m. (Monad m, TokenParsing m) => m String+atomP = token (highlight Symbol lit) where+ lit :: m [Char]+ lit = between (char '`') (char '`' <?> "end of atom") (many atomChar)+ <?> "atom"++ atomChar :: m Char+ atomChar = atomLetter <|> atomEscape <|> char ' '+ <?> "atom character"++ atomEscape :: m Char+ atomEscape = char '\\' *> (char '\\' <|> char '`' <|> escapedHex)++ escapedHex :: m Char+ escapedHex = chr . fromInteger <$> hexadecimal <* char ';'++ atomLetter :: m Char+ atomLetter = satisfy (\c -> c /= '\\' && c /= '`' && valid c)++valid :: Char -> Bool+valid c = isAlphaNum c || isSymbol c || isPunctuation c++valid' :: Char -> Bool+valid' c = valid c && c `notElem` "[](){}`\","
+ src/Data/TreeDiff/Pretty.hs view
@@ -0,0 +1,220 @@+-- | Utilities to pretty print 'Expr' and 'EditExpr'+module Data.TreeDiff.Pretty (+ -- * Explicit dictionary+ Pretty (..),+ ppExpr,+ ppEditExpr,+ -- * pretty+ prettyPretty,+ prettyExpr,+ prettyEditExpr,+ -- * ansi-wl-pprint+ ansiWlPretty,+ ansiWlExpr,+ ansiWlEditExpr,+ -- ** background+ ansiWlBgPretty,+ ansiWlBgExpr,+ ansiWlBgEditExpr,+ -- * Utilities+ escapeName,+ ) where++import Data.Char (isAlphaNum, isPunctuation, isSymbol, ord)+import Data.TreeDiff.Expr+import Numeric (showHex)+import Text.Read (readMaybe)++import qualified Data.Map as Map+import qualified Text.PrettyPrint as HJ+import qualified Text.PrettyPrint.ANSI.Leijen as WL++-- | 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+ }++-- | Escape field or constructor name+--+-- >>> putStrLn $ escapeName "Foo"+-- Foo+--+-- >>> putStrLn $ escapeName "_×_"+-- _×_+--+-- >>> putStrLn $ escapeName "-3"+-- `-3`+--+-- >>> putStrLn $ escapeName "kebab-case"+-- kebab-case+--+-- >>> putStrLn $ escapeName "inner space"+-- `inner space`+--+-- >>> putStrLn $ escapeName $ show "looks like a string"+-- "looks like a string"+--+-- >>> putStrLn $ escapeName $ show "tricky" ++ " "+-- `"tricky" `+--+-- >>> putStrLn $ escapeName "[]"+-- `[]`+--+-- >>> putStrLn $ escapeName "_,_"+-- `_,_`+--+escapeName :: String -> String+escapeName n+ | null n = "``"+ | isValidString n = n+ | all valid' n && headNotMP n = n+ | otherwise = "`" ++ concatMap e n ++ "`"+ where+ e '`' = "\\`"+ e '\\' = "\\\\"+ e ' ' = " "+ e c | not (valid c) = "\\x" ++ showHex (ord c) ";"+ e c = [c]++ valid c = isAlphaNum c || isSymbol c || isPunctuation c+ valid' c = valid c && c `notElem` "[](){}`\","++ headNotMP ('-' : _) = False+ headNotMP ('+' : _) = False+ headNotMP _ = True++ isValidString s+ | length s >= 2 && head s == '"' && last s == '"' =+ case readMaybe s :: Maybe String of+ Just _ -> True+ Nothing -> False+ isValidString _ = False++-- | Pretty print an 'Expr' using explicit pretty-printing dictionary.+ppExpr :: Pretty doc -> Expr -> doc+ppExpr p = ppExpr' p False++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 _ (Lst xs) = ppLst p (map (impl False) xs)++ ppField' (n, e) = (escapeName n, impl False e)++ ppParens' True = ppParens p+ ppParens' False = id++-- | Pretty print an @'Edit' 'EditExpr'@ using explicit pretty-printing dictionary.+ppEditExpr :: Pretty doc -> Edit EditExpr -> doc+ppEditExpr p = ppSep p . ppEdit False+ where+ 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) ]+ ppEdit b (Del expr) = [ ppDel p (ppEExpr b expr) ]+ ppEdit b (Swp x y) =+ [ ppDel p (ppEExpr b x)+ , ppIns p (ppEExpr b y)+ ]++ 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 $+ map ppField' $ Map.toList xs+ ppEExpr _ (EditLst xs) = ppLst p (concatMap (ppEdit False) xs)+ ppEExpr b (EditExp x) = ppExpr' p b x++ ppField' (n, e) = (escapeName n, ppSep p $ ppEdit False e)++ ppParens' True = ppParens p+ ppParens' False = id++-------------------------------------------------------------------------------+-- pretty+-------------------------------------------------------------------------------++-- | 'Pretty' via @pretty@ library.+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+ , ppCpy = id+ , ppIns = \d -> HJ.char '+' HJ.<> d+ , ppDel = \d -> HJ.char '-' HJ.<> d+ , ppSep = HJ.sep+ , ppParens = HJ.parens+ , ppHang = \d1 d2 -> HJ.hang d1 2 d2+ }++-- | Pretty print 'Expr' using @pretty@.+--+-- >>> prettyExpr $ Rec "ex" (Map.fromList [("[]", App "bar" [])])+-- ex {`[]` = bar}+prettyExpr :: Expr -> HJ.Doc+prettyExpr = ppExpr prettyPretty++-- | Pretty print @'Edit' 'EditExpr'@ using @pretty@.+prettyEditExpr :: Edit EditExpr -> HJ.Doc+prettyEditExpr = ppEditExpr prettyPretty++-------------------------------------------------------------------------------+-- ansi-wl-pprint+-------------------------------------------------------------------------------++-- | 'Pretty' via @ansi-wl-pprint@ library (with colors).+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+ , 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+ , ppParens = WL.parens+ , ppHang = \d1 d2 -> WL.hang 2 (d1 WL.</> d2)+ }++-- | Pretty print 'Expr' using @ansi-wl-pprint@.+ansiWlExpr :: Expr -> WL.Doc+ansiWlExpr = ppExpr ansiWlPretty++-- | Pretty print @'Edit' 'EditExpr'@ using @ansi-wl-pprint@.+ansiWlEditExpr :: Edit EditExpr -> WL.Doc+ansiWlEditExpr = ppEditExpr ansiWlPretty++-------------------------------------------------------------------------------+-- Background+-------------------------------------------------------------------------------++-- | Like 'ansiWlPretty' but color the background.+ansiWlBgPretty :: Pretty WL.Doc+ansiWlBgPretty = ansiWlPretty+ { ppIns = \d -> WL.ondullgreen $ WL.white $ WL.plain $ WL.char '+' WL.<> d+ , ppDel = \d -> WL.ondullred $ WL.white $ WL.plain $ WL.char '-' WL.<> d+ } ++-- | Pretty print 'Expr' using @ansi-wl-pprint@.+ansiWlBgExpr :: Expr -> WL.Doc+ansiWlBgExpr = ppExpr ansiWlBgPretty++-- | Pretty print @'Edit' 'EditExpr'@ using @ansi-wl-pprint@.+ansiWlBgEditExpr :: Edit EditExpr -> WL.Doc+ansiWlBgEditExpr = ppEditExpr ansiWlBgPretty
+ src/Data/TreeDiff/QuickCheck.hs view
@@ -0,0 +1,14 @@+-- | @QuickCheck@ related utilities.+module Data.TreeDiff.QuickCheck (+ ediffEq,+ ) where++import Data.TreeDiff+import System.Console.ANSI (SGR (Reset), setSGRCode)+import Test.QuickCheck (Property, counterexample)++-- | A variant of '===', which outputs a diff when values are inequal.+ediffEq :: (Eq a, ToExpr a) => a -> a -> Property+ediffEq x y = counterexample+ (setSGRCode [Reset] ++ show (ansiWlEditExpr $ ediff x y))+ (x == y)
+ src/Data/TreeDiff/Tree.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE CPP #-}+-- | Tree diffing working on @containers@ 'Tree'.+module Data.TreeDiff.Tree (treeDiff, EditTree (..), Edit (..)) where++import Data.Tree (Tree (..))+import Data.TreeDiff.List++#ifdef __DOCTEST__+import qualified Text.PrettyPrint as PP+#endif++-- | A breadth-traversal diff.+--+-- It's different from @gdiff@, as it doesn't produce a flat edit script,+-- but edit script iself is a tree. This makes visualising the diff much+-- simpler.+--+-- ==== Examples+--+-- Let's start from simple tree. We pretty print them as s-expressions.+--+-- >>> let x = Node 'a' [Node 'b' [], Node 'c' [return 'd', return 'e'], Node 'f' []]+-- >>> ppTree PP.char x+-- (a b (c d e) f)+--+-- If we modify an argument in a tree, we'll notice it's changed:+--+-- >>> let y = Node 'a' [Node 'b' [], Node 'c' [return 'x', return 'e'], Node 'f' []]+-- >>> ppTree PP.char y+-- (a b (c x e) f)+--+-- >>> ppEditTree PP.char (treeDiff x y)+-- (a b (c -d +x e) f)+--+-- If we modify a constructor, the whole sub-trees is replaced, though there+-- might be common subtrees.+--+-- >>> let z = Node 'a' [Node 'b' [], Node 'd' [], Node 'f' []]+-- >>> ppTree PP.char z+-- (a b d f)+--+-- >>> ppEditTree PP.char (treeDiff x z)+-- (a b -(c d e) +d f)+--+-- If we add arguments, they are spotted too:+--+-- >>> let w = Node 'a' [Node 'b' [], Node 'c' [return 'd', return 'x', return 'e'], Node 'f' []]+-- >>> ppTree PP.char w+-- (a b (c d x e) f)+--+-- >>> ppEditTree PP.char (treeDiff x w)+-- (a b (c d +x e) f)+--+treeDiff :: 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)+ where+ rec (Ins x) = Ins (treeToEdit x)+ rec (Del y) = Del (treeToEdit y)+ rec (Cpy z) = Cpy (treeToEdit z)+ rec (Swp x y) = treeDiff x y++-- | Type used in the result of 'treeDiff'.+--+-- It's essentially a 'Tree', but the forest list is changed from+-- @[tree a]@ to @['Edit' (tree a)]@. This highlights that+-- 'treeDiff' performs a list diff on each tree level.+data EditTree a+ = EditNode a [Edit (EditTree a)]+ deriving Show++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
@@ -0,0 +1,112 @@+{-# 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+import Test.QuickCheck (Property, counterexample)+import Test.Tasty (TestTree, defaultMain, testGroup)+import Test.Tasty.Golden.Advanced (goldenTest)+import Test.Tasty.QuickCheck (testProperty)++import qualified Text.Parsec as P+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 (..))++main :: IO ()+main = defaultMain $ testGroup "tests"+ [ testProperty "trifecta-pretty roundtrip" roundtripTrifectaPretty+ , testProperty "parsec-ansi-wl-pprint roundtrip" roundtripParsecAnsiWl+ , exFooTests+ ]++-------------------------------------------------------------------------------+-- QuickCheck: ediffEq+-------------------------------------------------------------------------------++-- | This property tests that we can parse pretty printed 'Expr'.+--+-- We demonstrate the use of 'ediffEq'. We could used '===' there,+-- but now the nice diff will be printed as well+-- (as there is 'ToExpr Expr' instance).+roundtripTrifectaPretty :: Expr -> Property+roundtripTrifectaPretty e = counterexample info $ ediffEq (Just e) res'+ where+ doc = show (prettyExpr e)+ res = T.parseString (exprParser <* T.eof) mempty doc++ info = case res of+ T.Success e' ->+ doc+ ++ "\n" +++ show e'+ T.Failure err ->+ doc+ ++ "\n" +++ show (T._errDoc err)++ res' = case res of+ T.Success e' -> Just e'+ T.Failure _ -> Nothing++roundtripParsecAnsiWl :: Expr -> Property+roundtripParsecAnsiWl e = counterexample info $ ediffEq (Just e) res'+ where+ doc = show (WL.plain (ansiWlExpr e))+ res = P.parse (exprParser <* P.eof) "<memory>" doc++ info = case res of+ Right e' ->+ doc+ ++ "\n" +++ show e'+ Left err ->+ doc+ ++ "\n" +++ show err++ res' = either (const Nothing) Just res++-------------------------------------------------------------------------------+-- Golden+-------------------------------------------------------------------------------++-- | This test case verifies that we don't change 'Foo' or 'exFoo'.+--+-- We demonstrate the use of 'ediffGolden'.+--+-- First we declare a type, make it instance of 'ToExpr' and define+-- an example value 'exFoo'. In real-world you might e.g. read the source+-- file and parse it into the AST type.+--+-- Then we create a golden test that verifies that version we got now,+-- is the same we had previously. @tree-diff@ seralises the 'Expr',+-- not the original value. This is a design trade-off:+-- as we can always deserialise we can better diff the values even the+-- type is changed, e.g. the fields is added.+data Foo = Foo+ { fooInt :: Int+ , fooBar :: [Maybe String]+ , fooQuu :: (Double, Proxy ())+ -- , fooNew :: Bool+ }+ deriving (Eq, Show, Generic)++instance ToExpr Foo++exFoo :: Foo+exFoo = Foo+ { fooInt = 42+ , fooBar = [Just "pub", Just "night\nclub"]+ , fooQuu = (125.375, Proxy)+ -- , fooNew = True+ }++exFooTests :: TestTree+exFooTests = ediffGolden goldenTest "golden exFoo" "fixtures/exfoo.expr" $+ return exFoo
+ tests/doctests.hs view
@@ -0,0 +1,12 @@+module Main where++import Build_doctests (flags, pkgs, module_sources)+import Data.Foldable (traverse_)+import Test.DocTest++main :: IO ()+main = do+ traverse_ putStrLn args+ doctest args+ where+ args = flags ++ pkgs ++ module_sources
+ tree-diff.cabal view
@@ -0,0 +1,142 @@+name: tree-diff+version: 0+synopsis: Diffing of (expression) trees.+description:+ Common diff algorithm works on list structures:+ .+ @+ diff :: Eq a => [a] -> [a] -> [Edit a]+ @+ .+ This package works on trees.+ .+ @+ treeDiff :: Eq a => Tree a -> Tree a -> Edit (EditTree a)+ @+ .+ This package also provides a way to diff arbitrary ADTs,+ using @Generics@-derivable helpers.+ .+ This package differs from <http://hackage.haskell.org/package/gdiff gdiff>,+ in a two ways: @tree-diff@ doesn't have patch function,+ and the "edit-script" is a tree itself, which is useful for pretty-printing.+ .+ @+ >>> prettyEditExpr $ ediff (Foo 42 [True, False] "old") (Foo 42 [False, False, True] "new")+ Foo+ {fooBool = [-True, +False, False, +True],+ fooInt = 42,+ fooString = -"old" +"new"}+ @+homepage: https://github.com/phadej/tree-diff+bug-reports: https://github.com/phadej/tree-diff/issues+license: BSD3+license-file: LICENSE+author: Oleg Grenrus <oleg.grenrus@iki.fi>+maintainer: Oleg.Grenrus <oleg.grenrus@iki.fi>+copyright: (c) 2017 Oleg Grenrus+category: Data+build-type: Custom+extra-source-files: README.md ChangeLog.md+cabal-version: >=1.10+tested-with:+ GHC==7.8.4,+ GHC==7.10.3,+ GHC==8.0.2,+ GHC==8.2.1+extra-source-files:+ fixtures/exfoo.expr++custom-setup+ setup-depends:+ base, Cabal, cabal-doctest >=1.0.2 && <1.1++source-repository head+ type: git+ location: https://github.com/phadej/tree-diff.git++library+ exposed-modules:+ Data.TreeDiff+ Data.TreeDiff.List+ Data.TreeDiff.Tree+ Data.TreeDiff.Expr+ Data.TreeDiff.Class+ Data.TreeDiff.Pretty+ Data.TreeDiff.Parser+ Data.TreeDiff.Golden+ Data.TreeDiff.QuickCheck+ build-depends:+ base >=4.7 && <4.11,+ aeson >=1.2.1.0 && <1.3,+ ansi-wl-pprint >=0.6.8.1 && <0.7,+ ansi-terminal >=0.6.3.1 && <0.7,+ base-compat >=0.9.3 && <0.10,+ bytestring >=0.10.4.0 && <0.11,+ containers >=0.5.5.1 && <0.6,+ generics-sop >=0.3.1.0 && <0.4,+ hashable >=1.2.6.1 && <1.3,+ MemoTrie >=0.6.8 && <0.7,+ parsec >=3.1.11 && <3.2,+ parsers >=0.12.7 && <0.13,+ pretty >=1.1.1.1 && <1.2,+ QuickCheck >=2.10.0.1 && <2.11,+ scientific >=0.3.5.2 && <0.4,+ tagged >=0.8.5 && <0.9,+ text >=1.2.2.2 && <1.3,+ time >=1.4.2 && <1.9,+ unordered-containers >=0.2.8.0 && <0.3,+ uuid-types >=1.0.3 && <1.1,+ vector >=0.12 && <0.13++ if !impl(ghc >= 8.0)+ build-depends:+ semigroups >=0.18.3 && <0.19++ if !impl(ghc >= 7.10)+ build-depends:+ void >=0.7.2 && <0.8,+ nats >=1.1.1 && <1.2,+ transformers >=0.3.0.0 && <0.6++ other-extensions:+ ConstraintKinds+ CPP+ DefaultSignatures+ FlexibleContexts+ GADTs+ RankNTypes+ ScopedTypeVariables+ hs-source-dirs: src+ default-language: Haskell2010++test-suite doctests+ type: exitcode-stdio-1.0+ main-is: doctests.hs+ x-doctest-options: -D__DOCTEST__+ build-depends:+ base,+ doctest >=0.13.0 && <0.14,+ template-haskell,+ QuickCheck+ ghc-options: -Wall -threaded+ hs-source-dirs: tests+ default-language: Haskell2010++test-suite test+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ main-is: Tests.hs+ hs-source-dirs: tests+ ghc-options: -Wall -threaded+ build-depends:+ base, tree-diff,+ base-compat,+ QuickCheck,+ ansi-terminal,+ ansi-wl-pprint,+ parsec,+ trifecta >=1.7.1.1 && <1.8,+ tasty >=0.11.2.5 && <0.12,+ tasty-golden >=2.3.1.1 && <2.4,+ tasty-quickcheck >=0.9.1 && <0.10