Skip to content

Commit fa4a40a

Browse files
fpringlefpringle
authored
Merge pull request #10 from fpringle/fpringle/special-containers
`SpecialDiff` examples: `containers` instances
2 parents 19ccd19 + d51d6ec commit fa4a40a

13 files changed

Lines changed: 739 additions & 31 deletions

File tree

‎.github/workflows/haskell.yml‎

Lines changed: 87 additions & 31 deletions
Original file line numberDiff line numberDiff line change
@@ -11,62 +11,118 @@ permissions:
1111
contents: read
1212

1313
jobs:
14+
find-packages:
15+
name: "Find packages by their .cabal files"
16+
if: ( ( github.event_name == 'push' )
17+
|| ( github.event_name == 'pull_request'
18+
&& github.event.pull_request.draft == false
19+
)
20+
)
21+
runs-on: ubuntu-latest
22+
outputs:
23+
packages: ${{ steps.set-matrix.outputs.packages }}
24+
steps:
25+
- uses: actions/checkout@v4
26+
- name: Find packages
27+
id: set-matrix
28+
run: |
29+
set -euo pipefail
30+
31+
packages=$(
32+
find . -name '*.cabal' | sed 's/^\.\///' | while read file; do
33+
file_name=$(basename -- $file)
34+
package_name="${file_name%.*}"
35+
echo "{\"package\": \"${package_name}\", \"cabal_file\": \"${file}\"}"
36+
done | jq -s -c
37+
)
38+
echo $packages
39+
echo "packages=$packages" > "$GITHUB_OUTPUT"
40+
1441
generate-matrix:
1542
name: "Generate matrix from cabal"
1643
if: ( ( github.event_name == 'push' )
1744
|| ( github.event_name == 'pull_request'
1845
&& github.event.pull_request.draft == false
1946
)
2047
)
48+
needs:
49+
- find-packages
2150
outputs:
2251
matrix: ${{ steps.set-matrix.outputs.matrix }}
2352
runs-on: ubuntu-latest
53+
env:
54+
GET_TESTED_VERSION: 0.1.7.1
55+
PACKAGES: ${{ needs.find-packages.outputs.packages }}
56+
2457
steps:
25-
- name: Extract the tested GHC versions
26-
id: set-matrix
27-
uses: kleidukos/get-tested@v0.1.7.1
58+
- uses: actions/checkout@v4
59+
- name: Install GH CLI
60+
uses: dev-hanz-ops/install-gh-cli-action@v0.2.1
2861
with:
29-
cabal-file: generic-diff.cabal
30-
ubuntu-version: "latest"
31-
version: 0.1.7.1
62+
gh-cli-version: 2.63.0
63+
- name: Set up get-tested
64+
uses: Kleidukos/get-tested/setup-get-tested@5f873c05c435a1f50e4c5ce815d687c1bff3b93b
65+
with:
66+
version: ${{ env.GET_TESTED_VERSION }}
67+
- name: Extract GHC versions for each package
68+
id: set-matrix
69+
run: |
70+
set -euo pipefail
71+
72+
matrix=$(echo $PACKAGES | jq -c '.[]' | while read package; do
73+
name=$(echo $package | jq -r '.package')
74+
echo "Running get-tested on package ${name}" >&2
75+
cabal_file=$(echo $package | jq -r '.cabal_file')
76+
output=$(./get-tested --ubuntu-version=latest $cabal_file)
77+
echo $output | sed 's/^matrix=//' | jq ".include[] |= . + ${package}"
78+
done | jq -s -c '{ include: map(.include) | add }')
79+
80+
echo $matrix
81+
82+
echo "matrix=$matrix" > "$GITHUB_OUTPUT"
3283
3384
test:
3485
if: ( ( github.event_name == 'push' )
3586
|| ( github.event_name == 'pull_request'
3687
&& github.event.pull_request.draft == false
3788
)
3889
)
39-
name: ${{ matrix.ghc }} on ${{ matrix.os }}
90+
name: Test ${{ matrix.package }} with GHC ${{ matrix.ghc }} on ${{ matrix.os }}
4091
needs: generate-matrix
4192
runs-on: ${{ matrix.os }}
4293
strategy:
94+
fail-fast: false
4395
matrix: ${{ fromJSON(needs.generate-matrix.outputs.matrix) }}
4496

4597
steps:
46-
- uses: actions/checkout@v4
98+
- uses: actions/checkout@v4
4799

48-
- uses: haskell-actions/setup@v2.7
49-
with:
50-
ghc-version: ${{ matrix.ghc }}
51-
cabal-version: '3.0'
100+
- uses: haskell-actions/setup@v2.7
101+
with:
102+
ghc-version: ${{ matrix.ghc }}
103+
cabal-version: '3.0'
52104

