diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,14 @@ +# Changelog + +All notable changes to `generic-diff-instances` will be documented in this file. + +The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.1.0/), +and this project adheres to [Haskell Package Versioning Policy](https://pvp.haskell.org). + +## [Unreleased] + +### Added + +- `Diff` instances for `Map`, `Seq`, `Set` and `Tree` from `containers`. + +[unreleased]: https://github.com/fpringle/generic-diff/compare/7dbc273...HEAD diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,12 @@ +[![Haskell CI](https://github.com/fpringle/generic-diff/actions/workflows/haskell.yml/badge.svg)](https://github.com/fpringle/generic-diff/actions/workflows/haskell.yml) + +# `generic-diff` instances + +The [generic-diff](https://hackage.haskell.org/package/generic-diff) package +aims to be lightweight and not force any instances which might have more than +one interpretation. + +This package provides a more comprehensive set of instances for types from a +range of common packages. + +Currently we provide instances for [Map](https://hackage-content.haskell.org/package/containers-0.8/docs/Data-Map-Lazy.html#t:Map), [Seq](https://hackage-content.haskell.org/package/containers-0.8/docs/Data-Sequence.html#t:Seq), [Set](https://hackage-content.haskell.org/package/containers-0.8/docs/Data-Set.html#t:Set) and [Tree](https://hackage-content.haskell.org/package/containers-0.8/docs/Data-Tree.html#t:Tree) from the containers package. diff --git a/generic-diff-instances.cabal b/generic-diff-instances.cabal new file mode 100644 --- /dev/null +++ b/generic-diff-instances.cabal @@ -0,0 +1,101 @@ +cabal-version: 3.0 +name: generic-diff-instances +version: 0.1.0.0 +synopsis: Diff instances for common types +description: + The [generic-diff](https://hackage.haskell.org/package/generic-diff) package + aims to be lightweight and not force any instances which might have more than + one interpretation. + + This package provides a more comprehensive set of instances for types from a + range of common packages. +license: BSD-3-Clause +author: Frederick Pringle +maintainer: freddyjepringle@gmail.com +copyright: Copyright(c) Frederick Pringle 2025 +homepage: https://github.com/fpringle/generic-diff +category: Generics, Test +build-type: Simple +extra-doc-files: CHANGELOG.md + README.md +tested-with: + GHC == 9.12.2 + GHC == 9.10.1 + GHC == 9.8.2 + GHC == 9.6.5 + GHC == 9.4.8 + GHC == 9.2.8 + GHC == 9.0.2 + GHC == 8.10.7 + GHC == 8.6.5 + +common warnings + ghc-options: -Wall + +common deps + build-depends: + , base >= 4.12 && < 5 + , generic-diff >= 0.1 && < 0.2 + , sop-core >= 0.4.0.1 && < 0.6 + , generics-sop >= 0.4 && < 0.6 + , text >= 1.1 && < 2.2 + , containers >= 0.5.9.2 && < 0.9 + +common extensions + default-extensions: + AllowAmbiguousTypes + ConstraintKinds + DataKinds + DefaultSignatures + DeriveGeneric + FlexibleContexts + FlexibleInstances + GADTs + LambdaCase + OverloadedStrings + PolyKinds + RankNTypes + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + TypeApplications + TypeFamilies + TypeOperators + UndecidableInstances + ViewPatterns + +library + import: + warnings + , deps + , extensions + exposed-modules: + Generics.Diff.Special.Seq + Generics.Diff.Special.Map + Generics.Diff.Special.Set + Generics.Diff.Special.Tree + + hs-source-dirs: src + default-language: Haskell2010 + +test-suite generic-diff-instances-test + import: + warnings + , deps + , extensions + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + other-modules: + Generics.Diff.UnitTestsSpec + Generics.Diff.PropertyTestsSpec + Util + build-tool-depends: + hspec-discover:hspec-discover + ghc-options: -Wno-orphans + build-depends: + , generic-diff + , generic-diff-instances + , QuickCheck + , hspec diff --git a/src/Generics/Diff/Special/Map.hs b/src/Generics/Diff/Special/Map.hs new file mode 100644 --- /dev/null +++ b/src/Generics/Diff/Special/Map.hs @@ -0,0 +1,68 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +{- | A worked example of implementing 'SpecialDiff' (and thereby 'Diff') for 'Map's. + +We make the choice to prioritise speed over exhaustiveness: in other words we stop when we find +one difference between the two input maps. Alternatively, we could have gone the other way and +enumerated all the difference between the inputs, using some kind of intersection test. This is left +as an exercise for the reader. +-} +module Generics.Diff.Special.Map + ( MapDiffError (..) + ) +where + +import Control.Applicative ((<|>)) +import Data.Map (Map) +import qualified Data.Map.Internal as Map +import Generics.Diff +import Generics.Diff.Render +import Generics.Diff.Special + +-- | For 'Map's, we only pick out (maximum) one difference between the two inputs. There are three possibilities: +data MapDiffError k v + = -- | A key is found in both maps, but they have different values. + DiffAtKey k (DiffError v) + | -- | The right set contains an element that isn't found in the left set + LeftMissingKey k + | -- | The left set contains an element that isn't found in the right set + RightMissingKey k + deriving (Show, Eq) + +{- | Render a 'MapDiffError'. This is a top-level function because we'll use it in the implementations +of 'renderSpecialDiffError' for both 'Map' and 'Data.IntMap.IntMap'. +-} +mapDiffErrorDoc :: (Show k) => MapDiffError k v -> Doc +mapDiffErrorDoc = \case + -- Since we have a nested 'DiffError' on the value, we use 'makeDoc'. + DiffAtKey k err -> + let lns = pure ("Both maps contain key " <> showB k <> " but the values differ:") + in makeDoc lns err + LeftMissingKey k -> + linesDoc $ pure $ "The right map contains key " <> showB k <> " but the left doesn't" + RightMissingKey k -> + linesDoc $ pure $ "The left map contains key " <> showB k <> " but the right doesn't" + +instance (Show k, Ord k, Diff v) => SpecialDiff (Map k v) where + type SpecialDiffError (Map k v) = MapDiffError k v + + -- base cases + specialDiff Map.Tip Map.Tip = Nothing + specialDiff Map.Tip (Map.Bin _ k _ _ _) = Just $ LeftMissingKey k + specialDiff (Map.Bin _ k _ _ _) Map.Tip = Just $ RightMissingKey k + -- recursive set, using Map.split + specialDiff (Map.Bin _ k lVal left right) r = case Map.lookup k r of + Nothing -> Just $ RightMissingKey k + Just rVal -> + -- first we check if the values are different (using the 'Diff' instance on v) + case diff lVal rVal of + Error err -> Just $ DiffAtKey k err + Equal -> + -- otherwise, split and recurse + let (less, more) = Map.split k r + in specialDiff left less <|> specialDiff right more + + renderSpecialDiffError = mapDiffErrorDoc + +instance (Show k, Ord k, Diff v) => Diff (Map k v) where + diff = diffWithSpecial diff --git a/src/Generics/Diff/Special/Seq.hs b/src/Generics/Diff/Special/Seq.hs new file mode 100644 --- /dev/null +++ b/src/Generics/Diff/Special/Seq.hs @@ -0,0 +1,22 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | A worked example of implementing 'SpecialDiff' (and thereby 'Diff') for 'Seq's. +module Generics.Diff.Special.Seq () where + +import Data.Foldable (toList) +import Data.Function (on) +import Data.Sequence (Seq) +import Generics.Diff +import Generics.Diff.Render +import Generics.Diff.Special + +{- | Just as with the instance for lists or non-empty lists (see "Generics.Diff.Special.List"), +we can use 'ListDiffError', 'diffListWith' and 'listDiffErrorDoc'. +-} +instance (Diff a) => SpecialDiff (Seq a) where + type SpecialDiffError (Seq a) = ListDiffError a + specialDiff = diffListWith diff `on` toList + renderSpecialDiffError = listDiffErrorDoc "sequence" + +instance (Diff a) => Diff (Seq a) where + diff = diffWithSpecial diff --git a/src/Generics/Diff/Special/Set.hs b/src/Generics/Diff/Special/Set.hs new file mode 100644 --- /dev/null +++ b/src/Generics/Diff/Special/Set.hs @@ -0,0 +1,66 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +{- | A worked example of implementing 'SpecialDiff' (and thereby 'Diff') for 'Set's. + +We make the choice to prioritise speed over exhaustiveness: in other words we stop when we find +one difference between the two input sets. Alternatively, we could have gone the other way and +enumerated all the difference between the inputs, using some kind of intersection test. This is left +as an exercise for the reader. + +Note that the implementation for maps in "Generics.Diff.Special.Map" is very similar; this is since a +@'Set' k@ can be seen as equivalent to @Map k ()@. +-} +module Generics.Diff.Special.Set + ( SetDiffError (..) + ) +where + +import Control.Applicative ((<|>)) +import Data.Set (Set) +import qualified Data.Set.Internal as Set +import Generics.Diff +import Generics.Diff.Render +import Generics.Diff.Special + +-- | For 'Set's, we only pick out (maximum) one difference between the two inputs. There are two possibilities: +data SetDiffError k + = -- | The right set contains an element that isn't found in the left set + LeftMissingKey k + | -- | The left set contains an element that isn't found in the right set + RightMissingKey k + deriving (Show, Eq) + +{- | Render a 'SetDiffError'. This is a top-level function because we'll use it in the implementations +of 'renderSpecialDiffError' for both 'Set' and 'Data.IntSet.IntSet'. + +There are no nested 'DiffError's here, so we use 'linesDoc'. +-} +setDiffErrorDoc :: (Show k) => SetDiffError k -> Doc +setDiffErrorDoc = \case + LeftMissingKey k -> + linesDoc $ pure $ "The right set contains key " <> showB k <> " but the left doesn't" + RightMissingKey k -> + linesDoc $ pure $ "The left set contains key " <> showB k <> " but the right doesn't" + +-- First we define an instance of 'SpecialDiff'. We need 'Show' and 'Eq' so that 'SetDiffError' +-- also has these instances; we need 'Ord' to compare elements of the set. +instance (Show k, Eq k, Ord k) => SpecialDiff (Set k) where + type SpecialDiffError (Set k) = SetDiffError k + + -- base cases + specialDiff Set.Tip Set.Tip = Nothing + specialDiff Set.Tip (Set.Bin _ k _ _) = Just $ LeftMissingKey k + specialDiff (Set.Bin _ k _ _) Set.Tip = Just $ RightMissingKey k + -- recursive step, using Set.split + specialDiff (Set.Bin _ k left right) r = + if Set.notMember k r + then Just $ RightMissingKey k + else + let (less, more) = Set.split k r + in specialDiff left less <|> specialDiff right more + + renderSpecialDiffError = setDiffErrorDoc + +-- Now we can implement 'Diff' using 'diffWithSpecial'. +instance (Show k, Ord k) => Diff (Set k) where + diff = diffWithSpecial diff --git a/src/Generics/Diff/Special/Tree.hs b/src/Generics/Diff/Special/Tree.hs new file mode 100644 --- /dev/null +++ b/src/Generics/Diff/Special/Tree.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE DerivingVia #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +{- | A worked example of implementing 'SpecialDiff' (and thereby 'Diff') for 'Tree.Tree's. + +As with other 3rd-party types, there are different approaches we can take here. We'll show 2 of them: + +- using 'gspecialDiffNested'; +- using 'SpecialDiff' and a custom diff type. +-} +module Generics.Diff.Special.Tree where + +import Control.Applicative +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.Text.Lazy.Builder as TB +import qualified Data.Tree as Tree +import Generics.Diff +import Generics.Diff.Render +import Generics.Diff.Special +import Generics.SOP.GGP + +------------------------------------------------------------ +-- Using gspecialDiffNested + +-- | Generically-derived instance. +instance (Diff a) => SpecialDiff (Tree.Tree a) where + type SpecialDiffError (Tree.Tree a) = DiffErrorNested (GCode (Tree.Tree a)) + specialDiff = gspecialDiffNested + renderSpecialDiffError = diffErrorNestedDoc + +instance (Diff a) => Diff (Tree.Tree a) where + diff = diffWithSpecial + +------------------------------------------------------------ +-- Using SpecialDiff + +{- | A newtype wrapper around 'Tree.Tree' to demonstrate one alternate way we could hand-write +a 'SpecialDiff' instance. +-} +newtype CustomTree a = CustomTree (Tree.Tree a) + deriving (Show) via (Tree.Tree a) + +-- | Where are we in the tree? Each element of the list says which child node we step to next. +newtype TreePath = TreePath [Int] + deriving (Show, Eq) via [Int] + +-- | A custom error type for 'CustomTree'. +data CustomTreeDiffError a + = DiffAtNode TreePath (DiffError a) + | WrongLengthsOfChildren TreePath Int Int + deriving (Show, Eq) + +-- | Render a tree path as a 'TB.Builder' +renderTreePath :: TreePath -> TB.Builder +renderTreePath (TreePath []) = "" +renderTreePath (TreePath (x : xs)) = mconcat $ showB x : ["->" <> showB y | y <- xs] + +instance (Diff a) => SpecialDiff (CustomTree a) where + type SpecialDiffError (CustomTree a) = CustomTreeDiffError a + + renderSpecialDiffError = \case + DiffAtNode path err -> + let ls = pure $ "Diff between nodes at path " <> renderTreePath path + in makeDoc ls err + WrongLengthsOfChildren path l r -> + let ls = + ("Child lists at path " <> renderTreePath path <> " are wrong lengths") + :| [ "Length of left child list: " <> showB l + , "Length of right child list: " <> showB r + ] + in linesDoc ls + + specialDiff (CustomTree l) (CustomTree r) = go [] l r + where + go curPath (Tree.Node n1 f1) (Tree.Node n2 f2) = + case diff n1 n2 of + Error err -> Just $ DiffAtNode curTreePath err + Equal -> + let go' n = go (n : curPath) + goChildren _ [] [] = Nothing + goChildren n [] ys = Just $ WrongLengthsOfChildren curTreePath n (n + length ys) + goChildren n xs [] = Just $ WrongLengthsOfChildren curTreePath (n + length xs) n + goChildren n (x : xs) (y : ys) = go' n x y <|> goChildren (n + 1) xs ys + in goChildren 0 f1 f2 + where + curTreePath = TreePath $ reverse curPath + +instance (Diff a) => Diff (CustomTree a) where + diff = diffWithSpecial diff --git a/test/Generics/Diff/PropertyTestsSpec.hs b/test/Generics/Diff/PropertyTestsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Generics/Diff/PropertyTestsSpec.hs @@ -0,0 +1,55 @@ +{-# OPTIONS_GHC -Wno-partial-fields #-} + +module Generics.Diff.PropertyTestsSpec where + +import Data.Fixed +import Data.Map (Map) +import Data.Proxy +import Data.Sequence (Seq) +import Data.Set (Set) +import Data.Tree (Tree) +import Data.Version +import Foreign.C.Types +import Generics.Diff +import Generics.Diff.Instances () +import Generics.Diff.Special.Map () +import Generics.Diff.Special.Seq () +import Generics.Diff.Special.Set () +import Generics.Diff.Special.Tree () +import qualified Test.Hspec as H +import qualified Test.Hspec.QuickCheck as H +import qualified Test.QuickCheck as Q +import Util + +spec :: H.Spec +spec = do + H.describe "x == y => x `diff` y == Equal" $ + manyTypes propEqualGivesEqual + H.describe "x `diff` y == Equal => x == y" $ + manyTypes propEqualMeansEqual + +-- | If the two inputs are equal, 'diff' should return 'Equal'. +propEqualGivesEqual :: forall a. (Q.Arbitrary a, Diff a, Show a) => Proxy a -> Q.Property +propEqualGivesEqual _ = Q.property $ \a -> propDiffResult @a a a Equal + +-- | If the two inputs are not equal, 'diff' should never return 'Equal'. +propEqualMeansEqual :: forall a. (Q.Arbitrary a, Eq a, Diff a, Show a) => Proxy a -> Q.Property +propEqualMeansEqual _ = Q.property $ \leftValue rightValue -> + leftValue /= rightValue Q.==> + diff @a leftValue rightValue /= Equal + +manyTypes :: (forall x. (Q.Arbitrary x, Eq x, Diff x, Show x) => Proxy x -> Q.Property) -> H.Spec +manyTypes prop = do + H.prop "Set Char" $ prop $ Proxy @(Set Char) + H.prop "Set Int" $ prop $ Proxy @(Set Int) + + H.prop "Seq Rational" $ prop $ Proxy @(Seq Rational) + H.prop "Seq Version" $ prop $ Proxy @(Seq Version) + H.prop "Seq CLong" $ prop $ Proxy @(Seq CLong) + + H.prop "Tree CChar" $ prop $ Proxy @(Tree CChar) + H.prop "Tree Uni" $ prop $ Proxy @(Tree Uni) + H.prop "Tree Deci" $ prop $ Proxy @(Tree Deci) + + H.prop "Map Int Char" $ prop $ Proxy @(Map Int Char) + H.prop "Map Char Int" $ prop $ Proxy @(Map Char Int) diff --git a/test/Generics/Diff/UnitTestsSpec.hs b/test/Generics/Diff/UnitTestsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Generics/Diff/UnitTestsSpec.hs @@ -0,0 +1,231 @@ +{-# OPTIONS_GHC -Wno-partial-fields #-} + +module Generics.Diff.UnitTestsSpec where + +import Data.Foldable +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Sequence (Seq) +import qualified Data.Sequence as Seq +import Data.Set (Set) +import qualified Data.Set as Set +import qualified Data.Text as T +import Data.Tree (Tree) +import qualified Data.Tree as Tree +import Generics.Diff +import Generics.Diff.Instances () +import Generics.Diff.Special.Map as Map +import Generics.Diff.Special.Seq () +import Generics.Diff.Special.Set as Set +import Generics.Diff.Special.Tree +import Generics.SOP +import Generics.SOP.GGP +import qualified Test.Hspec as H +import qualified Test.Hspec.QuickCheck as H +import Util + +spec :: H.Spec +spec = + H.describe "Unit tests" $ do + H.describe "Map" $ traverse_ specTestSet mapTestSets + H.describe "Set" $ traverse_ specTestSet setTestSets + H.describe "Seq" $ traverse_ specTestSet seqTestSets + H.describe "Tree" $ traverse_ specTestSet treeTestSets + H.describe "CustomTree" $ traverse_ specTestSet customTreeTestSets + +specTestSet :: (Diff a, Show a) => TestSet a -> H.Spec +specTestSet TestSet {..} = + H.prop (T.unpack setName) $ + propDiffResult leftValue rightValue expectedDiffResult + +data TestSet a = TestSet + { setName :: T.Text + , leftValue :: a + , rightValue :: a + , expectedDiffResult :: DiffResult a + } + deriving (Show) + +setTestSets :: [TestSet (Set Int)] +setTestSets = + [ TestSet + { setName = "Equal" + , leftValue = value1 + , rightValue = value1 + , expectedDiffResult = Equal + } + , TestSet + { setName = "Diff, LeftMissingKey" + , leftValue = value1 + , rightValue = value2 + , expectedDiffResult = Error error2 + } + , TestSet + { setName = "Diff, RightMissingKey" + , leftValue = value1 + , rightValue = value3 + , expectedDiffResult = Error error3 + } + ] + where + value1 = Set.fromList [1, 3] + + value2 = Set.fromList [1, 2, 3] + error2 = DiffSpecial $ Set.LeftMissingKey 2 + + value3 = Set.fromList [1] + error3 = DiffSpecial $ Set.RightMissingKey 3 + +mapTestSets :: [TestSet (Map Int String)] +mapTestSets = + [ TestSet + { setName = "Equal" + , leftValue = value1 + , rightValue = value1 + , expectedDiffResult = Equal + } + , TestSet + { setName = "Diff, DiffAtKey" + , leftValue = value1 + , rightValue = value2 + , expectedDiffResult = Error error2 + } + , TestSet + { setName = "Diff, LeftMissingKey" + , leftValue = value1 + , rightValue = value3 + , expectedDiffResult = Error error3 + } + , TestSet + { setName = "Diff, RightMissingKey" + , leftValue = value1 + , rightValue = value4 + , expectedDiffResult = Error error4 + } + ] + where + value1 = Map.fromList [(1, "one"), (3, "three")] + + value2 = Map.fromList [(1, "one"), (3, "THREE")] + error2 = DiffSpecial $ Map.DiffAtKey 3 TopLevelNotEqual + + value3 = Map.fromList [(1, "one"), (2, "two"), (3, "three")] + error3 = DiffSpecial $ Map.LeftMissingKey 2 + + value4 = Map.fromList [(1, "one")] + error4 = DiffSpecial $ Map.RightMissingKey 3 + +seqTestSets :: [TestSet (Seq Int)] +seqTestSets = + [ TestSet + { setName = "Equal" + , leftValue = value1 + , rightValue = value1 + , expectedDiffResult = Equal + } + , TestSet + { setName = "Diff, WrongLengths" + , leftValue = value1 + , rightValue = value2 + , expectedDiffResult = Error error2 + } + , TestSet + { setName = "Diff, DiffAtIndex" + , leftValue = value1 + , rightValue = value3 + , expectedDiffResult = Error error3 + } + ] + where + value1 = Seq.fromList [1, 3] + + value2 = Seq.fromList [1, 3, 4] + error2 = DiffSpecial $ WrongLengths 2 3 + + value3 = Seq.fromList [1, 2] + error3 = DiffSpecial $ DiffAtIndex 1 TopLevelNotEqual + +treeTestSets :: [TestSet (Tree Int)] +treeTestSets = + [ TestSet + { setName = "Equal" + , leftValue = value1 + , rightValue = value1 + , expectedDiffResult = Equal + } + , TestSet + { setName = "Diff, FieldMismatch, level 1" + , leftValue = value1 + , rightValue = value2 + , expectedDiffResult = Error error2 + } + , TestSet + { setName = "Diff, FieldMismatch, level 2, WrongLengths" + , leftValue = value1 + , rightValue = value3 + , expectedDiffResult = Error error3 + } + , TestSet + { setName = "Diff, FieldMismatch, level 2, DiffAtIndex" + , leftValue = value1 + , rightValue = value4 + , expectedDiffResult = Error error4 + } + ] + where + value1 = Tree.Node 1 [Tree.Node 2 [], Tree.Node 3 [Tree.Node 4 [], Tree.Node 5 []]] + + value2 = Tree.Node 2 [] + error2 = DiffSpecial $ FieldMismatch $ DiffAtField $ Z $ nodeInfo :*: Z TopLevelNotEqual + + value3 = Tree.Node 1 [Tree.Node 2 []] + error3 = + let e = DiffSpecial $ WrongLengths 2 1 + in DiffSpecial $ FieldMismatch $ DiffAtField $ Z $ nodeInfo :*: S (Z e) + + value4 = Tree.Node 1 [Tree.Node 2 [], Tree.Node 4 []] + error4 = + let e = DiffSpecial $ DiffAtIndex 1 $ DiffSpecial $ FieldMismatch $ DiffAtField $ Z $ nodeInfo :*: Z TopLevelNotEqual + in DiffSpecial $ FieldMismatch $ DiffAtField $ Z $ nodeInfo :*: S (Z e) + + nodeInfo :: ConstructorInfo '[Int, [Tree Int]] + nodeInfo :* _ = constructorInfo $ gdatatypeInfo $ Proxy @(Tree Int) + +customTreeTestSets :: [TestSet (CustomTree Int)] +customTreeTestSets = + [ TestSet + { setName = "Equal" + , leftValue = value1 + , rightValue = value1 + , expectedDiffResult = Equal + } + , TestSet + { setName = "Diff, DiffAtNode, level 1" + , leftValue = value1 + , rightValue = value2 + , expectedDiffResult = Error error2 + } + , TestSet + { setName = "Diff, WrongLengthsOfChildren, level 2" + , leftValue = value1 + , rightValue = value3 + , expectedDiffResult = Error error3 + } + , TestSet + { setName = "Diff, DiffAtNode, level 2" + , leftValue = value1 + , rightValue = value4 + , expectedDiffResult = Error error4 + } + ] + where + value1 = CustomTree $ Tree.Node 1 [Tree.Node 2 [], Tree.Node 3 [Tree.Node 4 [], Tree.Node 5 []]] + + value2 = CustomTree $ Tree.Node 2 [] + error2 = DiffSpecial $ DiffAtNode (TreePath []) TopLevelNotEqual + + value3 = CustomTree $ Tree.Node 1 [Tree.Node 2 []] + error3 = DiffSpecial $ WrongLengthsOfChildren (TreePath []) 2 1 + + value4 = CustomTree $ Tree.Node 1 [Tree.Node 2 [], Tree.Node 4 []] + error4 = DiffSpecial $ DiffAtNode (TreePath [1]) TopLevelNotEqual diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/Util.hs b/test/Util.hs new file mode 100644 --- /dev/null +++ b/test/Util.hs @@ -0,0 +1,23 @@ +module Util where + +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Builder as TB +import Generics.Diff +import Generics.Diff.Instances () +import Generics.Diff.Render +import qualified Test.QuickCheck as Q + +propDiffResult :: (Diff a, Show a) => a -> a -> DiffResult a -> Q.Property +propDiffResult leftValue rightValue expectedDiffResult = + let actualDiffResult = diff leftValue rightValue + eq = expectedDiffResult == actualDiffResult + showDiffResult = TL.unpack . TB.toLazyText . renderDiffResult + addLabel = + if eq + then Q.property + else + Q.counterexample ("Expected DiffResult:\n" <> showDiffResult expectedDiffResult) + . Q.counterexample ("Actual DiffResult:\n" <> showDiffResult actualDiffResult) + . Q.counterexample ("Left value:\n" <> show leftValue) + . Q.counterexample ("Right value:\n" <> show rightValue) + in addLabel eq