Skip to content

Commit 0bbbac1

Browse files
sjakobisjakobi
authored
Tests: Increase variation in generated tree shapes (#442)
Closes #438. Also: * haskell-ci: Use GHCup instead of HVR's PPA due to outage
1 parent fe33c60 commit 0bbbac1

File tree

7 files changed

+114
-87
lines changed

7 files changed

+114
-87
lines changed

‎.github/workflows/haskell-ci.yml

Lines changed: 17 additions & 36 deletions
Original file line numberDiff line numberDiff line change
@@ -8,9 +8,9 @@
88
#
99
# For more information, see https://github.com/haskell-CI/haskell-ci
1010
#
11-
# version: 0.14.1
11+
# version: 0.14.3
1212
#
13-
# REGENDATA ("0.14.1",["github","unordered-containers.cabal"])
13+
# REGENDATA ("0.14.3",["github","unordered-containers.cabal"])
1414
#
1515
name: Haskell-CI
1616
on:
@@ -50,44 +50,34 @@ jobs:
5050
- compiler: ghc-8.8.4
5151
compilerKind: ghc
5252
compilerVersion: 8.8.4
53-
setup-method: hvr-ppa
53+
setup-method: ghcup
5454
allow-failure: false
5555
- compiler: ghc-8.6.5
5656
compilerKind: ghc
5757
compilerVersion: 8.6.5
58-
setup-method: hvr-ppa
58+
setup-method: ghcup
5959
allow-failure: false
6060
- compiler: ghc-8.4.4
6161
compilerKind: ghc
6262
compilerVersion: 8.4.4
63-
setup-method: hvr-ppa
63+
setup-method: ghcup
6464
allow-failure: false
6565
- compiler: ghc-8.2.2
6666
compilerKind: ghc
6767
compilerVersion: 8.2.2
68-
setup-method: hvr-ppa
68+
setup-method: ghcup
6969
allow-failure: false
7070
fail-fast: false
7171
steps:
7272
- name: apt
7373
run: |
7474
apt-get update
75-
apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5
76-
if [ "${{ matrix.setup-method }}" = ghcup ]; then
77-
mkdir -p "$HOME/.ghcup/bin"
78-
curl -sL https://downloads.haskell.org/ghcup/0.1.17.3/x86_64-linux-ghcup-0.1.17.3 > "$HOME/.ghcup/bin/ghcup"
79-
chmod a+x "$HOME/.ghcup/bin/ghcup"
80-
"$HOME/.ghcup/bin/ghcup" install ghc "$HCVER"
81-
"$HOME/.ghcup/bin/ghcup" install cabal 3.6.2.0
82-
else
83-
apt-add-repository -y 'ppa:hvr/ghc'
84-
apt-get update
85-
apt-get install -y "$HCNAME"
86-
mkdir -p "$HOME/.ghcup/bin"
87-
curl -sL https://downloads.haskell.org/ghcup/0.1.17.3/x86_64-linux-ghcup-0.1.17.3 > "$HOME/.ghcup/bin/ghcup"
88-
chmod a+x "$HOME/.ghcup/bin/ghcup"
89-
"$HOME/.ghcup/bin/ghcup" install cabal 3.6.2.0
90-
fi
75+
apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 libnuma-dev
76+
mkdir -p "$HOME/.ghcup/bin"
77+
curl -sL https://downloads.haskell.org/ghcup/0.1.17.5/x86_64-linux-ghcup-0.1.17.5 > "$HOME/.ghcup/bin/ghcup"
78+
chmod a+x "$HOME/.ghcup/bin/ghcup"
79+
"$HOME/.ghcup/bin/ghcup" install ghc "$HCVER"
80+
"$HOME/.ghcup/bin/ghcup" install cabal 3.6.2.0
9181
env:
9282
HCKIND: ${{ matrix.compilerKind }}
9383
HCNAME: ${{ matrix.compiler }}
@@ -99,20 +89,11 @@ jobs:
9989
echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV"
10090
echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV"
10191
HCDIR=/opt/$HCKIND/$HCVER
102-
if [ "${{ matrix.setup-method }}" = ghcup ]; then
103-
HC=$HOME/.ghcup/bin/$HCKIND-$HCVER
104-
echo "HC=$HC" >> "$GITHUB_ENV"
105-
echo "HCPKG=$HOME/.ghcup/bin/$HCKIND-pkg-$HCVER" >> "$GITHUB_ENV"
106-
echo "HADDOCK=$HOME/.ghcup/bin/haddock-$HCVER" >> "$GITHUB_ENV"
107-
echo "CABAL=$HOME/.ghcup/bin/cabal-3.6.2.0 -vnormal+nowrap" >> "$GITHUB_ENV"
108-
else
109-
HC=$HCDIR/bin/$HCKIND
110-
echo "HC=$HC" >> "$GITHUB_ENV"
111-
echo "HCPKG=$HCDIR/bin/$HCKIND-pkg" >> "$GITHUB_ENV"
112-
echo "HADDOCK=$HCDIR/bin/haddock" >> "$GITHUB_ENV"
113-
echo "CABAL=$HOME/.ghcup/bin/cabal-3.6.2.0 -vnormal+nowrap" >> "$GITHUB_ENV"
114-
fi
115-
92+
HC=$HOME/.ghcup/bin/$HCKIND-$HCVER
93+
echo "HC=$HC" >> "$GITHUB_ENV"
94+
echo "HCPKG=$HOME/.ghcup/bin/$HCKIND-pkg-$HCVER" >> "$GITHUB_ENV"
95+
echo "HADDOCK=$HOME/.ghcup/bin/haddock-$HCVER" >> "$GITHUB_ENV"
96+
echo "CABAL=$HOME/.ghcup/bin/cabal-3.6.2.0 -vnormal+nowrap" >> "$GITHUB_ENV"
11697
HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')
11798
echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV"
11899
echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV"

‎cabal.haskell-ci

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -9,3 +9,6 @@ constraint-set debug
99

1010
installed: -containers
1111
installed: -binary
12+
13+
-- Avoid HVR's PPA due to outage on 2022-04-27
14+
ghcup-jobs: True

‎tests/Properties/HashMapLazy.hs

Lines changed: 9 additions & 13 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,6 @@
11
{-# LANGUAGE CPP #-}
22
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3+
{-# LANGUAGE TypeApplications #-}
34
{-# OPTIONS_GHC -fno-warn-orphans #-} -- because of Arbitrary (HashMap k v)
45

56
-- | Tests for the 'Data.HashMap.Lazy' module. We test functions by
@@ -26,6 +27,7 @@ import Test.QuickCheck.Function (Fun, apply)
2627
import Test.QuickCheck.Poly (A, B)
2728
import Test.Tasty (TestTree, testGroup)
2829
import Test.Tasty.QuickCheck (testProperty)
30+
import Util.Key (Key, keyToInt)
2931

3032
import qualified Data.Foldable as Foldable
3133
import qualified Data.List as List
@@ -40,15 +42,9 @@ import qualified Data.HashMap.Lazy as HM
4042
import qualified Data.Map.Lazy as M
4143
#endif
4244

43-
-- Key type that generates more hash collisions.
44-
newtype Key = K { unK :: Int }
45-
deriving (Arbitrary, Eq, Ord, Read, Show, Num)
46-
47-
instance Hashable Key where
48-
hashWithSalt salt k = hashWithSalt salt (unK k) `mod` 20
49-
5045
instance (Eq k, Hashable k, Arbitrary k, Arbitrary v) => Arbitrary (HashMap k v) where
51-
arbitrary = fmap (HM.fromList) arbitrary
46+
arbitrary = HM.fromList <$> arbitrary
47+
shrink = fmap HM.fromList . shrink . HM.toList
5248

5349
------------------------------------------------------------------------
5450
-- * Properties
@@ -284,7 +280,7 @@ pUnionWithKey xs ys = M.unionWithKey go (M.fromList xs) `eq_`
284280
HM.unionWithKey go (HM.fromList xs) $ ys
285281
where
286282
go :: Key -> Int -> Int -> Int
287-
go (K k) i1 i2 = k - i1 + i2
283+
go k i1 i2 = keyToInt k - i1 + i2
288284

289285
pUnions :: [[(Key, Int)]] -> Property
290286
pUnions xss = M.toAscList (M.unions (map M.fromList xss)) ===
@@ -332,7 +328,7 @@ pIntersectionWithKey xs ys = M.intersectionWithKey go (M.fromList xs) `eq_`
332328
HM.intersectionWithKey go (HM.fromList xs) $ ys
333329
where
334330
go :: Key -> Int -> Int -> Int
335-
go (K k) i1 i2 = k - i1 - i2
331+
go k i1 i2 = keyToInt k - i1 - i2
336332

337333
------------------------------------------------------------------------
338334
-- ** Folds
@@ -394,7 +390,7 @@ pFoldr' = (List.sort . M.foldr' (:) []) `eq` (List.sort . HM.foldr' (:) [])
394390

395391
pMapMaybeWithKey :: [(Key, Int)] -> Property
396392
pMapMaybeWithKey = M.mapMaybeWithKey f `eq_` HM.mapMaybeWithKey f
397-
where f k v = guard (odd (unK k + v)) >> Just (v + 1)
393+
where f k v = guard (odd (keyToInt k + v)) >> Just (v + 1)
398394

399395
pMapMaybe :: [(Key, Int)] -> Property
400396
pMapMaybe = M.mapMaybe f `eq_` HM.mapMaybe f
@@ -405,7 +401,7 @@ pFilter = M.filter odd `eq_` HM.filter odd
405401

406402
pFilterWithKey :: [(Key, Int)] -> Property
407403
pFilterWithKey = M.filterWithKey p `eq_` HM.filterWithKey p
408-
where p k v = odd (unK k + v)
404+
where p k v = odd (keyToInt k + v)
409405

410406
------------------------------------------------------------------------
411407
-- ** Conversions
@@ -433,7 +429,7 @@ pFromListWith kvs = (M.toAscList $ M.fromListWith Op kvsM) ===
433429
pFromListWithKey :: [(Key, Int)] -> Property
434430
pFromListWithKey kvs = (M.toAscList $ M.fromListWithKey combine kvsM) ===
435431
(toAscList $ HM.fromListWithKey combine kvsM)
436-
where kvsM = fmap (\(K k,v) -> (Leaf k, Leaf v)) kvs
432+
where kvsM = fmap (\(k,v) -> (Leaf (keyToInt k), Leaf v)) kvs
437433
combine k v1 v2 = Op k (Op v1 v2)
438434

439435
pToList :: [(Key, Int)] -> Property

‎tests/Properties/HashSet.hs

Lines changed: 6 additions & 13 deletions
Original file line numberDiff line numberDiff line change
@@ -1,29 +1,20 @@
1-
{-# LANGUAGE CPP #-}
2-
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3-
41
-- | Tests for the 'Data.HashSet' module. We test functions by
52
-- comparing them to @Set@ from @containers@.
63

74
module Properties.HashSet (tests) where
85

96
import Data.Hashable (Hashable (hashWithSalt))
107
import Data.Ord (comparing)
11-
import Test.QuickCheck (Arbitrary, Property, property, (===), (==>))
8+
import Test.QuickCheck (Property, property, (===), (==>))
129
import Test.Tasty (TestTree, testGroup)
1310
import Test.Tasty.QuickCheck (testProperty)
11+
import Util.Key (Key, incKey, keyToInt)
1412

1513
import qualified Data.Foldable as Foldable
1614
import qualified Data.HashSet as S
1715
import qualified Data.List as List
1816
import qualified Data.Set as Set
1917

20-
-- Key type that generates more hash collisions.
21-
newtype Key = K { unK :: Int }
22-
deriving (Arbitrary, Enum, Eq, Integral, Num, Ord, Read, Show, Real)
23-
24-
instance Hashable Key where
25-
hashWithSalt salt k = hashWithSalt salt (unK k) `mod` 20
26-
2718
------------------------------------------------------------------------
2819
-- * Properties
2920

@@ -128,7 +119,7 @@ pUnion xs ys = Set.union (Set.fromList xs) `eq_`
128119
-- ** Transformations
129120

130121
pMap :: [Key] -> Property
131-
pMap = Set.map (+ 1) `eq_` S.map (+ 1)
122+
pMap = Set.map incKey `eq_` S.map incKey
132123

133124
------------------------------------------------------------------------
134125
-- ** Folds
@@ -150,7 +141,9 @@ foldl'Set = Set.foldl'
150141
-- ** Filter
151142

152143
pFilter :: [Key] -> Property
153-
pFilter = Set.filter odd `eq_` S.filter odd
144+
pFilter = Set.filter p `eq_` S.filter p
145+
where
146+
p = odd . keyToInt
154147

155148
------------------------------------------------------------------------
156149
-- ** Conversions

‎tests/Strictness.hs

Lines changed: 10 additions & 25 deletions
Original file line numberDiff line numberDiff line change
@@ -1,42 +1,27 @@
1-
{-# LANGUAGE CPP #-}
2-
{-# LANGUAGE FlexibleInstances #-}
3-
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4-
{-# OPTIONS_GHC -fno-warn-orphans #-}
1+
{-# OPTIONS_GHC -fno-warn-orphans #-} -- because of Arbitrary (HashMap k v)
52

63
module Strictness (tests) where
74

85
import Control.Arrow (second)
96
import Control.Monad (guard)
107
import Data.Foldable (foldl')
11-
import Data.Hashable (Hashable (hashWithSalt))
8+
import Data.Hashable (Hashable)
129
import Data.HashMap.Strict (HashMap)
1310
import Data.Maybe (fromMaybe, isJust)
1411
import Test.ChasingBottoms.IsBottom
15-
import Test.QuickCheck (Arbitrary (arbitrary), Property, (.&&.),
16-
(===))
12+
import Test.QuickCheck (Arbitrary (..), Property, (.&&.), (===))
1713
import Test.QuickCheck.Function
1814
import Test.QuickCheck.Poly (A)
1915
import Test.Tasty (TestTree, testGroup)
2016
import Test.Tasty.QuickCheck (testProperty)
17+
import Text.Show.Functions ()
18+
import Util.Key (Key)
2119

2220
import qualified Data.HashMap.Strict as HM
2321

24-
-- Key type that generates more hash collisions.
25-
newtype Key = K { unK :: Int }
26-
deriving (Arbitrary, Eq, Ord, Show)
27-
28-
instance Hashable Key where
29-
hashWithSalt salt k = hashWithSalt salt (unK k) `mod` 20
30-
31-
instance (Arbitrary k, Arbitrary v, Eq k, Hashable k) =>
32-
Arbitrary (HashMap k v) where
33-
arbitrary = HM.fromList `fmap` arbitrary
34-
35-
instance Show (Int -> Int) where
36-
show _ = "<function>"
37-
38-
instance Show (Int -> Int -> Int) where
39-
show _ = "<function>"
22+
instance (Eq k, Hashable k, Arbitrary k, Arbitrary v) => Arbitrary (HashMap k v) where
23+
arbitrary = HM.fromList <$> arbitrary
24+
shrink = fmap HM.fromList . shrink . HM.toList
4025

4126
------------------------------------------------------------------------
4227
-- * Properties
@@ -84,8 +69,8 @@ pInsertWithValueStrict f k v m
8469
pFromListKeyStrict :: Bool
8570
pFromListKeyStrict = isBottom $ HM.fromList [(undefined :: Key, 1 :: Int)]
8671

87-
pFromListValueStrict :: Bool
88-
pFromListValueStrict = isBottom $ HM.fromList [(K 1, undefined)]
72+
pFromListValueStrict :: Key -> Bool
73+
pFromListValueStrict k = isBottom $ HM.fromList [(k, undefined)]
8974

9075
pFromListWithKeyStrict :: (Int -> Int -> Int) -> Bool
9176
pFromListWithKeyStrict f =

‎tests/Util/Key.hs

Lines changed: 68 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,68 @@
1+
{-# LANGUAGE DeriveGeneric #-}
2+
{-# LANGUAGE TypeApplications #-}
3+
4+
module Util.Key (Key(..), keyToInt, incKey, collisionAtHash) where
5+
6+
import Data.Bits (bit, (.&.))
7+
import Data.Hashable (Hashable (hashWithSalt))
8+
import Data.Word (Word16)
9+
import GHC.Generics (Generic)
10+
import Test.QuickCheck (Arbitrary (..), Gen, Large)
11+
12+
import qualified Test.QuickCheck as QC
13+
14+
-- Key type that generates more hash collisions.
15+
data Key = K
16+
{ hash :: !Int
17+
-- ^ The hash of the key
18+
, _x :: !SmallSum
19+
-- ^ Additional data, so we can have collisions for any hash
20+
} deriving (Eq, Ord, Read, Show, Generic)
21+
22+
instance Hashable Key where
23+
hashWithSalt _ (K h _) = h
24+
25+
data SmallSum = A | B | C | D
26+
deriving (Eq, Ord, Read, Show, Generic, Enum, Bounded)
27+
28+
instance Arbitrary SmallSum where
29+
arbitrary = QC.arbitraryBoundedEnum
30+
shrink = shrinkSmallSum
31+
32+
shrinkSmallSum :: SmallSum -> [SmallSum]
33+
shrinkSmallSum A = []
34+
shrinkSmallSum B = [A]
35+
shrinkSmallSum C = [A, B]
36+
shrinkSmallSum D = [A, B, C]
37+
38+
instance Arbitrary Key where
39+
arbitrary = K <$> arbitraryHash <*> arbitrary
40+
shrink = QC.genericShrink
41+
42+
arbitraryHash :: Gen Int
43+
arbitraryHash = do
44+
let gens =
45+
[ (2, (fromIntegral . QC.getLarge) <$> arbitrary @(Large Word16))
46+
, (1, QC.getSmall <$> arbitrary)
47+
, (1, QC.getLarge <$> arbitrary)
48+
]
49+
i <- QC.frequency gens
50+
moreCollisions' <- QC.elements [moreCollisions, id]
51+
pure (moreCollisions' i)
52+
53+
-- | Mask out most bits to produce more collisions
54+
moreCollisions :: Int -> Int
55+
moreCollisions w = fromIntegral (w .&. mask)
56+
57+
mask :: Int
58+
mask = sum [bit n | n <- [0, 3, 8, 14, 61]]
59+
60+
keyToInt :: Key -> Int
61+
keyToInt (K h x) = h * fromEnum x
62+
63+
incKey :: Key -> Key
64+
incKey (K h x) = K (h + 1) x
65+
66+
-- | 4 colliding keys at a given hash.
67+
collisionAtHash :: Int -> (Key, Key, Key, Key)
68+
collisionAtHash h = (K h A, K h B, K h C, K h D)

‎unordered-containers.cabal

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -89,6 +89,7 @@ test-suite unordered-containers-tests
8989
Properties.HashSet
9090
Properties.List
9191
Strictness
92+
Util.Key
9293

9394
build-depends:
9495
base,

0 commit comments

Comments
 (0)