Tests: Increase variation in generated tree shapes (#442)

Closes #438.

Also:

* haskell-ci: Use GHCup instead of HVR's PPA due to outage

.github/workflows/haskell-ci.yml

@@ -8,9 +8,9 @@
 #
 # For more information, see https://github.com/haskell-CI/haskell-ci
 #
-# version: 0.14.1
+# version: 0.14.3
 #
-# REGENDATA ("0.14.1",["github","unordered-containers.cabal"])
+# REGENDATA ("0.14.3",["github","unordered-containers.cabal"])
 #
 name: Haskell-CI
 on:
@@ -50,44 +50,34 @@ jobs:
           - compiler: ghc-8.8.4
             compilerKind: ghc
             compilerVersion: 8.8.4
-            setup-method: hvr-ppa
+            setup-method: ghcup
             allow-failure: false
           - compiler: ghc-8.6.5
             compilerKind: ghc
             compilerVersion: 8.6.5
-            setup-method: hvr-ppa
+            setup-method: ghcup
             allow-failure: false
           - compiler: ghc-8.4.4
             compilerKind: ghc
             compilerVersion: 8.4.4
-            setup-method: hvr-ppa
+            setup-method: ghcup
             allow-failure: false
           - compiler: ghc-8.2.2
             compilerKind: ghc
             compilerVersion: 8.2.2
-            setup-method: hvr-ppa
+            setup-method: ghcup
             allow-failure: false
       fail-fast: false
     steps:
       - name: apt
         run: |
           apt-get update
-          apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5
-          if [ "${{ matrix.setup-method }}" = ghcup ]; then
-            mkdir -p "$HOME/.ghcup/bin"
-            curl -sL https://downloads.haskell.org/ghcup/0.1.17.3/x86_64-linux-ghcup-0.1.17.3 > "$HOME/.ghcup/bin/ghcup"
-            chmod a+x "$HOME/.ghcup/bin/ghcup"
-            "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER"
-            "$HOME/.ghcup/bin/ghcup" install cabal 3.6.2.0
-          else
-            apt-add-repository -y 'ppa:hvr/ghc'
-            apt-get update
-            apt-get install -y "$HCNAME"
-            mkdir -p "$HOME/.ghcup/bin"
-            curl -sL https://downloads.haskell.org/ghcup/0.1.17.3/x86_64-linux-ghcup-0.1.17.3 > "$HOME/.ghcup/bin/ghcup"
-            chmod a+x "$HOME/.ghcup/bin/ghcup"
-            "$HOME/.ghcup/bin/ghcup" install cabal 3.6.2.0
-          fi
+          apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 libnuma-dev
+          mkdir -p "$HOME/.ghcup/bin"
+          curl -sL https://downloads.haskell.org/ghcup/0.1.17.5/x86_64-linux-ghcup-0.1.17.5 > "$HOME/.ghcup/bin/ghcup"
+          chmod a+x "$HOME/.ghcup/bin/ghcup"
+          "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER"
+          "$HOME/.ghcup/bin/ghcup" install cabal 3.6.2.0
         env:
           HCKIND: ${{ matrix.compilerKind }}
           HCNAME: ${{ matrix.compiler }}
@@ -99,20 +89,11 @@ jobs:
           echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV"
           echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV"
           HCDIR=/opt/$HCKIND/$HCVER
-          if [ "${{ matrix.setup-method }}" = ghcup ]; then
-            HC=$HOME/.ghcup/bin/$HCKIND-$HCVER
-            echo "HC=$HC" >> "$GITHUB_ENV"
-            echo "HCPKG=$HOME/.ghcup/bin/$HCKIND-pkg-$HCVER" >> "$GITHUB_ENV"
-            echo "HADDOCK=$HOME/.ghcup/bin/haddock-$HCVER" >> "$GITHUB_ENV"
-            echo "CABAL=$HOME/.ghcup/bin/cabal-3.6.2.0 -vnormal+nowrap" >> "$GITHUB_ENV"
-          else
-            HC=$HCDIR/bin/$HCKIND
-            echo "HC=$HC" >> "$GITHUB_ENV"
-            echo "HCPKG=$HCDIR/bin/$HCKIND-pkg" >> "$GITHUB_ENV"
-            echo "HADDOCK=$HCDIR/bin/haddock" >> "$GITHUB_ENV"
-            echo "CABAL=$HOME/.ghcup/bin/cabal-3.6.2.0 -vnormal+nowrap" >> "$GITHUB_ENV"
-          fi
-
+          HC=$HOME/.ghcup/bin/$HCKIND-$HCVER
+          echo "HC=$HC" >> "$GITHUB_ENV"
+          echo "HCPKG=$HOME/.ghcup/bin/$HCKIND-pkg-$HCVER" >> "$GITHUB_ENV"
+          echo "HADDOCK=$HOME/.ghcup/bin/haddock-$HCVER" >> "$GITHUB_ENV"
+          echo "CABAL=$HOME/.ghcup/bin/cabal-3.6.2.0 -vnormal+nowrap" >> "$GITHUB_ENV"
           HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')
           echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV"
           echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV"

cabal.haskell-ci

@@ -9,3 +9,6 @@ constraint-set debug
 
 installed: -containers
 installed: -binary
+
+-- Avoid HVR's PPA due to outage on 2022-04-27
+ghcup-jobs: True

tests/Properties/HashMapLazy.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE CPP                        #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE TypeApplications           #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-} -- because of Arbitrary (HashMap k v)
 
 -- | Tests for the 'Data.HashMap.Lazy' module.  We test functions by
@@ -26,6 +27,7 @@ import Test.QuickCheck.Function (Fun, apply)
 import Test.QuickCheck.Poly     (A, B)
 import Test.Tasty               (TestTree, testGroup)
 import Test.Tasty.QuickCheck    (testProperty)
+import Util.Key                 (Key, keyToInt)
 
 import qualified Data.Foldable as Foldable
 import qualified Data.List     as List
@@ -40,15 +42,9 @@ import qualified Data.HashMap.Lazy as HM
 import qualified Data.Map.Lazy     as M
 #endif
 
--- Key type that generates more hash collisions.
-newtype Key = K { unK :: Int }
-            deriving (Arbitrary, Eq, Ord, Read, Show, Num)
-
-instance Hashable Key where
-    hashWithSalt salt k = hashWithSalt salt (unK k) `mod` 20
-
 instance (Eq k, Hashable k, Arbitrary k, Arbitrary v) => Arbitrary (HashMap k v) where
-  arbitrary = fmap (HM.fromList) arbitrary
+  arbitrary = HM.fromList <$> arbitrary
+  shrink = fmap HM.fromList . shrink . HM.toList
 
 ------------------------------------------------------------------------
 -- * Properties
@@ -284,7 +280,7 @@ pUnionWithKey xs ys = M.unionWithKey go (M.fromList xs) `eq_`
                              HM.unionWithKey go (HM.fromList xs) $ ys
   where
     go :: Key -> Int -> Int -> Int
-    go (K k) i1 i2 = k - i1 + i2
+    go k i1 i2 = keyToInt k - i1 + i2
 
 pUnions :: [[(Key, Int)]] -> Property
 pUnions xss = M.toAscList (M.unions (map M.fromList xss)) ===
@@ -332,7 +328,7 @@ pIntersectionWithKey xs ys = M.intersectionWithKey go (M.fromList xs) `eq_`
                              HM.intersectionWithKey go (HM.fromList xs) $ ys
   where
     go :: Key -> Int -> Int -> Int
-    go (K k) i1 i2 = k - i1 - i2
+    go k i1 i2 = keyToInt k - i1 - i2
 
 ------------------------------------------------------------------------
 -- ** Folds
@@ -394,7 +390,7 @@ pFoldr' = (List.sort . M.foldr' (:) []) `eq` (List.sort . HM.foldr' (:) [])
 
 pMapMaybeWithKey :: [(Key, Int)] -> Property
 pMapMaybeWithKey = M.mapMaybeWithKey f `eq_` HM.mapMaybeWithKey f
-  where f k v = guard (odd (unK k + v)) >> Just (v + 1)
+  where f k v = guard (odd (keyToInt k + v)) >> Just (v + 1)
 
 pMapMaybe :: [(Key, Int)] -> Property
 pMapMaybe = M.mapMaybe f `eq_` HM.mapMaybe f
@@ -405,7 +401,7 @@ pFilter = M.filter odd `eq_` HM.filter odd
 
 pFilterWithKey :: [(Key, Int)] -> Property
 pFilterWithKey = M.filterWithKey p `eq_` HM.filterWithKey p
-  where p k v = odd (unK k + v)
+  where p k v = odd (keyToInt k + v)
 
 ------------------------------------------------------------------------
 -- ** Conversions
@@ -433,7 +429,7 @@ pFromListWith kvs = (M.toAscList $ M.fromListWith Op kvsM) ===
 pFromListWithKey :: [(Key, Int)] -> Property
 pFromListWithKey kvs = (M.toAscList $ M.fromListWithKey combine kvsM) ===
                        (toAscList $ HM.fromListWithKey combine kvsM)
-  where kvsM = fmap (\(K k,v) -> (Leaf k, Leaf v)) kvs
+  where kvsM = fmap (\(k,v) -> (Leaf (keyToInt k), Leaf v)) kvs
         combine k v1 v2 = Op k (Op v1 v2)
 
 pToList :: [(Key, Int)] -> Property

tests/Properties/HashSet.hs

@@ -1,29 +1,20 @@
-{-# LANGUAGE CPP                        #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-
 -- | Tests for the 'Data.HashSet' module.  We test functions by
 -- comparing them to @Set@ from @containers@.
 
 module Properties.HashSet (tests) where
 
 import Data.Hashable         (Hashable (hashWithSalt))
 import Data.Ord              (comparing)
-import Test.QuickCheck       (Arbitrary, Property, property, (===), (==>))
+import Test.QuickCheck       (Property, property, (===), (==>))
 import Test.Tasty            (TestTree, testGroup)
 import Test.Tasty.QuickCheck (testProperty)
+import Util.Key              (Key, incKey, keyToInt)
 
 import qualified Data.Foldable as Foldable
 import qualified Data.HashSet  as S
 import qualified Data.List     as List
 import qualified Data.Set      as Set
 
--- Key type that generates more hash collisions.
-newtype Key = K { unK :: Int }
-            deriving (Arbitrary, Enum, Eq, Integral, Num, Ord, Read, Show, Real)
-
-instance Hashable Key where
-    hashWithSalt salt k = hashWithSalt salt (unK k) `mod` 20
-
 ------------------------------------------------------------------------
 -- * Properties
 
@@ -128,7 +119,7 @@ pUnion xs ys = Set.union (Set.fromList xs) `eq_`
 -- ** Transformations
 
 pMap :: [Key] -> Property
-pMap = Set.map (+ 1) `eq_` S.map (+ 1)
+pMap = Set.map incKey `eq_` S.map incKey
 
 ------------------------------------------------------------------------
 -- ** Folds
@@ -150,7 +141,9 @@ foldl'Set = Set.foldl'
 -- ** Filter
 
 pFilter :: [Key] -> Property
-pFilter = Set.filter odd `eq_` S.filter odd
+pFilter = Set.filter p `eq_` S.filter p
+  where
+    p = odd . keyToInt
 
 ------------------------------------------------------------------------
 -- ** Conversions

tests/Strictness.hs

@@ -1,42 +1,27 @@
-{-# LANGUAGE CPP                        #-}
-{-# LANGUAGE FlexibleInstances          #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-} -- because of Arbitrary (HashMap k v)
 
 module Strictness (tests) where
 
 import Control.Arrow                (second)
 import Control.Monad                (guard)
 import Data.Foldable                (foldl')
-import Data.Hashable                (Hashable (hashWithSalt))
+import Data.Hashable                (Hashable)
 import Data.HashMap.Strict          (HashMap)
 import Data.Maybe                   (fromMaybe, isJust)
 import Test.ChasingBottoms.IsBottom
-import Test.QuickCheck              (Arbitrary (arbitrary), Property, (.&&.),
-                                     (===))
+import Test.QuickCheck              (Arbitrary (..), Property, (.&&.), (===))
 import Test.QuickCheck.Function
 import Test.QuickCheck.Poly         (A)
 import Test.Tasty                   (TestTree, testGroup)
 import Test.Tasty.QuickCheck        (testProperty)
+import Text.Show.Functions          ()
+import Util.Key                     (Key)
 
 import qualified Data.HashMap.Strict as HM
 
--- Key type that generates more hash collisions.
-newtype Key = K { unK :: Int }
-            deriving (Arbitrary, Eq, Ord, Show)
-
-instance Hashable Key where
-    hashWithSalt salt k = hashWithSalt salt (unK k) `mod` 20
-
-instance (Arbitrary k, Arbitrary v, Eq k, Hashable k) =>
-         Arbitrary (HashMap k v) where
-    arbitrary = HM.fromList `fmap` arbitrary
-
-instance Show (Int -> Int) where
-    show _ = "<function>"
-
-instance Show (Int -> Int -> Int) where
-    show _ = "<function>"
+instance (Eq k, Hashable k, Arbitrary k, Arbitrary v) => Arbitrary (HashMap k v) where
+  arbitrary = HM.fromList <$> arbitrary
+  shrink = fmap HM.fromList . shrink . HM.toList
 
 ------------------------------------------------------------------------
 -- * Properties
@@ -84,8 +69,8 @@ pInsertWithValueStrict f k v m
 pFromListKeyStrict :: Bool
 pFromListKeyStrict = isBottom $ HM.fromList [(undefined :: Key, 1 :: Int)]
 
-pFromListValueStrict :: Bool
-pFromListValueStrict = isBottom $ HM.fromList [(K 1, undefined)]
+pFromListValueStrict :: Key -> Bool
+pFromListValueStrict k = isBottom $ HM.fromList [(k, undefined)]
 
 pFromListWithKeyStrict :: (Int -> Int -> Int) -> Bool
 pFromListWithKeyStrict f =

tests/Util/Key.hs

@@ -0,0 +1,68 @@
+{-# LANGUAGE DeriveGeneric    #-}
+{-# LANGUAGE TypeApplications #-}
+
+module Util.Key (Key(..), keyToInt, incKey, collisionAtHash) where
+
+import Data.Bits       (bit, (.&.))
+import Data.Hashable   (Hashable (hashWithSalt))
+import Data.Word       (Word16)
+import GHC.Generics    (Generic)
+import Test.QuickCheck (Arbitrary (..), Gen, Large)
+
+import qualified Test.QuickCheck as QC
+
+-- Key type that generates more hash collisions.
+data Key = K
+  { hash :: !Int
+    -- ^ The hash of the key
+  , _x :: !SmallSum
+    -- ^ Additional data, so we can have collisions for any hash
+  } deriving (Eq, Ord, Read, Show, Generic)
+
+instance Hashable Key where
+  hashWithSalt _ (K h _) = h
+
+data SmallSum = A | B | C | D
+  deriving (Eq, Ord, Read, Show, Generic, Enum, Bounded)
+
+instance Arbitrary SmallSum where
+  arbitrary = QC.arbitraryBoundedEnum
+  shrink = shrinkSmallSum
+
+shrinkSmallSum :: SmallSum -> [SmallSum]
+shrinkSmallSum A = []
+shrinkSmallSum B = [A]
+shrinkSmallSum C = [A, B]
+shrinkSmallSum D = [A, B, C]
+
+instance Arbitrary Key where
+  arbitrary = K <$> arbitraryHash <*> arbitrary
+  shrink = QC.genericShrink
+
+arbitraryHash :: Gen Int
+arbitraryHash = do
+  let gens =
+        [ (2, (fromIntegral . QC.getLarge) <$> arbitrary @(Large Word16))
+        , (1, QC.getSmall <$> arbitrary)
+        , (1, QC.getLarge <$> arbitrary)
+        ]
+  i <- QC.frequency gens
+  moreCollisions' <- QC.elements [moreCollisions, id]
+  pure (moreCollisions' i)
+
+-- | Mask out most bits to produce more collisions
+moreCollisions :: Int -> Int
+moreCollisions w = fromIntegral (w .&. mask)
+
+mask :: Int
+mask = sum [bit n | n <- [0, 3, 8, 14, 61]]
+
+keyToInt :: Key -> Int
+keyToInt (K h x) = h * fromEnum x
+
+incKey :: Key -> Key
+incKey (K h x) = K (h + 1) x
+
+-- | 4 colliding keys at a given hash.
+collisionAtHash :: Int -> (Key, Key, Key, Key)
+collisionAtHash h = (K h A, K h B, K h C, K h D)

unordered-containers.cabal

@@ -89,6 +89,7 @@ test-suite unordered-containers-tests
     Properties.HashSet
     Properties.List
     Strictness
+    Util.Key
 
   build-depends:
     base,