SpecialDiff examples: containers instances

.github/workflows/haskell.yml

@@ -11,62 +11,118 @@ 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' )
         || ( github.event_name == 'pull_request'
             && 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' )
         || ( github.event_name == 'pull_request'
             && 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

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

cabal.project

@@ -0,0 +1,3 @@
+packages:
+    ./generic-diff.cabal
+    examples/containers-instances/generic-diff-containers.cabal

examples/containers-instances/generic-diff-containers.cabal

@@ -0,0 +1,91 @@
+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
+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
+    , 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
+
+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

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

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