From 91f57c34e8d28dde121b3b959e714d073e4832c3 Mon Sep 17 00:00:00 2001 From: solomon Date: Mon, 14 Feb 2022 11:12:27 -0800 Subject: [PATCH 1/5] Updates `traversable` to test the correct laws --- src/Test/QuickCheck/Classes.hs | 34 ++++++++++++++++++++-------------- 1 file changed, 20 insertions(+), 14 deletions(-) diff --git a/src/Test/QuickCheck/Classes.hs b/src/Test/QuickCheck/Classes.hs index bed9131..b386665 100644 --- a/src/Test/QuickCheck/Classes.hs +++ b/src/Test/QuickCheck/Classes.hs @@ -1,5 +1,5 @@ {-# LANGUAGE ScopedTypeVariables, FlexibleContexts, KindSignatures - , Rank2Types, TypeOperators, CPP + , TypeApplications, Rank2Types, TypeOperators, CPP #-} ---------------------------------------------------------------------- @@ -33,10 +33,11 @@ import Data.Functor.Apply (Apply ((<.>))) import Data.Functor.Alt (Alt (())) import Data.Functor.Bind (Bind ((>>-)), apDefault) import qualified Data.Functor.Bind as B (Bind (join)) +import Data.Functor.Compose (Compose (..)) +import Data.Functor.Identity (Identity (..)) import Data.List.NonEmpty (NonEmpty(..)) import Data.Semigroup (Semigroup (..)) import Data.Monoid (Endo(..), Dual(..), Sum(..), Product(..)) -import Data.Traversable (fmapDefault, foldMapDefault) import Control.Applicative (Alternative(..)) import Control.Monad (MonadPlus (..), ap, join) import Control.Arrow (Arrow,ArrowChoice,first,second,left,right,(>>>),arr) @@ -717,23 +718,28 @@ arrowChoice = const ("arrow choice laws" rightMovesP f g = (left f >>> right (arr g)) =-= ((right (arr g)) >>> left f) -traversable :: forall f a b m. - ( Traversable f, Monoid m, Show (f a) - , Arbitrary (f a), Arbitrary b, Arbitrary m - , CoArbitrary a - , EqProp (f b), EqProp m) => - f (a, b, m) -> TestBatch +traversable :: forall t a b c f. + ( Traversable t, Applicative f + , Arbitrary (t a), Arbitrary (t b), Arbitrary (f b), Arbitrary (f c) + , CoArbitrary a, CoArbitrary b + , Show (t a), Show (t b) + , EqProp (t b), EqProp (f (f (t c)))) => + t (f a, b, c) -> TestBatch traversable = const ( "traversable" - , [ ("fmap", property fmapP) - , ("foldMap", property foldMapP) + , [ ("identity", property identityP) + , ("composition", property compositionP) + -- , ("naturality", property $ \(f :: f Int -> g Int) -> naturalityP f) ] ) where - fmapP :: (a -> b) -> f a -> Property - foldMapP :: (a -> m) -> f a -> Property + identityP :: Property + identityP = traverse @t @_ @b Identity =-= Identity + + compositionP :: (a -> f b) -> (b -> f c) -> Property + compositionP f g = traverse @t (Compose . fmap g . f) =-= Compose . fmap (traverse g) . traverse f - fmapP f x = f `fmap` x =-= f `fmapDefault` x - foldMapP f x = f `foldMap` x =-= f `foldMapDefault` x + --naturalityP :: (forall x. (f x -> g x)) -> (a -> f b) -> Property + --naturalityP t f = t . traverse @t f =-= traverse (t . f) -- | Note that 'foldable' doesn't check the strictness of 'foldl'', `foldr'' and `foldMap''. -- From 9fc0065a56583d9700d50bed8c52d98bd93f89c7 Mon Sep 17 00:00:00 2001 From: solomon Date: Mon, 14 Feb 2022 13:25:19 -0800 Subject: [PATCH 2/5] Removes TypeApplications for backwards compatability --- src/Test/QuickCheck/Classes.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Test/QuickCheck/Classes.hs b/src/Test/QuickCheck/Classes.hs index b386665..c15a7bd 100644 --- a/src/Test/QuickCheck/Classes.hs +++ b/src/Test/QuickCheck/Classes.hs @@ -1,5 +1,5 @@ {-# LANGUAGE ScopedTypeVariables, FlexibleContexts, KindSignatures - , TypeApplications, Rank2Types, TypeOperators, CPP + , Rank2Types, TypeOperators, CPP #-} ---------------------------------------------------------------------- @@ -733,10 +733,10 @@ traversable = const ( "traversable" ) where identityP :: Property - identityP = traverse @t @_ @b Identity =-= Identity + identityP = (traverse :: (b -> Identity b) -> t b -> Identity (t b)) Identity =-= Identity compositionP :: (a -> f b) -> (b -> f c) -> Property - compositionP f g = traverse @t (Compose . fmap g . f) =-= Compose . fmap (traverse g) . traverse f + compositionP f g = (traverse :: (a -> Compose f f c) -> t a -> Compose f f (t c)) (Compose . fmap g . f) =-= Compose . fmap (traverse g) . traverse f --naturalityP :: (forall x. (f x -> g x)) -> (a -> f b) -> Property --naturalityP t f = t . traverse @t f =-= traverse (t . f) From 98cb1bc9a9352a292c5f2c6d7355c9c9478a4617 Mon Sep 17 00:00:00 2001 From: solomon Date: Wed, 16 Feb 2022 15:27:03 -0800 Subject: [PATCH 3/5] Adds TypeApplication and reverts fmap and foldMap traversable laws --- src/Test/QuickCheck/Classes.hs | 27 +++++++++++++++++++-------- 1 file changed, 19 insertions(+), 8 deletions(-) diff --git a/src/Test/QuickCheck/Classes.hs b/src/Test/QuickCheck/Classes.hs index c15a7bd..4db1b1c 100644 --- a/src/Test/QuickCheck/Classes.hs +++ b/src/Test/QuickCheck/Classes.hs @@ -1,5 +1,5 @@ {-# LANGUAGE ScopedTypeVariables, FlexibleContexts, KindSignatures - , Rank2Types, TypeOperators, CPP + , Rank2Types, TypeApplications, TypeOperators, CPP #-} ---------------------------------------------------------------------- @@ -46,6 +46,7 @@ import Text.Show.Functions () import Test.QuickCheck.Checkers import Test.QuickCheck.Instances.Char () +import Data.Traversable -- | Total ordering. @@ -718,29 +719,39 @@ arrowChoice = const ("arrow choice laws" rightMovesP f g = (left f >>> right (arr g)) =-= ((right (arr g)) >>> left f) -traversable :: forall t a b c f. - ( Traversable t, Applicative f +traversable :: forall t a b c m f. + ( Traversable t, Applicative f, Monoid m , Arbitrary (t a), Arbitrary (t b), Arbitrary (f b), Arbitrary (f c) + , Arbitrary m, Arbitrary b , CoArbitrary a, CoArbitrary b , Show (t a), Show (t b) - , EqProp (t b), EqProp (f (f (t c)))) => - t (f a, b, c) -> TestBatch -traversable = const ( "traversable" + , EqProp (t b), EqProp (f (f (t c))), EqProp m) => + t (f a, b, c, m) -> TestBatch +traversable = const ( "Traversable" , [ ("identity", property identityP) , ("composition", property compositionP) -- , ("naturality", property $ \(f :: f Int -> g Int) -> naturalityP f) + , ("fmap", property fmapP) + , ("foldMap", property foldMapP) ] ) where identityP :: Property - identityP = (traverse :: (b -> Identity b) -> t b -> Identity (t b)) Identity =-= Identity + identityP = traverse @t @_ @b Identity =-= Identity compositionP :: (a -> f b) -> (b -> f c) -> Property - compositionP f g = (traverse :: (a -> Compose f f c) -> t a -> Compose f f (t c)) (Compose . fmap g . f) =-= Compose . fmap (traverse g) . traverse f + compositionP f g = traverse @t (Compose . fmap g . f) =-= Compose . fmap (traverse g) . traverse f + --FIXME: Does not compile due to rank2 type. --naturalityP :: (forall x. (f x -> g x)) -> (a -> f b) -> Property --naturalityP t f = t . traverse @t f =-= traverse (t . f) + fmapP :: (a -> b) -> t a -> Property + fmapP f x = f `fmap` x =-= f `fmapDefault` x + + foldMapP :: (a -> m) -> t a -> Property + foldMapP f x = f `foldMap` x =-= (f `foldMapDefault` x :: m) + -- | Note that 'foldable' doesn't check the strictness of 'foldl'', `foldr'' and `foldMap''. -- -- @since 0.4.13 From dedd995e408caf4a7e1d0635f14e312dc1d550b1 Mon Sep 17 00:00:00 2001 From: solomon Date: Wed, 16 Feb 2022 15:47:24 -0800 Subject: [PATCH 4/5] Adds traversable sequenceA laws --- src/Test/QuickCheck/Classes.hs | 30 ++++++++++++++++++++++-------- 1 file changed, 22 insertions(+), 8 deletions(-) diff --git a/src/Test/QuickCheck/Classes.hs b/src/Test/QuickCheck/Classes.hs index 4db1b1c..781f1b5 100644 --- a/src/Test/QuickCheck/Classes.hs +++ b/src/Test/QuickCheck/Classes.hs @@ -38,6 +38,7 @@ import Data.Functor.Identity (Identity (..)) import Data.List.NonEmpty (NonEmpty(..)) import Data.Semigroup (Semigroup (..)) import Data.Monoid (Endo(..), Dual(..), Sum(..), Product(..)) +import Data.Traversable import Control.Applicative (Alternative(..)) import Control.Monad (MonadPlus (..), ap, join) import Control.Arrow (Arrow,ArrowChoice,first,second,left,right,(>>>),arr) @@ -46,7 +47,6 @@ import Text.Show.Functions () import Test.QuickCheck.Checkers import Test.QuickCheck.Instances.Char () -import Data.Traversable -- | Total ordering. @@ -719,27 +719,31 @@ arrowChoice = const ("arrow choice laws" rightMovesP f g = (left f >>> right (arr g)) =-= ((right (arr g)) >>> left f) -traversable :: forall t a b c m f. - ( Traversable t, Applicative f, Monoid m - , Arbitrary (t a), Arbitrary (t b), Arbitrary (f b), Arbitrary (f c) +traversable :: forall t a b c m f g. + ( Traversable t, Applicative f, Applicative g, Monoid m + , Arbitrary (t a), Arbitrary (t b), Arbitrary (f b), Arbitrary (g c) + , Arbitrary (t (f (g a))) , Arbitrary m, Arbitrary b , CoArbitrary a, CoArbitrary b - , Show (t a), Show (t b) - , EqProp (t b), EqProp (f (f (t c))), EqProp m) => - t (f a, b, c, m) -> TestBatch + , Show (t a), Show (t b), Show (t (f (g a))) + , EqProp (t b), EqProp m, EqProp (f (g (t a))), EqProp (f (g (t c)))) => t (f a, g b, c, m) + -> TestBatch traversable = const ( "Traversable" , [ ("identity", property identityP) , ("composition", property compositionP) -- , ("naturality", property $ \(f :: f Int -> g Int) -> naturalityP f) , ("fmap", property fmapP) , ("foldMap", property foldMapP) + , ("sequenceA identity", property sequenceIdentityP) + , ("sequenceA composition", property sequenceCompositionP) + -- , ("sequenceA naturality", property $ \(f :: f a -> g a) -> sequenceNaturalityP f) ] ) where identityP :: Property identityP = traverse @t @_ @b Identity =-= Identity - compositionP :: (a -> f b) -> (b -> f c) -> Property + compositionP :: (a -> f b) -> (b -> g c) -> Property compositionP f g = traverse @t (Compose . fmap g . f) =-= Compose . fmap (traverse g) . traverse f --FIXME: Does not compile due to rank2 type. @@ -752,6 +756,16 @@ traversable = const ( "Traversable" foldMapP :: (a -> m) -> t a -> Property foldMapP f x = f `foldMap` x =-= (f `foldMapDefault` x :: m) + sequenceIdentityP :: Property + sequenceIdentityP = sequenceA @t @_ @b . fmap Identity =-= Identity + + sequenceCompositionP :: Property + sequenceCompositionP = sequenceA @t @(Compose f g) @a . fmap Compose =-= Compose . fmap sequenceA . sequenceA + + --FIXME: Does not compile due to rank2 type. + --sequenceNaturalityP :: (forall x. (f x -> g x)) -> Property + --sequenceNaturalityP t = t . sequenceA @t @_ @a =-= sequenceA . fmap t + -- | Note that 'foldable' doesn't check the strictness of 'foldl'', `foldr'' and `foldMap''. -- -- @since 0.4.13 From b0ead27e4e515a0c54d8e2d07feebbc3ee92c816 Mon Sep 17 00:00:00 2001 From: solomon Date: Wed, 16 Feb 2022 16:12:49 -0800 Subject: [PATCH 5/5] Explicit Traversable import --- src/Test/QuickCheck/Classes.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Test/QuickCheck/Classes.hs b/src/Test/QuickCheck/Classes.hs index 781f1b5..f756d0e 100644 --- a/src/Test/QuickCheck/Classes.hs +++ b/src/Test/QuickCheck/Classes.hs @@ -38,7 +38,7 @@ import Data.Functor.Identity (Identity (..)) import Data.List.NonEmpty (NonEmpty(..)) import Data.Semigroup (Semigroup (..)) import Data.Monoid (Endo(..), Dual(..), Sum(..), Product(..)) -import Data.Traversable +import Data.Traversable (fmapDefault, foldMapDefault) import Control.Applicative (Alternative(..)) import Control.Monad (MonadPlus (..), ap, join) import Control.Arrow (Arrow,ArrowChoice,first,second,left,right,(>>>),arr)