From cf5724c2b21cf04cc8b6fe91059c9355ed29d6e3 Mon Sep 17 00:00:00 2001 From: Frederick Pringle Date: Thu, 29 May 2025 18:10:50 +0200 Subject: [PATCH 1/9] Example package demonstrating implementation of `Diff` for `containers` --- cabal.project | 3 + .../generic-diff-containers.cabal | 59 +++++++++++++++++++ 2 files changed, 62 insertions(+) create mode 100644 cabal.project create mode 100644 examples/containers-instances/generic-diff-containers.cabal diff --git a/cabal.project b/cabal.project new file mode 100644 index 0000000..1698ce8 --- /dev/null +++ b/cabal.project @@ -0,0 +1,3 @@ +packages: + ./generic-diff.cabal + examples/containers-instances/generic-diff-containers.cabal diff --git a/examples/containers-instances/generic-diff-containers.cabal b/examples/containers-instances/generic-diff-containers.cabal new file mode 100644 index 0000000..6ff08db --- /dev/null +++ b/examples/containers-instances/generic-diff-containers.cabal @@ -0,0 +1,59 @@ +cabal-version: 3.0 +name: generic-diff-containers +version: 0.1.0.0 +license: BSD-3-Clause +license-file: LICENSE +author: Frederick Pringle +maintainer: freddyjepringle@gmail.com +copyright: Copyright(c) Frederick Pringle 2025 +homepage: https://github.com/fpringle/generic-diff +build-type: Simple + +common warnings + ghc-options: -Wall + +common deps + build-depends: + , base >= 4.12 && < 5 + , generic-diff + , sop-core >= 0.4.0.1 && < 0.6 + , generics-sop >= 0.4 && < 0.6 + , text >= 1.1 && < 2.2 + , containers + +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 From 87d1e69c1126b54f595a5173fbb0b475a8903976 Mon Sep 17 00:00:00 2001 From: Frederick Pringle Date: Thu, 29 May 2025 18:11:43 +0200 Subject: [PATCH 2/9] `Seq`, easy --- .../src/Generics/Diff/Special/Seq.hs | 22 +++++++++++++++++++ 1 file changed, 22 insertions(+) create mode 100644 examples/containers-instances/src/Generics/Diff/Special/Seq.hs diff --git a/examples/containers-instances/src/Generics/Diff/Special/Seq.hs b/examples/containers-instances/src/Generics/Diff/Special/Seq.hs new file mode 100644 index 0000000..f48f790 --- /dev/null +++ b/examples/containers-instances/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 From 96c9520baab3e7353e40de0195bdd9b8e8058345 Mon Sep 17 00:00:00 2001 From: Frederick Pringle Date: Thu, 29 May 2025 18:12:41 +0200 Subject: [PATCH 3/9] `Map` --- .../src/Generics/Diff/Special/Map.hs | 72 +++++++++++++++++++ 1 file changed, 72 insertions(+) create mode 100644 examples/containers-instances/src/Generics/Diff/Special/Map.hs diff --git a/examples/containers-instances/src/Generics/Diff/Special/Map.hs b/examples/containers-instances/src/Generics/Diff/Special/Map.hs new file mode 100644 index 0000000..09065fd --- /dev/null +++ b/examples/containers-instances/src/Generics/Diff/Special/Map.hs @@ -0,0 +1,72 @@ +{-# 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 '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" + +------------------------------------------------------------ +-- Map + +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 + +-- | Now we can implement 'Diff' using 'diffWithSpecial'. +instance (Show k, Ord k, Diff v) => Diff (Map k v) where + diff = diffWithSpecial From 49480b0f54adc32ac1b4195b73a4b4783f498fc4 Mon Sep 17 00:00:00 2001 From: Frederick Pringle Date: Thu, 29 May 2025 18:13:17 +0200 Subject: [PATCH 4/9] `Set` is very similar to `Map` --- .../src/Generics/Diff/Special/Set.hs | 67 +++++++++++++++++++ 1 file changed, 67 insertions(+) create mode 100644 examples/containers-instances/src/Generics/Diff/Special/Set.hs diff --git a/examples/containers-instances/src/Generics/Diff/Special/Set.hs b/examples/containers-instances/src/Generics/Diff/Special/Set.hs new file mode 100644 index 0000000..e04a3d4 --- /dev/null +++ b/examples/containers-instances/src/Generics/Diff/Special/Set.hs @@ -0,0 +1,67 @@ +{-# 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 '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 From c0b51abc57d1235d672521f82dc45fa43729afa1 Mon Sep 17 00:00:00 2001 From: Frederick Pringle Date: Thu, 29 May 2025 18:18:12 +0200 Subject: [PATCH 5/9] `Tree`, 2 different ways --- .../src/Generics/Diff/Special/Tree.hs | 82 +++++++++++++++++++ 1 file changed, 82 insertions(+) create mode 100644 examples/containers-instances/src/Generics/Diff/Special/Tree.hs diff --git a/examples/containers-instances/src/Generics/Diff/Special/Tree.hs b/examples/containers-instances/src/Generics/Diff/Special/Tree.hs new file mode 100644 index 0000000..436a202 --- /dev/null +++ b/examples/containers-instances/src/Generics/Diff/Special/Tree.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE DerivingVia #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +{- | A worked example of implementing 'SpecialDiff' (and thereby 'Diff') for '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 + +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 + +newtype CustomTree a = CustomTree (Tree.Tree a) + deriving (Show) via (Tree.Tree a) + +newtype TreePath = TreePath [Int] + deriving (Show, Eq) via [Int] + +data CustomTreeDiffError a + = DiffAtNode TreePath (DiffError a) + | WrongLengthsOfChildren TreePath Int Int + deriving (Show, Eq) + +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 From 20484f09735fb43ae4b83081951ced905079d6d0 Mon Sep 17 00:00:00 2001 From: Frederick Pringle Date: Thu, 29 May 2025 18:30:38 +0200 Subject: [PATCH 6/9] Link to `examples/container-instances` from `SpecialDiff` haddocks --- src/Generics/Diff/Type.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Generics/Diff/Type.hs b/src/Generics/Diff/Type.hs index 6a1bd1a..170d611 100644 --- a/src/Generics/Diff/Type.hs +++ b/src/Generics/Diff/Type.hs @@ -80,6 +80,10 @@ newtype DiffAtField xss = DiffAtField (NS (ConstructorInfo :*: NS DiffError) xss such as lists (see 'ListDiffError'), or even user-defined types that internally preserve invariants or have unusual 'Eq' instances. In this case we can implement an instance of 'SpecialDiff' for the type. + +For concrete examples implementing 'SpecialDiff' on types from "containers", see the +[examples/containers-instances](https://github.com/fpringle/generic-diff/tree/main/examples/containers-instances) +directory. -} class (Show (SpecialDiffError a), Eq (SpecialDiffError a)) => SpecialDiff a where -- | A custom diff error type for the special case. From 09760e7969a207b896ca0d20e3d0eba87191077c Mon Sep 17 00:00:00 2001 From: Frederick Pringle Date: Fri, 30 May 2025 15:21:48 +0200 Subject: [PATCH 7/9] Tests for `generic-diff-containers --- .../generic-diff-containers.cabal | 22 ++ .../test/Generics/Diff/PropertyTestsSpec.hs | 55 +++++ .../test/Generics/Diff/UnitTestsSpec.hs | 231 ++++++++++++++++++ examples/containers-instances/test/Spec.hs | 1 + examples/containers-instances/test/Util.hs | 23 ++ 5 files changed, 332 insertions(+) create mode 100644 examples/containers-instances/test/Generics/Diff/PropertyTestsSpec.hs create mode 100644 examples/containers-instances/test/Generics/Diff/UnitTestsSpec.hs create mode 100644 examples/containers-instances/test/Spec.hs create mode 100644 examples/containers-instances/test/Util.hs diff --git a/examples/containers-instances/generic-diff-containers.cabal b/examples/containers-instances/generic-diff-containers.cabal index 6ff08db..e647eb5 100644 --- a/examples/containers-instances/generic-diff-containers.cabal +++ b/examples/containers-instances/generic-diff-containers.cabal @@ -57,3 +57,25 @@ library hs-source-dirs: src default-language: Haskell2010 + +test-suite generic-diff-containers-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-containers + , QuickCheck + , hspec diff --git a/examples/containers-instances/test/Generics/Diff/PropertyTestsSpec.hs b/examples/containers-instances/test/Generics/Diff/PropertyTestsSpec.hs new file mode 100644 index 0000000..82448bd --- /dev/null +++ b/examples/containers-instances/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/examples/containers-instances/test/Generics/Diff/UnitTestsSpec.hs b/examples/containers-instances/test/Generics/Diff/UnitTestsSpec.hs new file mode 100644 index 0000000..443c859 --- /dev/null +++ b/examples/containers-instances/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/examples/containers-instances/test/Spec.hs b/examples/containers-instances/test/Spec.hs new file mode 100644 index 0000000..a824f8c --- /dev/null +++ b/examples/containers-instances/test/Spec.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/examples/containers-instances/test/Util.hs b/examples/containers-instances/test/Util.hs new file mode 100644 index 0000000..7835d0f --- /dev/null +++ b/examples/containers-instances/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 From b2b70fb80d12ed57bbc9c62ff09f25389c0d9bc7 Mon Sep 17 00:00:00 2001 From: Frederick Pringle Date: Fri, 30 May 2025 20:29:25 +0200 Subject: [PATCH 8/9] Update Changelog --- CHANGELOG.md | 1 + 1 file changed, 1 insertion(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index 02d2f0c..2114669 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -11,5 +11,6 @@ and this project adheres to [Haskell Package Versioning Policy](https://pvp.hask - First version. Released on an unsuspecting world. - Let users extend the built-in diff types with custom diffs via the `SpecialDiff` class in [#9](https://github.com/fpringle/generic-diff/pull/9). +- Add example implementations of `SpecialDiff` for `containers` types in [#10](https://github.com/fpringle/generic-diff/pull/10). [unreleased]: https://github.com/fpringle/generic-diff/compare/74b5028...HEAD From d51d6ec94a37631193793bc697eb700a2a0502bb Mon Sep 17 00:00:00 2001 From: Frederick Pringle Date: Fri, 30 May 2025 20:34:29 +0200 Subject: [PATCH 9/9] Test `generic-diff-containers` during CICD too --- .github/workflows/haskell.yml | 118 +++++++++++++----- .../generic-diff-containers.cabal | 10 ++ 2 files changed, 97 insertions(+), 31 deletions(-) diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index 4fbf938..cc730e4 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -11,6 +11,33 @@ permissions: contents: read jobs: + find-packages: + name: "Find packages by their .cabal files" + if: ( ( github.event_name == 'push' ) + || ( github.event_name == 'pull_request' + && github.event.pull_request.draft == false + ) + ) + runs-on: ubuntu-latest + outputs: + packages: ${{ steps.set-matrix.outputs.packages }} + steps: + - uses: actions/checkout@v4 + - name: Find packages + id: set-matrix + run: | + set -euo pipefail + + packages=$( + find . -name '*.cabal' | sed 's/^\.\///' | while read file; do + file_name=$(basename -- $file) + package_name="${file_name%.*}" + echo "{\"package\": \"${package_name}\", \"cabal_file\": \"${file}\"}" + done | jq -s -c + ) + echo $packages + echo "packages=$packages" > "$GITHUB_OUTPUT" + generate-matrix: name: "Generate matrix from cabal" if: ( ( github.event_name == 'push' ) @@ -18,17 +45,41 @@ jobs: && github.event.pull_request.draft == false ) ) + needs: + - find-packages outputs: matrix: ${{ steps.set-matrix.outputs.matrix }} runs-on: ubuntu-latest + env: + GET_TESTED_VERSION: 0.1.7.1 + PACKAGES: ${{ needs.find-packages.outputs.packages }} + steps: - - name: Extract the tested GHC versions - id: set-matrix - uses: kleidukos/get-tested@v0.1.7.1 + - uses: actions/checkout@v4 + - name: Install GH CLI + uses: dev-hanz-ops/install-gh-cli-action@v0.2.1 with: - cabal-file: generic-diff.cabal - ubuntu-version: "latest" - version: 0.1.7.1 + gh-cli-version: 2.63.0 + - name: Set up get-tested + uses: Kleidukos/get-tested/setup-get-tested@5f873c05c435a1f50e4c5ce815d687c1bff3b93b + with: + version: ${{ env.GET_TESTED_VERSION }} + - name: Extract GHC versions for each package + id: set-matrix + run: | + set -euo pipefail + + matrix=$(echo $PACKAGES | jq -c '.[]' | while read package; do + name=$(echo $package | jq -r '.package') + echo "Running get-tested on package ${name}" >&2 + cabal_file=$(echo $package | jq -r '.cabal_file') + output=$(./get-tested --ubuntu-version=latest $cabal_file) + echo $output | sed 's/^matrix=//' | jq ".include[] |= . + ${package}" + done | jq -s -c '{ include: map(.include) | add }') + + echo $matrix + + echo "matrix=$matrix" > "$GITHUB_OUTPUT" test: if: ( ( github.event_name == 'push' ) @@ -36,37 +87,42 @@ jobs: && github.event.pull_request.draft == false ) ) - name: ${{ matrix.ghc }} on ${{ matrix.os }} + name: Test ${{ matrix.package }} with GHC ${{ matrix.ghc }} on ${{ matrix.os }} needs: generate-matrix runs-on: ${{ matrix.os }} strategy: + fail-fast: false matrix: ${{ fromJSON(needs.generate-matrix.outputs.matrix) }} steps: - - uses: actions/checkout@v4 + - uses: actions/checkout@v4 - - uses: haskell-actions/setup@v2.7 - with: - ghc-version: ${{ matrix.ghc }} - cabal-version: '3.0' + - uses: haskell-actions/setup@v2.7 + with: + ghc-version: ${{ matrix.ghc }} + cabal-version: '3.0' - - name: Cache - uses: actions/cache@v3 - env: - cache-name: cache-cabal - with: - path: ~/.cabal - key: ${{ runner.os }}-build-${{ env.cache-name }}-${{ hashFiles('**/*.cabal') }}-${{ hashFiles('**/cabal.project') }} - restore-keys: | - ${{ runner.os }}-build-${{ env.cache-name }}- - ${{ runner.os }}-build- - ${{ runner.os }}- + - name: Cache + uses: actions/cache@v3 + env: + cache-name: cache-cabal + with: + path: ~/.cabal + key: ${{ runner.os }}-build-${{ env.cache-name }}-${{ hashFiles('**/*.cabal') }}-${{ hashFiles('**/cabal.project') }} + restore-keys: | + ${{ runner.os }}-build-${{ env.cache-name }}- + ${{ runner.os }}-build- + ${{ runner.os }}- - - name: Install dependencies - run: | - cabal update - cabal build --only-dependencies --enable-tests --enable-benchmarks - - name: Build - run: cabal build --enable-tests --enable-benchmarks all - - name: Run tests - run: cabal test all + - name: Install dependencies + run: | + cabal update + cabal build --only-dependencies --enable-tests --enable-benchmarks ${{ matrix.package }} + - name: Build + run: cabal build --enable-tests --enable-benchmarks ${{ matrix.package }} + - name: Run tests + # https://github.com/fpringle/generic-diff/actions/runs/15353395135/job/43206848857?pr=10 + run: | + cabal configure --enable-tests + cd $(dirname ${{ matrix.cabal_file }}) + cabal test --enable-tests diff --git a/examples/containers-instances/generic-diff-containers.cabal b/examples/containers-instances/generic-diff-containers.cabal index e647eb5..d2686ed 100644 --- a/examples/containers-instances/generic-diff-containers.cabal +++ b/examples/containers-instances/generic-diff-containers.cabal @@ -8,6 +8,16 @@ maintainer: freddyjepringle@gmail.com copyright: Copyright(c) Frederick Pringle 2025 homepage: https://github.com/fpringle/generic-diff build-type: Simple +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