diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple + main = defaultMain diff --git a/genvalidity.cabal b/genvalidity.cabal --- a/genvalidity.cabal +++ b/genvalidity.cabal @@ -1,58 +1,51 @@ -name: genvalidity -version: 0.3.0.0 -synopsis: Testing utilities for the validity library +name: genvalidity +version: 0.3.1.0 +cabal-version: >=1.10 +build-type: Simple +license: MIT +license-file: LICENSE +copyright: Copyright: (c) 2016 Tom Sydney Kerckhove +maintainer: syd.kerckhove@gmail.com +homepage: https://github.com/NorfairKing/validity#readme +synopsis: Testing utilities for the validity library description: - Note: There are companion instance packages for this library: - . - * - . - * - . - * + Note: There are companion instance packages for this library: + . + * + . + * + . + * + . + * +category: Testing +author: Tom Sydney Kerckhove -homepage: https://github.com/NorfairKing/validity#readme -license: MIT -license-file: LICENSE -author: Tom Sydney Kerckhove -maintainer: syd.kerckhove@gmail.com -copyright: Copyright: (c) 2016 Tom Sydney Kerckhove -category: Testing -build-type: Simple --- extra-source-files: -cabal-version: >=1.10 +source-repository head + type: git + location: https://github.com/NorfairKing/validity library - hs-source-dirs: src - exposed-modules: Data.GenValidity - , Data.GenRelativeValidity - build-depends: base < 5 - , validity >= 0.3 && < 0.4 - , QuickCheck >= 2.8 && < 2.10 - default-language: Haskell2010 + exposed-modules: + Data.GenValidity + Data.GenRelativeValidity + build-depends: + base <5, + validity >=0.3 && <0.4, + QuickCheck >=2.8 && <2.10 + default-language: Haskell2010 + hs-source-dirs: src test-suite genvalidity-test - type: - exitcode-stdio-1.0 - default-language: - Haskell2010 - hs-source-dirs: - test - main-is: - Spec.hs - other-modules: - Data.GenValiditySpec - ghc-options: - -threaded -rtsopts -with-rtsopts=-N - -Wall - -fno-warn-name-shadowing - build-depends: - base - - , hspec - , QuickCheck >= 2.8 && < 2.9 - - , genvalidity - -source-repository head - type: git - location: https://github.com/NorfairKing/validity + type: exitcode-stdio-1.0 + main-is: Spec.hs + build-depends: + base -any, + hspec -any, + QuickCheck, + genvalidity -any + default-language: Haskell2010 + hs-source-dirs: test + other-modules: + Data.GenValiditySpec + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -fno-warn-name-shadowing diff --git a/src/Data/GenValidity.hs b/src/Data/GenValidity.hs --- a/src/Data/GenValidity.hs +++ b/src/Data/GenValidity.hs @@ -42,6 +42,12 @@ > Nothing -> return () -- Can happen > Just output -> output `shouldSatisfy` isValid -} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DefaultSignatures #-} +{-# OPTIONS_GHC -Wno-redundant-constraints #-} + module Data.GenValidity ( module Data.Validity , module Data.GenValidity @@ -49,13 +55,20 @@ import Data.Validity -import Test.QuickCheck +import Data.Fixed (Fixed(..), HasResolution) +import GHC.Generics +import GHC.Real (Ratio(..)) +import Test.QuickCheck hiding (Fixed) + import Control.Monad (forM) -- | A class of types for which truly arbitrary values can be generated. class GenUnchecked a where genUnchecked :: Gen a + default genUnchecked :: (Generic a, GGenUnchecked (Rep a)) => + Gen a + genUnchecked = to <$> gGenUnchecked -- | A class of types for which valid values can be generated. -- @@ -130,7 +143,6 @@ GenValid (Either a b) where genValid = oneof [Left <$> genValid, Right <$> genValid] - -- | This instance ensures that the generated tupse contains at least one invalid element. The other element is unchecked. instance (GenInvalid a, GenInvalid b) => GenInvalid (Either a b) where @@ -265,6 +277,21 @@ instance GenValid Integer +instance GenUnchecked (Ratio Integer) where + genUnchecked = do + n <- genUnchecked + d <- genUnchecked + pure $ n :% d + +instance GenValid (Ratio Integer) + +instance HasResolution a => + GenUnchecked (Fixed a) where + genUnchecked = MkFixed <$> genUnchecked + +instance HasResolution a => + GenValid (Fixed a) + -- | 'upTo' generates an integer between 0 (inclusive) and 'n'. upTo :: Int -> Gen Int upTo n @@ -302,3 +329,28 @@ size <- upTo n pars <- arbPartition size forM pars $ \i -> resize i func + +class GGenUnchecked f where + gGenUnchecked :: Gen (f a) + +instance GGenUnchecked U1 where + gGenUnchecked = pure U1 + +instance (GGenUnchecked a, GGenUnchecked b) => + GGenUnchecked (a :*: b) where + gGenUnchecked = do + g1 <- gGenUnchecked + g2 <- gGenUnchecked + pure $ g1 :*: g2 + +instance (GGenUnchecked a, GGenUnchecked b) => + GGenUnchecked (a :+: b) where + gGenUnchecked = oneof [L1 <$> gGenUnchecked, R1 <$> gGenUnchecked] + +instance (GGenUnchecked a) => + GGenUnchecked (M1 i c a) where + gGenUnchecked = M1 <$> gGenUnchecked + +instance (GenUnchecked a) => + GGenUnchecked (K1 i a) where + gGenUnchecked = K1 <$> genUnchecked diff --git a/test/Data/GenValiditySpec.hs b/test/Data/GenValiditySpec.hs --- a/test/Data/GenValiditySpec.hs +++ b/test/Data/GenValiditySpec.hs @@ -1,43 +1,34 @@ -module Data.GenValiditySpec (spec) where +module Data.GenValiditySpec + ( spec + ) where -import Test.Hspec -import Test.QuickCheck +import Test.Hspec +import Test.QuickCheck -import Data.GenValidity +import Data.GenValidity spec :: Spec spec = do describe "upTo" $ do it "returns only positive integers" $ do - forAll arbitrary $ \n -> - forAll (upTo n) (`shouldSatisfy` (>= 0)) - + forAll arbitrary $ \n -> forAll (upTo n) (`shouldSatisfy` (>= 0)) describe "genSplit" $ do it "returns positive integers" $ do forAll arbitrary $ \i -> forAll (genSplit i) $ \(a, b) -> do a `shouldSatisfy` (>= 0) b `shouldSatisfy` (>= 0) - it "returns two integers such that the sum is the original integer" $ do forAll (arbitrary `suchThat` (>= 0)) $ \i -> - forAll (genSplit i) $ \(a, b) -> - a + b `shouldBe` i - + forAll (genSplit i) $ \(a, b) -> a + b `shouldBe` i describe "arbPartition" $ do it "returns an empty list upon strictly negative input" $ do forAll (arbitrary `suchThat` (< 0)) $ \n -> forAll (arbPartition n) (`shouldBe` []) - it "returns a list of strictly positive integers" $ do forAll arbitrary $ \n -> - forAll (arbPartition n) $ \p -> - p `shouldSatisfy` all (> 0) - - it "returns a list of integers that sum to the original positive integer" $ do + forAll (arbPartition n) $ \p -> p `shouldSatisfy` all (> 0) + it + "returns a list of integers that sum to the original positive integer" $ do forAll (arbitrary `suchThat` (>= 0)) $ \n -> - forAll (arbPartition n) $ \p -> - sum p `shouldBe` n - - - + forAll (arbPartition n) $ \p -> sum p `shouldBe` n