diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,18 @@ ## [Unreleased] +## [0.9.0.0] - 2020-06-14 + +### Added + +* `genMapOf` +* `genSeqOf` +* `genSetOf` + +### Changed + +* Improved the generation of Set, Seq and Map to generate more appropriately (bigger) sized collections + ## [0.8.0.2] - 2020-02-10 ### Changed diff --git a/bench/Main.hs b/bench/Main.hs --- a/bench/Main.hs +++ b/bench/Main.hs @@ -1,26 +1,28 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} module Main where +import Criterion.Main as Criterion +import Data.GenValidity +import Data.GenValidity.Containers +import Data.GenValidity.Criterion import Data.Map (Map) import Data.Sequence (Seq) import Data.Set (Set) import Data.Tree (Forest, Tree) - -import Criterion.Main as Criterion - - -import Data.GenValidity.Containers () -import Data.GenValidity.Criterion +import Test.QuickCheck main :: IO () main = Criterion.defaultMain - [ genValidBench @(Set Int) - , genValidBench @(Seq Int) - , genValidBench @(Tree Int) - , genValidBench @(Forest Int) - , genValidBench @(Map Int Int) + [ genValidBench @(Set Int), + genValidBench @(Seq Int), + genValidBench @(Tree Int), + genValidBench @(Forest Int), + genValidBench @(Map Int Int), + genBenchSizes "genSeqOf" $ genSeqOf (genValid :: Gen Int), + genBenchSizes "genSetOf" $ genSetOf (genValid :: Gen Int), + genBenchSizes "genMapOf" $ genMapOf (genValid :: Gen (Int, Int)) ] diff --git a/genvalidity-containers.cabal b/genvalidity-containers.cabal --- a/genvalidity-containers.cabal +++ b/genvalidity-containers.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: cc5a5331fe04afda9869d3afa266c4dca21b717141d42d91d701385413187885 +-- hash: 1f475d682a51c1839b38c10a051dbd9df5a0b7f4cd1323be22c26605a4495c48 name: genvalidity-containers -version: 0.8.0.2 +version: 0.9.0.0 synopsis: GenValidity support for containers category: Testing homepage: https://github.com/NorfairKing/validity#readme @@ -39,7 +39,7 @@ build-depends: QuickCheck , base >=4.9 && <=5 - , containers + , containers >=0.6.0.1 , genvalidity >=0.8 , validity >=0.5 , validity-containers >=0.3 @@ -49,16 +49,17 @@ type: exitcode-stdio-1.0 main-is: Spec.hs other-modules: - Test.Validity.Containers.MapSpec - Test.Validity.Containers.SeqSpec - Test.Validity.Containers.SetSpec - Test.Validity.Containers.TreeSpec + Data.GenValidity.Containers.MapSpec + Data.GenValidity.Containers.SeqSpec + Data.GenValidity.Containers.SetSpec + Data.GenValidity.Containers.TreeSpec Paths_genvalidity_containers hs-source-dirs: test/ ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall build-depends: - base >=4.9 && <=5 + QuickCheck + , base >=4.9 && <=5 , containers , genvalidity >=0.7 , genvalidity-containers >=0.5 @@ -66,6 +67,7 @@ , genvalidity-property >=0.5 , hspec , validity >=0.9 + , validity-containers default-language: Haskell2010 benchmark genvalidity-containers-bench @@ -81,6 +83,7 @@ , base >=4.9 && <=5 , containers , criterion + , genvalidity , genvalidity-containers , genvalidity-criterion default-language: Haskell2010 diff --git a/src/Data/GenValidity/Containers.hs b/src/Data/GenValidity/Containers.hs --- a/src/Data/GenValidity/Containers.hs +++ b/src/Data/GenValidity/Containers.hs @@ -1,8 +1,9 @@ module Data.GenValidity.Containers - ( module Containers - ) where + ( module Containers, + ) +where -import Data.GenValidity.Map as Containers () -import Data.GenValidity.Sequence as Containers () -import Data.GenValidity.Set as Containers () +import Data.GenValidity.Map as Containers +import Data.GenValidity.Sequence as Containers +import Data.GenValidity.Set as Containers import Data.GenValidity.Tree as Containers diff --git a/src/Data/GenValidity/Map.hs b/src/Data/GenValidity/Map.hs --- a/src/Data/GenValidity/Map.hs +++ b/src/Data/GenValidity/Map.hs @@ -2,7 +2,8 @@ {-# LANGUAGE CPP #-} module Data.GenValidity.Map - ( genStructurallyValidMapOf + ( genMapOf + , genStructurallyValidMapOf , genStructurallyValidMapOfInvalidValues #if MIN_VERSION_containers(0,5,9) , genStructurallyInvalidMap @@ -47,7 +48,7 @@ shrinkUnchecked = fmap M.fromList . shrinkUnchecked . M.toList #endif instance (Show k, Ord k, GenValid k, GenValid v) => GenValid (Map k v) where - genValid = M.fromList <$> genValid + genValid = genMapOf genValid shrinkValid = fmap M.fromList . shrinkValid . M.toList #if MIN_VERSION_containers(0,5,9) instance (Show k, Ord k, GenUnchecked k, GenInvalid k, GenUnchecked v, GenInvalid v) => GenInvalid (Map k v) where @@ -58,16 +59,12 @@ instance (Show k, Ord k, GenUnchecked k, GenInvalid k, GenUnchecked v, GenInvalid v) => GenInvalid (Map k v) where genInvalid = genStructurallyValidMapOfInvalidValues #endif + +genMapOf :: Ord k => Gen (k, v) -> Gen (Map k v) +genMapOf = genStructurallyValidMapOf + genStructurallyValidMapOf :: Ord k => Gen (k, v) -> Gen (Map k v) -genStructurallyValidMapOf g = - sized $ \n -> - case n of - 0 -> pure M.empty - _ -> do - (kv, m) <- genSplit n - (key, val) <- resize kv g - rest <- resize m $ genStructurallyValidMapOf g - pure $ M.insert key val rest +genStructurallyValidMapOf g = M.fromList <$> genListOf g -- Note: M.fromList <$> genInvalid does not work because of this line in the Data.Map documentation: -- ' If the list contains more than one value for the same key, the last value for the key is retained.' diff --git a/src/Data/GenValidity/Sequence.hs b/src/Data/GenValidity/Sequence.hs --- a/src/Data/GenValidity/Sequence.hs +++ b/src/Data/GenValidity/Sequence.hs @@ -1,7 +1,10 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE CPP #-} -module Data.GenValidity.Sequence where +module Data.GenValidity.Sequence ( + genSeqOf, + ) where +import Test.QuickCheck #if !MIN_VERSION_base(4,8,0) import Data.Functor ((<$>)) #endif @@ -13,13 +16,15 @@ import qualified Data.Sequence as S instance GenUnchecked v => GenUnchecked (Seq v) where - genUnchecked = S.fromList <$> genUnchecked + genUnchecked = genSeqOf genUnchecked shrinkUnchecked = fmap S.fromList . shrinkUnchecked . toList instance GenValid v => GenValid (Seq v) where - genValid = S.fromList <$> genValid + genValid = genSeqOf genValid shrinkValid = fmap S.fromList . shrinkValid . toList instance (GenUnchecked v, GenInvalid v) => GenInvalid (Seq v) where - genInvalid = S.fromList <$> genInvalid shrinkInvalid = fmap S.fromList . shrinkInvalid . toList + +genSeqOf :: Gen v -> Gen (Seq v) +genSeqOf g = S.fromList <$> genListOf g diff --git a/src/Data/GenValidity/Set.hs b/src/Data/GenValidity/Set.hs --- a/src/Data/GenValidity/Set.hs +++ b/src/Data/GenValidity/Set.hs @@ -2,19 +2,28 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Data.GenValidity.Set - ( genStructurallyValidSetOf + ( genSetOf + , genStructurallyValidSetOf , genStructurallyValidSetOfInvalidValues #if MIN_VERSION_containers(0,5,9) , genStructurallyInvalidSet #endif + , genSeperate + , genSeperateFor + , genSeperateForNE + , genValidSeperateFor + , genValidSeperateForNE ) where #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>), pure) #endif import Data.GenValidity import Data.Validity.Set () +import Data.Containers.ListUtils import Test.QuickCheck +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NE import Data.Set (Set) import qualified Data.Set as S #if MIN_VERSION_containers(0,5,9) @@ -56,16 +65,12 @@ instance (Ord v, GenUnchecked v, GenInvalid v) => GenInvalid (Set v) where genInvalid = genStructurallyValidSetOfInvalidValues #endif + +genSetOf :: Ord v => Gen v -> Gen (Set v) +genSetOf = genStructurallyValidSetOf + genStructurallyValidSetOf :: Ord v => Gen v -> Gen (Set v) -genStructurallyValidSetOf g = - sized $ \n -> - case n of - 0 -> pure S.empty - _ -> do - (v, m) <- genSplit n - val <- resize v g - rest <- resize m $ genStructurallyValidSetOf g - pure $ S.insert val rest +genStructurallyValidSetOf g = S.fromList <$> genListOf g -- Note: M.fromList <$> genInvalid does not work because of this line in the Data.Set documentation: -- ' If the list contains more than one value for the same key, the last value for the key is retained.' @@ -84,3 +89,29 @@ then scale (+ 1) genStructurallyInvalidSet else pure v #endif + +genValidSeperateFor :: (GenValid b, Eq b) => [a] -> Gen [(b, a)] +genValidSeperateFor = genSeperateFor genValid + +genValidSeperateForNE :: (GenValid b, Eq b) => NonEmpty a -> Gen (NonEmpty (b, a)) +genValidSeperateForNE = genSeperateForNE genValid + +#if MIN_VERSION_containers(0,6,0) +genSeperate :: Ord a => Gen a -> Gen [a] +genSeperate g = nubOrd <$> genListOf g +#else +genSeperate :: Eq a => Gen a -> Gen [a] +genSeperate g = nub <$> genListOf g +#endif + +-- TODO these two can likely be optimised +genSeperateFor :: Eq b => Gen b -> [a] -> Gen [(b, a)] +genSeperateFor _ [] = pure [] +genSeperateFor g (a : as) = NE.toList <$> genSeperateForNE g (a :| as) + +genSeperateForNE :: Eq b => Gen b -> NonEmpty a -> Gen (NonEmpty (b, a)) +genSeperateForNE g (a :| as) = do + restTups <- genSeperateFor g as + b <- g `suchThat` (`notElem` map fst restTups) + pure ((b, a) :| restTups) + diff --git a/test/Data/GenValidity/Containers/MapSpec.hs b/test/Data/GenValidity/Containers/MapSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/GenValidity/Containers/MapSpec.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeApplications #-} + +module Data.GenValidity.Containers.MapSpec where + +import Test.Hspec + +import Data.GenValidity +import Data.GenValidity.Map +import Data.Map (Map) +import Test.Validity.GenValidity + +spec :: Spec +spec = do + describe "genStructurallyValidMapOf" $ + it "produces valid maps" $ + genGeneratesValid + (genStructurallyValidMapOf @Rational @Rational genValid) + describe "genStructurallyValidMapOfInvalidValues" $ + it "produces valid maps" $ + genGeneratesInvalid + (genStructurallyValidMapOfInvalidValues @Rational @Rational) +#if MIN_VERSION_containers(0,5,9) + describe "genStructurallyInvalidMap" $ + it "produces invalid maps" $ + genGeneratesInvalid + (genStructurallyInvalidMap @Rational @Rational) +#endif + genValidSpec @(Map Int Rational) + genValiditySpec @(Map Rational Rational) diff --git a/test/Data/GenValidity/Containers/SeqSpec.hs b/test/Data/GenValidity/Containers/SeqSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/GenValidity/Containers/SeqSpec.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE TypeApplications #-} + +module Data.GenValidity.Containers.SeqSpec where + +import Data.GenValidity.Sequence () +import Data.Sequence (Seq) +import Test.Hspec +import Test.Validity.GenValidity + +spec :: Spec +spec = do + genValidSpec @(Seq Int) + genValiditySpec @(Seq Rational) diff --git a/test/Data/GenValidity/Containers/SetSpec.hs b/test/Data/GenValidity/Containers/SetSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/GenValidity/Containers/SetSpec.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeApplications #-} + +module Data.GenValidity.Containers.SetSpec where + +import Data.GenValidity +import Data.GenValidity.Set +import Data.Set (Set) +import Data.Validity.Containers +import Test.Hspec +import Test.QuickCheck +import Test.Validity + +spec :: Spec +spec = do + describe "genStructurallyValidSetOf" $ + it "produces valid sets" $ + genGeneratesValid + (genStructurallyValidSetOf @Rational genValid) + describe "genStructurallyValidSetOfInvalidValues" $ + it "produces valid sets" $ + genGeneratesInvalid + (genStructurallyValidSetOfInvalidValues @Rational) +#if MIN_VERSION_containers(0,5,9) + describe "genStructurallyInvalidSet" $ + it "produces invalid sets" $ + genGeneratesInvalid (genStructurallyInvalidSet @Rational) +#endif + genValidSpec @(Set Int) + genValiditySpec @(Set Rational) + describe "genSeperate" $ do + it "generates values that are seperate" $ + forAll (genSeperate genUnchecked) $ \ls -> distinctOrd (ls :: [Int]) + it "generates values that are seperate" $ + forAll (genSeperate genValid) $ \ls -> distinctOrd (ls :: [Int]) + describe "genSeperateFor" $ do + it "generates values that are seperate" $ + forAllValid $ \ls -> + forAll (genSeperateFor genUnchecked ls) $ \tups -> distinctOrd (map fst (tups :: [(Int, Int)])) + it "generates values that are seperate" $ + forAllValid $ \ls -> + forAll (genSeperateFor genValid ls) $ \tups -> distinctOrd (map fst(tups :: [(Int, Int)])) + describe "genValidSeperateFor" $ + it "generates values that are seperate" $ + forAllValid $ \ls -> + forAll (genValidSeperateFor ls) $ \tups -> distinctOrd (map fst (tups :: [(Int, Int)])) diff --git a/test/Data/GenValidity/Containers/TreeSpec.hs b/test/Data/GenValidity/Containers/TreeSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/GenValidity/Containers/TreeSpec.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE TypeApplications #-} + +module Data.GenValidity.Containers.TreeSpec where + +import Data.GenValidity.Tree () +import Data.Tree (Tree) +import Test.Hspec +import Test.Validity + +spec :: Spec +spec = do + genValidSpec @(Tree Int) + genValiditySpec @(Tree Rational) diff --git a/test/Test/Validity/Containers/MapSpec.hs b/test/Test/Validity/Containers/MapSpec.hs deleted file mode 100644 --- a/test/Test/Validity/Containers/MapSpec.hs +++ /dev/null @@ -1,30 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TypeApplications #-} - -module Test.Validity.Containers.MapSpec where - -import Test.Hspec - -import Data.GenValidity -import Data.GenValidity.Map -import Data.Map (Map) -import Test.Validity.GenValidity - -spec :: Spec -spec = do - describe "genStructurallyValidMapOf" $ - it "produces valid maps" $ - genGeneratesValid - (genStructurallyValidMapOf @Rational @Rational genValid) - describe "genStructurallyValidMapOfInvalidValues" $ - it "produces valid maps" $ - genGeneratesInvalid - (genStructurallyValidMapOfInvalidValues @Rational @Rational) -#if MIN_VERSION_containers(0,5,9) - describe "genStructurallyInvalidMap" $ - it "produces invalid maps" $ - genGeneratesInvalid - (genStructurallyInvalidMap @Rational @Rational) -#endif - genValidSpec @(Map Int Rational) - genValiditySpec @(Map Rational Rational) diff --git a/test/Test/Validity/Containers/SeqSpec.hs b/test/Test/Validity/Containers/SeqSpec.hs deleted file mode 100644 --- a/test/Test/Validity/Containers/SeqSpec.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE TypeApplications #-} - -module Test.Validity.Containers.SeqSpec where - -import Test.Hspec - -import Data.GenValidity.Sequence () -import Data.Sequence (Seq) -import Test.Validity.GenValidity - -spec :: Spec -spec = do - genValidSpec @(Seq Int) - genValiditySpec @(Seq Rational) diff --git a/test/Test/Validity/Containers/SetSpec.hs b/test/Test/Validity/Containers/SetSpec.hs deleted file mode 100644 --- a/test/Test/Validity/Containers/SetSpec.hs +++ /dev/null @@ -1,29 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TypeApplications #-} - -module Test.Validity.Containers.SetSpec where - -import Test.Hspec - -import Data.GenValidity -import Data.GenValidity.Set -import Data.Set (Set) -import Test.Validity.GenValidity - -spec :: Spec -spec = do - describe "genStructurallyValidSetOf" $ - it "produces valid sets" $ - genGeneratesValid - (genStructurallyValidSetOf @Rational genValid) - describe "genStructurallyValidSetOfInvalidValues" $ - it "produces valid sets" $ - genGeneratesInvalid - (genStructurallyValidSetOfInvalidValues @Rational) -#if MIN_VERSION_containers(0,5,9) - describe "genStructurallyInvalidSet" $ - it "produces invalid sets" $ - genGeneratesInvalid (genStructurallyInvalidSet @Rational) -#endif - genValidSpec @(Set Int) - genValiditySpec @(Set Rational) diff --git a/test/Test/Validity/Containers/TreeSpec.hs b/test/Test/Validity/Containers/TreeSpec.hs deleted file mode 100644 --- a/test/Test/Validity/Containers/TreeSpec.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE TypeApplications #-} - -module Test.Validity.Containers.TreeSpec where - -import Test.Hspec - -import Data.GenValidity.Tree () -import Data.Tree (Tree) -import Test.Validity - -spec :: Spec -spec = do - genValidSpec @(Tree Int) - genValiditySpec @(Tree Rational)