53-
- name: Cache
54-
uses: actions/cache@v3
55-
env:
56-
cache-name: cache-cabal
57-
with:
58-
path: ~/.cabal
59-
key: ${{ runner.os }}-build-${{ env.cache-name }}-${{ hashFiles('**/*.cabal') }}-${{ hashFiles('**/cabal.project') }}
60-
restore-keys: |
61-
${{ runner.os }}-build-${{ env.cache-name }}-
62-
${{ runner.os }}-build-
63-
${{ runner.os }}-
105+
- name: Cache
106+
uses: actions/cache@v3
107+
env:
108+
cache-name: cache-cabal
109+
with:
110+
path: ~/.cabal
111+
key: ${{ runner.os }}-build-${{ env.cache-name }}-${{ hashFiles('**/*.cabal') }}-${{ hashFiles('**/cabal.project') }}
112+
restore-keys: |
113+
${{ runner.os }}-build-${{ env.cache-name }}-
114+
${{ runner.os }}-build-
115+
${{ runner.os }}-
64116
65-
- name: Install dependencies
66-
run: |
67-
cabal update
68-
cabal build --only-dependencies --enable-tests --enable-benchmarks
69-
- name: Build
70-
run: cabal build --enable-tests --enable-benchmarks all
71-
- name: Run tests
72-
run: cabal test all
117+
- name: Install dependencies
118+
run: |
119+
cabal update
120+
cabal build --only-dependencies --enable-tests --enable-benchmarks ${{ matrix.package }}
121+
- name: Build
122+
run: cabal build --enable-tests --enable-benchmarks ${{ matrix.package }}
123+
- name: Run tests
124+
# https://github.com/fpringle/generic-diff/actions/runs/15353395135/job/43206848857?pr=10
125+
run: |
126+
cabal configure --enable-tests
127+
cd $(dirname ${{ matrix.cabal_file }})
128+
cabal test --enable-tests

