diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,11 @@ # Changelog +## [1.1.1.0] - 2024-07-18 + +### Added + +* `GenValid` instances for various newtypes in base + ## [1.1.0.0] - 2022-08-30 ### Added diff --git a/genvalidity.cabal b/genvalidity.cabal --- a/genvalidity.cabal +++ b/genvalidity.cabal @@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.7. +-- This file has been generated from package.yaml by hpack version 0.36.0. -- -- see: https://github.com/sol/hpack name: genvalidity -version: 1.1.0.0 +version: 1.1.1.0 synopsis: Testing utilities for the validity library description: Note: There are companion instance packages for this library: . @@ -58,7 +58,7 @@ QuickCheck >=2.13 , base >=4.13 && <5 , random >=1.1 - , validity >=0.12 + , validity >=0.12.1 default-language: Haskell2010 test-suite genvalidity-test diff --git a/src/Data/GenValidity.hs b/src/Data/GenValidity.hs --- a/src/Data/GenValidity.hs +++ b/src/Data/GenValidity.hs @@ -1,7 +1,10 @@ {-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -fno-warn-redundant-constraints #-} @@ -84,10 +87,15 @@ import Control.Monad (guard) import Data.Char (chr) import Data.Fixed (Fixed (..), HasResolution) +import Data.Functor.Const (Const (Const)) +import Data.Functor.Identity (Identity (Identity)) import Data.GenValidity.Utils import Data.Int (Int16, Int32, Int64, Int8) import Data.List.NonEmpty (NonEmpty) +import Data.Monoid (Alt, Dual) +import qualified Data.Monoid as Monoid import Data.Ratio ((%)) +import qualified Data.Semigroup as Semigroup import Data.Validity import Data.Word (Word16, Word32, Word64, Word8) import GHC.Generics @@ -123,7 +131,7 @@ -- > instance Arbitrary A where -- > arbitrary = genValid -- > shrink = shrinkValid -class Validity a => GenValid a where +class (Validity a) => GenValid a where -- | Generate a valid datum, this should cover all possible valid values in -- the type -- @@ -208,15 +216,15 @@ | (a', (b', (c', (d', e')))) <- shrinkValid (a, (b, (c, (d, e)))) ] -instance GenValid a => GenValid (Maybe a) where +instance (GenValid a) => GenValid (Maybe a) where genValid = genMaybe genValid shrinkValid = shrinkMaybe shrinkValid -instance GenValid a => GenValid (NonEmpty a) where +instance (GenValid a) => GenValid (NonEmpty a) where genValid = genNonEmptyOf genValid shrinkValid = shrinkNonEmpty shrinkValid -instance GenValid a => GenValid [a] where +instance (GenValid a) => GenValid [a] where genValid = genListOf genValid shrinkValid = shrinkList shrinkValid @@ -328,7 +336,7 @@ guard $ isValid candidate pure $ n' % d' -instance HasResolution a => GenValid (Fixed a) where +instance (HasResolution a) => GenValid (Fixed a) where genValid = MkFixed <$> genValid shrinkValid (MkFixed i) = MkFixed <$> shrinkValid i @@ -371,6 +379,22 @@ instance (GenValid a) => GGenValid (K1 i a) where gGenValid = K1 <$> genValid +deriving newtype instance (GenValid a) => GenValid (Identity a) + +deriving newtype instance (GenValid (f a)) => GenValid (Alt f a) + +deriving newtype instance (GenValid a) => GenValid (Dual a) + +deriving newtype instance (GenValid a) => GenValid (Semigroup.First a) + +deriving newtype instance (GenValid a) => GenValid (Semigroup.Last a) + +deriving newtype instance (GenValid a) => GenValid (Monoid.First a) + +deriving newtype instance (GenValid a) => GenValid (Monoid.Last a) + +deriving newtype instance (GenValid a) => GenValid (Const a b) + -- | Shrink a term to any of its immediate valid subterms, -- and also recursively shrink all subterms, and then filtering out the results that are not valid. -- @@ -408,10 +432,10 @@ gValidRecursivelyShrink (L1 x) = map L1 (gValidRecursivelyShrink x) gValidRecursivelyShrink (R1 x) = map R1 (gValidRecursivelyShrink x) -instance GValidRecursivelyShrink f => GValidRecursivelyShrink (M1 i c f) where +instance (GValidRecursivelyShrink f) => GValidRecursivelyShrink (M1 i c f) where gValidRecursivelyShrink (M1 x) = map M1 (gValidRecursivelyShrink x) -instance GenValid a => GValidRecursivelyShrink (K1 i a) where +instance (GenValid a) => GValidRecursivelyShrink (K1 i a) where gValidRecursivelyShrink (K1 x) = map K1 (shrinkValid x) instance GValidRecursivelyShrink U1 where @@ -441,7 +465,7 @@ gValidSubterms (L1 x) = gValidSubtermsIncl x gValidSubterms (R1 x) = gValidSubtermsIncl x -instance GValidSubterms f a => GValidSubterms (M1 i c f) a where +instance (GValidSubterms f a) => GValidSubterms (M1 i c f) a where gValidSubterms (M1 x) = gValidSubterms x instance GValidSubterms (K1 i a) b where @@ -463,7 +487,7 @@ gValidSubtermsIncl (L1 x) = gValidSubtermsIncl x gValidSubtermsIncl (R1 x) = gValidSubtermsIncl x -instance GValidSubtermsIncl f a => GValidSubtermsIncl (M1 i c f) a where +instance (GValidSubtermsIncl f a) => GValidSubtermsIncl (M1 i c f) a where gValidSubtermsIncl (M1 x) = gValidSubtermsIncl x -- This is the important case: We've found a term of the same type. diff --git a/test/Data/GenValidity/GenericSpec.hs b/test/Data/GenValidity/GenericSpec.hs --- a/test/Data/GenValidity/GenericSpec.hs +++ b/test/Data/GenValidity/GenericSpec.hs @@ -82,14 +82,16 @@ ( unwords ["never shrinks to itself for valid", "\"" ++ nameOf proxy ++ "\"s"] ) - $ forAll (genValid :: Gen a) $ \a -> + $ forAll (genValid :: Gen a) + $ \a -> forM_ (shrinkValidStructurally a) $ \subA -> when (subA == a) $ - expectationFailure $ unlines [show a, "was shrunk to itself."] + expectationFailure $ + unlines [show a, "was shrunk to itself."] nameOf :: forall a. - Typeable a => + (Typeable a) => Proxy a -> String nameOf = show . typeRep diff --git a/test/Data/GenValiditySpec.hs b/test/Data/GenValiditySpec.hs --- a/test/Data/GenValiditySpec.hs +++ b/test/Data/GenValiditySpec.hs @@ -23,7 +23,8 @@ forAll genSingleLineString (`shouldSatisfy` isSingleLine) describe "upTo" $ do it "returns only positive integers" $ - forAll arbitrary $ \n -> forAll (upTo n) (`shouldSatisfy` (>= 0)) + forAll arbitrary $ + \n -> forAll (upTo n) (`shouldSatisfy` (>= 0)) it "returns only integers smaller than or equal to the given number" $ forAll arbitrary $ \n -> forAll (upTo n) (`shouldSatisfy` (<= (max n 0))) diff --git a/test/Data/InstanceSpec.hs b/test/Data/InstanceSpec.hs --- a/test/Data/InstanceSpec.hs +++ b/test/Data/InstanceSpec.hs @@ -54,7 +54,8 @@ tupleTest (Proxy :: Proxy Double) genValidTest (Proxy :: Proxy (Ratio Int)) modifyMaxSuccess (`quot` 2) $ - modifyMaxSize (`quot` 2) $ genValidTest (Proxy :: Proxy (Either Bool Ordering)) + modifyMaxSize (`quot` 2) $ + genValidTest (Proxy :: Proxy (Either Bool Ordering)) genValidTest (Proxy :: Proxy (Maybe Ordering)) genValidTest (Proxy :: Proxy (Maybe (Maybe (Ordering)))) genValidTest (Proxy :: Proxy (Ratio Integer)) @@ -118,26 +119,28 @@ Left err -> expectationFailure $ unlines ["'validate' reported this value to be invalid:", show v, err, ""] - modifyMaxSuccess (`quot` 5) $ - it + modifyMaxSuccess (`quot` 5) + $ it ( unwords ["shrinkValid of", nameOf proxy, "only produces values that do not crash while validating"] ) - $ forAll genValid $ \a -> - forM_ (shrinkValid a) $ \v -> - case prettyValidate (v :: a) of - Right v_ -> seq v_ $ pure () :: IO () - Left err -> seq err $ pure () + $ forAll genValid + $ \a -> + forM_ (shrinkValid a) $ \v -> + case prettyValidate (v :: a) of + Right v_ -> seq v_ $ pure () :: IO () + Left err -> seq err $ pure () modifyMaxSuccess (`quot` 5) $ it (unwords ["shrinkValid of", nameOf proxy, "does not shrink to itself"]) $ forAll genValid $ \a -> forM_ (shrinkValid a) $ \a' -> unless (a /= a') $ - expectationFailure $ unlines ["The value", show (a :: a), "was shrunk to itself"] + expectationFailure $ + unlines ["The value", show (a :: a), "was shrunk to itself"] nameOf :: forall a. - Typeable a => + (Typeable a) => Proxy a -> String nameOf = show . typeRep