From 510368c87df425b7b54b149802c01eeff44f2905 Mon Sep 17 00:00:00 2001 From: L0neGamer Date: Wed, 26 Nov 2025 17:50:36 +0000 Subject: [PATCH 1/2] simplify arbitrary instances for map and set --- containers-tests/tests/map-properties.hs | 54 ++++----------- containers-tests/tests/set-properties.hs | 87 ++++++++---------------- 2 files changed, 40 insertions(+), 101 deletions(-) diff --git a/containers-tests/tests/map-properties.hs b/containers-tests/tests/map-properties.hs index d1e5a8e1e..d41857911 100644 --- a/containers-tests/tests/map-properties.hs +++ b/containers-tests/tests/map-properties.hs @@ -1,5 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} #ifdef STRICT import Data.Map.Strict as Data.Map @@ -313,46 +315,7 @@ main = defaultMain $ testGroup "map-properties" , testProperty "mapAccumRWithKey" prop_mapAccumRWithKey ] -{-------------------------------------------------------------------- - Arbitrary, reasonably balanced trees ---------------------------------------------------------------------} - --- | The IsInt class lets us constrain a type variable to be Int in an entirely --- standard way. The constraint @ IsInt a @ is essentially equivalent to the --- GHC-only constraint @ a ~ Int @, but @ IsInt @ requires manual intervention --- to use. If ~ is ever standardized, we should certainly use it instead. --- Earlier versions used an Enum constraint, but this is confusing because --- not all Enum instances will work properly for the Arbitrary instance here. -class (Show a, Read a, Integral a, Arbitrary a) => IsInt a where - fromIntF :: f Int -> f a - -instance IsInt Int where - fromIntF = id - --- | Convert an Int to any instance of IsInt -fromInt :: IsInt a => Int -> a -fromInt = runIdentity . fromIntF . Identity - -{- We don't actually need this, but we can add it if we ever do -toIntF :: IsInt a => g a -> g Int -toIntF = unf . fromIntF . F $ id - -newtype F g a b = F {unf :: g b -> a} - -toInt :: IsInt a => a -> Int -toInt = runIdentity . toIntF . Identity -} - - --- How much the minimum key of an arbitrary map should vary -positionFactor :: Int -positionFactor = 1 - --- How much the gap between consecutive keys in an arbitrary --- map should vary -gapRange :: Int -gapRange = 5 - -instance (IsInt k, Arbitrary v) => Arbitrary (Map k v) where +instance (Int ~ k, Arbitrary v) => Arbitrary (Map k v) where arbitrary = sized (\sz0 -> do sz <- choose (0, sz0) middle <- choose (-positionFactor * (sz + 1), positionFactor * (sz + 1)) @@ -366,7 +329,16 @@ instance (IsInt k, Arbitrary v) => Arbitrary (Map k v) where diff <- lift $ choose (1, gapRange) let i' = i + diff put i' - pure (fromInt i') + pure i' + + -- How much the minimum key of an arbitrary map should vary + positionFactor :: Int + positionFactor = 1 + + -- How much the gap between consecutive keys in an arbitrary + -- map should vary + gapRange :: Int + gapRange = 5 -- A type with a peculiar Eq instance designed to make sure keys -- come from where they're supposed to. diff --git a/containers-tests/tests/set-properties.hs b/containers-tests/tests/set-properties.hs index 29bd94ca8..7499c9d6b 100644 --- a/containers-tests/tests/set-properties.hs +++ b/containers-tests/tests/set-properties.hs @@ -1,4 +1,6 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} import qualified Data.IntSet as IntSet import Data.List (nub, sort, sortBy) import qualified Data.List as List @@ -192,42 +194,7 @@ test_deleteAt = do Arbitrary, reasonably balanced trees --------------------------------------------------------------------} --- | The IsInt class lets us constrain a type variable to be Int in an entirely --- standard way. The constraint @ IsInt a @ is essentially equivalent to the --- GHC-only constraint @ a ~ Int @, but @ IsInt @ requires manual intervention --- to use. If ~ is ever standardized, we should certainly use it instead. --- Earlier versions used an Enum constraint, but this is confusing because --- not all Enum instances will work properly for the Arbitrary instance here. -class (Show a, Read a, Integral a, Arbitrary a) => IsInt a where - fromIntF :: f Int -> f a - -instance IsInt Int where - fromIntF = id - --- | Convert an Int to any instance of IsInt -fromInt :: IsInt a => Int -> a -fromInt = runIdentity . fromIntF . Identity - -{- We don't actually need this, but we can add it if we ever do -toIntF :: IsInt a => g a -> g Int -toIntF = unf . fromIntF . F $ id - -newtype F g a b = F {unf :: g b -> a} - -toInt :: IsInt a => a -> Int -toInt = runIdentity . toIntF . Identity -} - - --- How much the minimum value of an arbitrary set should vary -positionFactor :: Int -positionFactor = 1 - --- How much the gap between consecutive elements in an arbitrary --- set should vary -gapRange :: Int -gapRange = 5 - -instance IsInt a => Arbitrary (Set a) where +instance (Int ~ a) => Arbitrary (Set a) where arbitrary = sized (\sz0 -> do sz <- choose (0, sz0) middle <- choose (-positionFactor * (sz + 1), positionFactor * (sz + 1)) @@ -241,45 +208,45 @@ instance IsInt a => Arbitrary (Set a) where diff <- lift $ choose (1, gapRange) let i' = i + diff put i' - pure (fromInt i') + pure i' -data TwoSets = TwoSets (Set Int) (Set Int) deriving (Show) + -- How much the minimum value of an arbitrary set should vary + positionFactor :: Int + positionFactor = 1 -data TwoLists a = TwoLists [a] [a] + -- How much the gap between consecutive elements in an arbitrary + -- set should vary + gapRange :: Int + gapRange = 5 -data Options2 = One2 | Two2 | Both2 deriving (Bounded, Enum) -instance Arbitrary Options2 where - arbitrary = arbitraryBoundedEnum +data TwoSets = TwoSets (Set Int) (Set Int) deriving (Show) -- We produce two lists from a simple "universe". This instance -- is intended to give good results when the two lists are then -- combined with each other; if other elements are used with them, -- they may or may not behave particularly well. -instance IsInt a => Arbitrary (TwoLists a) where - arbitrary = sized $ \sz0 -> do - sz <- choose (0, sz0) - let universe = [0,3..3*(fromInt sz - 1)] - divide2Gen universe - instance Arbitrary TwoSets where arbitrary = do - TwoLists l r <- arbitrary + (l, r) <- sized $ \sz0 -> do + sz <- choose (0, sz0) + let universe = [0,3..3*(sz - 1)] + divide2Gen universe TwoSets <$> setFromList l <*> setFromList r - -divide2Gen :: [a] -> Gen (TwoLists a) -divide2Gen [] = pure (TwoLists [] []) -divide2Gen (x : xs) = do - way <- arbitrary - TwoLists ls rs <- divide2Gen xs - case way of - One2 -> pure (TwoLists (x : ls) rs) - Two2 -> pure (TwoLists ls (x : rs)) - Both2 -> pure (TwoLists (x : ls) (x : rs)) + where + divide2Gen :: [a] -> Gen ([a], [a]) + divide2Gen [] = pure ([], []) + divide2Gen (x : xs) = do + mIsFirst <- arbitrary + (ls, rs) <- divide2Gen xs + pure $ case mIsFirst of + Just True -> ((x : ls), rs) + Just False -> (ls, (x : rs)) + Nothing -> ((x : ls), (x : rs)) {-------------------------------------------------------------------- Valid trees --------------------------------------------------------------------} -forValid :: (IsInt a,Testable b) => (Set a -> b) -> Property +forValid :: (Int ~ a, Testable b) => (Set a -> b) -> Property forValid f = forAll arbitrary $ \t -> classify (size t == 0) "empty" $ classify (size t > 0 && size t <= 10) "small" $ From 38d45a13eeb969d59e663609e1559a0c870f8398 Mon Sep 17 00:00:00 2001 From: L0neGamer Date: Wed, 26 Nov 2025 18:21:57 +0000 Subject: [PATCH 2/2] add some more documentation --- containers-tests/tests/map-properties.hs | 1 + containers-tests/tests/set-properties.hs | 9 +++++++-- 2 files changed, 8 insertions(+), 2 deletions(-) diff --git a/containers-tests/tests/map-properties.hs b/containers-tests/tests/map-properties.hs index d41857911..1c0c32134 100644 --- a/containers-tests/tests/map-properties.hs +++ b/containers-tests/tests/map-properties.hs @@ -324,6 +324,7 @@ instance (Int ~ k, Arbitrary v) => Arbitrary (Map k v) where t <- evalStateT (mkArbMap step sz) start if valid t then pure t else error "Test generated invalid tree!") where + step :: StateT Int Gen Int step = do i <- get diff <- lift $ choose (1, gapRange) diff --git a/containers-tests/tests/set-properties.hs b/containers-tests/tests/set-properties.hs index 7499c9d6b..e24e21519 100644 --- a/containers-tests/tests/set-properties.hs +++ b/containers-tests/tests/set-properties.hs @@ -221,18 +221,23 @@ instance (Int ~ a) => Arbitrary (Set a) where data TwoSets = TwoSets (Set Int) (Set Int) deriving (Show) --- We produce two lists from a simple "universe". This instance +-- | We produce two lists from a simple "universe". This instance -- is intended to give good results when the two lists are then -- combined with each other; if other elements are used with them, -- they may or may not behave particularly well. +-- +-- The universe is made of ints in multiples of three. Each value is equally +-- likely to be in the left set, the right set, or both sets. instance Arbitrary TwoSets where arbitrary = do (l, r) <- sized $ \sz0 -> do sz <- choose (0, sz0) let universe = [0,3..3*(sz - 1)] divide2Gen universe - TwoSets <$> setFromList l <*> setFromList r + liftA2 TwoSets (setFromList l) (setFromList r) where + -- | Split a list into two lists, choosing to add values to one of the first list, + -- the second list, or both lists evenly. divide2Gen :: [a] -> Gen ([a], [a]) divide2Gen [] = pure ([], []) divide2Gen (x : xs) = do