‎CHANGELOG.md‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -11,5 +11,6 @@ and this project adheres to [Haskell Package Versioning Policy](https://pvp.hask
1111

1212
- First version. Released on an unsuspecting world.
1313
- 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).
14+
- Add example implementations of `SpecialDiff` for `containers` types in [#10](https://github.com/fpringle/generic-diff/pull/10).
1415

1516
[unreleased]: https://github.com/fpringle/generic-diff/compare/74b5028...HEAD

‎cabal.project‎

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,3 @@
1+
packages:
2+
./generic-diff.cabal
3+
examples/containers-instances/generic-diff-containers.cabal

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

Lines changed: 91 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,91 @@
1+
cabal-version: 3.0
2+
name: generic-diff-containers
3+
version: 0.1.0.0
4+
license: BSD-3-Clause
5+
license-file: LICENSE
6+
author: Frederick Pringle
7+
maintainer: freddyjepringle@gmail.com
8+
copyright: Copyright(c) Frederick Pringle 2025
9+
homepage: https://github.com/fpringle/generic-diff
10+
build-type: Simple
11+
tested-with:
12+
GHC == 9.12.2
13+
GHC == 9.10.1
14+
GHC == 9.8.2
15+
GHC == 9.6.5
16+
GHC == 9.4.8
17+
GHC == 9.2.8
18+
GHC == 9.0.2
19+
GHC == 8.10.7
20+
GHC == 8.6.5
21+
22+
common warnings
23+
ghc-options: -Wall
24+
25+
common deps
26+
build-depends:
27+
, base >= 4.12 && < 5
28+
, generic-diff
29+
, sop-core >= 0.4.0.1 && < 0.6
30+
, generics-sop >= 0.4 && < 0.6
31+
, text >= 1.1 && < 2.2
32+
, containers
33+
34+
common extensions
35+
default-extensions:
36+
AllowAmbiguousTypes
37+
ConstraintKinds
38+
DataKinds
39+
DefaultSignatures
40+
DeriveGeneric
41+
FlexibleContexts
42+
FlexibleInstances
43+
GADTs
44+
LambdaCase
45+
OverloadedStrings
46+
PolyKinds
47+
RankNTypes
48+
RecordWildCards
49+
ScopedTypeVariables
50+
StandaloneDeriving
51+
TypeApplications
52+
TypeFamilies
53+
TypeOperators
54+
UndecidableInstances
55+
ViewPatterns
56+
57+
library
58+
import:
59+
warnings
60+
, deps
61+
, extensions
62+
exposed-modules:
63+
Generics.Diff.Special.Seq
64+
Generics.Diff.Special.Map
65+
Generics.Diff.Special.Set
66+
Generics.Diff.Special.Tree
67+
68+
hs-source-dirs: src
69+
default-language: Haskell2010
70+
71+
test-suite generic-diff-containers-test
72+
import:
73+
warnings
74+
, deps
75+
, extensions
76+
default-language: Haskell2010
77+
type: exitcode-stdio-1.0
78+
hs-source-dirs: test
79+
main-is: Spec.hs
80+
other-modules:
81+
Generics.Diff.UnitTestsSpec
82+
Generics.Diff.PropertyTestsSpec
83+
Util
84+
build-tool-depends:
85+
hspec-discover:hspec-discover
86+
ghc-options: -Wno-orphans
87+
build-depends:
88+
, generic-diff
89+
, generic-diff-containers
90+
, QuickCheck
91+
, hspec

‎examples/containers-instances/src/Generics/Diff/Special/Map.hs‎

Lines changed: 72 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,72 @@
1+
{-# OPTIONS_GHC -Wno-orphans #-}
2+
3+
{- | A worked example of implementing 'SpecialDiff' (and thereby 'Diff') for 'Map's.
4+
5+
We make the choice to prioritise speed over exhaustiveness: in other words we stop when we find
6+
one difference between the two input maps. Alternatively, we could have gone the other way and
7+
enumerated all the difference between the inputs, using some kind of intersection test. This is left
8+
as an exercise for the reader.
9+
-}
10+
module Generics.Diff.Special.Map
11+
( MapDiffError (..)
12+
)
13+
where
14+
15+
import Control.Applicative ((<|>))
16+
import Data.Map (Map)
17+
import qualified Data.Map.Internal as Map
18+
import Generics.Diff
19+
import Generics.Diff.Render
20+
import Generics.Diff.Special
21+
22+
-- | For 'Map's, we only pick out (maximum) one difference between the two inputs. There are three possibilities:
23+
data MapDiffError k v
24+
= -- | A key is found in both maps, but they have different values.
25+
DiffAtKey k (DiffError v)
26+
| -- | The right set contains an element that isn't found in the left set
27+
LeftMissingKey k
28+
| -- | The left set contains an element that isn't found in the right set
29+
RightMissingKey k
30+
deriving (Show, Eq)
31+
32+
{- | Render a 'MapDiffError'. This is a top-level function because we'll use it in the implementations
33+
of 'renderSpecialDiffError' for both 'Map' and 'IntMap'.
34+
-}
35+
mapDiffErrorDoc :: (Show k) => MapDiffError k v -> Doc
36+
mapDiffErrorDoc = \case
37+
-- Since we have a nested 'DiffError' on the value, we use 'makeDoc'.
38+
DiffAtKey k err ->
39+
let lns = pure ("Both maps contain key " <> showB k <> " but the values differ:")
40+
in makeDoc lns err
41+
LeftMissingKey k ->
42+
linesDoc $ pure $ "The right map contains key " <> showB k <> " but the left doesn't"
43+
RightMissingKey k ->
44+
linesDoc $ pure $ "The left map contains key " <> showB k <> " but the right doesn't"
45+
46+
------------------------------------------------------------
47+
-- Map
48+
49+
instance (Show k, Ord k, Diff v) => SpecialDiff (Map k v) where
50+
type SpecialDiffError (Map k v) = MapDiffError k v
51+
52+
-- base cases
53+
specialDiff Map.Tip Map.Tip = Nothing
54+
specialDiff Map.Tip (Map.Bin _ k _ _ _) = Just $ LeftMissingKey k
55+
specialDiff (Map.Bin _ k _ _ _) Map.Tip = Just $ RightMissingKey k
56+
-- recursive set, using Map.split
57+
specialDiff (Map.Bin _ k lVal left right) r = case Map.lookup k r of
58+
Nothing -> Just $ RightMissingKey k
59+
Just rVal ->
60+
-- first we check if the values are different (using the 'Diff' instance on v)
61+
case diff lVal rVal of
62+
Error err -> Just $ DiffAtKey k err
63+
Equal ->
64+
-- otherwise, split and recurse
65+
let (less, more) = Map.split k r
66+
in specialDiff left less <|> specialDiff right more
67+
68+
renderSpecialDiffError = mapDiffErrorDoc
69+
70+
-- | Now we can implement 'Diff' using 'diffWithSpecial'.
71+
instance (Show k, Ord k, Diff v) => Diff (Map k v) where
72+
diff = diffWithSpecial

‎examples/containers-instances/src/Generics/Diff/Special/Seq.hs‎

Lines changed: 22 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,22 @@
1+
{-# OPTIONS_GHC -Wno-orphans #-}
2+
3+
-- | A worked example of implementing 'SpecialDiff' (and thereby 'Diff') for 'Seq's.
4+
module Generics.Diff.Special.Seq () where
5+
6+
import Data.Foldable (toList)
7+
import Data.Function (on)
8+
import Data.Sequence (Seq)
9+
import Generics.Diff
10+
import Generics.Diff.Render
11+
import Generics.Diff.Special
12+
13+
{- | Just as with the instance for lists or non-empty lists (see "Generics.Diff.Special.List"),
14+
we can use 'ListDiffError', 'diffListWith' and 'listDiffErrorDoc'.
15+
-}
16+
instance (Diff a) => SpecialDiff (Seq a) where
17+
type SpecialDiffError (Seq a) = ListDiffError a
18+
specialDiff = diffListWith diff `on` toList
19+
renderSpecialDiffError = listDiffErrorDoc "sequence"
20+
21+
instance (Diff a) => Diff (Seq a) where
22+
diff = diffWithSpecial

0 commit comments

Comments
 (0)