From 0cafed39657cb9e18331d9ce4ecc732015b41ce8 Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Wed, 11 May 2022 08:23:35 +1200 Subject: [PATCH 1/6] Initial tests --- cabal.project | 2 ++ mtl.cabal | 29 ++++++++++++++++++++--------- test/properties/Accum.hs | 19 +++++++++++++++++++ test/properties/Main.hs | 4 ++++ 4 files changed, 45 insertions(+), 9 deletions(-) create mode 100644 test/properties/Accum.hs create mode 100644 test/properties/Main.hs diff --git a/cabal.project b/cabal.project index f243510..f419e1b 100644 --- a/cabal.project +++ b/cabal.project @@ -1,4 +1,6 @@ packages: ./mtl.cabal +test-show-details: direct + package mtl ghc-options: -Werror diff --git a/mtl.cabal b/mtl.cabal index e7a1629..e9c11ce 100644 --- a/mtl.cabal +++ b/mtl.cabal @@ -28,7 +28,16 @@ source-repository head type: git location: https://github.com/haskell/mtl.git +common common-lang + build-depends: base >= 4.12 && < 5 + ghc-options: + -Wall -Wcompat -Wincomplete-record-updates + -Wincomplete-uni-patterns -Wredundant-constraints + -Wmissing-export-lists + default-language: Haskell2010 + Library + import: common-lang exposed-modules: Control.Monad.Cont Control.Monad.Cont.Class @@ -55,14 +64,16 @@ Library Control.Monad.Accum Control.Monad.Select - build-depends: - , base >=4.12 && < 5 - , transformers >= 0.5.6 && <0.7 + build-depends: transformers >= 0.5.6 && <0.7 - ghc-options: - -Wall -Wcompat -Wincomplete-record-updates - -Wincomplete-uni-patterns -Wredundant-constraints - -Wmissing-export-lists - - default-language: Haskell2010 +test-suite properties + import: common-lang + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: Accum + build-depends: + , mtl + , QuickCheck ^>= 2.14.0 + hs-source-dirs: test/properties + ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N diff --git a/test/properties/Accum.hs b/test/properties/Accum.hs new file mode 100644 index 0000000..eb0c8c8 --- /dev/null +++ b/test/properties/Accum.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE RankNTypes #-} + +module Accum ( + accumConstLaw, + accumThenLaw + ) where + +import Data.Kind (Type) +import Test.QuickCheck (Property) + +accumConstLaw :: forall (m :: Type -> Type) . + (forall (a :: Type) . m a -> a) -> Property +accumConstLaw lower = _ + +accumThenLaw :: forall (m :: Type -> Type) . + (forall (a :: Type) . m a -> a) -> Property +accumThenLaw lower = _ diff --git a/test/properties/Main.hs b/test/properties/Main.hs new file mode 100644 index 0000000..5505574 --- /dev/null +++ b/test/properties/Main.hs @@ -0,0 +1,4 @@ +module Main (main) where + +main :: IO () +main = _ From 482298344ace0a0b3d0ff24d3e37e8a7b4806634 Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Wed, 11 May 2022 19:03:45 +1200 Subject: [PATCH 2/6] More Accum tests --- test/properties/Main.hs | 47 ++++++++++++++++++++++++++++++----------- 1 file changed, 35 insertions(+), 12 deletions(-) diff --git a/test/properties/Main.hs b/test/properties/Main.hs index 2e9e9b6..3b7d575 100644 --- a/test/properties/Main.hs +++ b/test/properties/Main.hs @@ -3,6 +3,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -11,8 +12,9 @@ module Main (main) where import Control.Monad.Accum (MonadAccum (add, look)) import Control.Monad.Trans.Accum (AccumT, runAccum) +import Control.Monad.Trans.Maybe (MaybeT, runMaybeT) import Data.Functor (($>)) -import Data.Functor.Identity (Identity) +import Data.Functor.Identity (Identity (Identity)) import Data.Kind (Type) import GHC.IO.Encoding (setLocaleEncoding, utf8) import Test.QuickCheck @@ -35,7 +37,8 @@ main = do defaultMain . adjustOption go . testGroup "Laws" $ [ testGroup "Accum" - [ accumLaws lowerBaseline + [ accumLaws lowerBaseline, + accumLaws lowerMaybe ] ] where @@ -45,9 +48,13 @@ main = do -- Law generators accumLaws :: - forall (m :: Type -> Type). - (MonadAccum M m, Typeable m) => - (forall (a :: Type). m a -> M -> (a, M)) -> + forall (m :: Type -> Type) (f :: Type -> Type -> Type). + ( MonadAccum M m, + Typeable m, + forall b. Eq b => Eq (f M b), + forall b. Show b => Show (f M b) + ) => + (forall (a :: Type). m a -> M -> f M a) -> TestTree accumLaws lower = testProperties @@ -81,8 +88,31 @@ accumLaws lower = rhs = look >>= \w' -> add x $> w' <> x in lower lhs w === lower rhs w +-- Lowerings + +lowerBaseline :: + forall (w :: Type) (a :: Type). + AccumT w Identity a -> + w -> + Result Identity w a +lowerBaseline comp acc = case runAccum comp acc of + (x, acc') -> Result (Identity x, acc') + +lowerMaybe :: + forall (w :: Type) (a :: Type). + MaybeT (AccumT w Identity) a -> + w -> + Result Maybe w a +lowerMaybe comp acc = case runAccum (runMaybeT comp) acc of + (x, acc') -> Result (x, acc') + -- Helpers +newtype Result (f :: Type -> Type) (w :: Type) (a :: Type) + = Result (f a, w) + deriving (Eq) via (f a, w) + deriving stock (Show) + -- A type that's a 'non-specific monoid', similar to how 'A' and 'B' work in -- QuickCheck. -- @@ -96,13 +126,6 @@ instance Arbitrary M where x <- sized $ \size -> chooseInt (0, abs size) pure . M . pure $ x -lowerBaseline :: - forall (a :: Type) (w :: Type). - AccumT w Identity a -> - w -> - (a, w) -lowerBaseline = runAccum - typeName :: forall (a :: Type). (Typeable a) => String typeName = tyConName . typeRepTyCon $ typeRep @a From d324fa9c3f9f371cdd9bec7f2ef65a28e67134ba Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Sat, 21 May 2022 14:24:14 +1200 Subject: [PATCH 3/6] Tests for MonadAccum laws, update property description --- Control/Monad/Accum.hs | 2 +- test/properties/Main.hs | 301 ++++++++++++++++++++++++++++++++++------ 2 files changed, 261 insertions(+), 42 deletions(-) diff --git a/Control/Monad/Accum.hs b/Control/Monad/Accum.hs index 7be9140..5a019a2 100644 --- a/Control/Monad/Accum.hs +++ b/Control/Monad/Accum.hs @@ -140,7 +140,7 @@ import Data.Kind (Type) -- These are also the default definitions. -- -- 1. @'look'@ @=@ @'accum' '$' \acc -> (acc, mempty)@ --- 2. @'add' x@ @=@ @'accum' '$' \acc -> ('()', x)@ +-- 2. @'add' x@ @=@ @'accum' '$' \_ -> ('()', x)@ -- 3. @'accum' f@ @=@ @'look' >>= \acc -> let (res, v) = f acc in 'add' v '$>' res@ -- -- @since 2.3 diff --git a/test/properties/Main.hs b/test/properties/Main.hs index 3b7d575..43e1a82 100644 --- a/test/properties/Main.hs +++ b/test/properties/Main.hs @@ -3,29 +3,48 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE NumericUnderscores #-} -{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} module Main (main) where -import Control.Monad.Accum (MonadAccum (add, look)) -import Control.Monad.Trans.Accum (AccumT, runAccum) +import Control.Monad (guard) +import Control.Monad.Accum (MonadAccum (accum, add, look)) +import Control.Monad.Trans.Accum (Accum, AccumT, runAccum) +import Control.Monad.Trans.Except (ExceptT, runExceptT) +import Control.Monad.Trans.Identity (IdentityT, runIdentityT) import Control.Monad.Trans.Maybe (MaybeT, runMaybeT) +import qualified Control.Monad.Trans.RWS.CPS as RWSCPS +import qualified Control.Monad.Trans.RWS.Lazy as RWSLazy +import qualified Control.Monad.Trans.RWS.Strict as RWSStrict +import Control.Monad.Trans.Reader (ReaderT, runReaderT) +import qualified Control.Monad.Trans.State.Lazy as StateLazy +import qualified Control.Monad.Trans.State.Strict as StateStrict +import qualified Control.Monad.Trans.Writer.CPS as WriterCPS +import qualified Control.Monad.Trans.Writer.Lazy as WriterLazy +import qualified Control.Monad.Trans.Writer.Strict as WriterStrict import Data.Functor (($>)) -import Data.Functor.Identity (Identity (Identity)) +import Data.Functor.Identity (Identity) import Data.Kind (Type) import GHC.IO.Encoding (setLocaleEncoding, utf8) import Test.QuickCheck ( Arbitrary (arbitrary, shrink), + Blind (Blind), + CoArbitrary (coarbitrary), + Fun, + Function (function), Property, + applyFun, chooseInt, forAllShrinkShow, + functionMap, + property, + shrinkList, sized, - (===), ) -import Test.QuickCheck.Poly (A) +import Test.QuickCheck.Poly (A, B) import Test.Tasty (TestTree, adjustOption, defaultMain, testGroup) import Test.Tasty.QuickCheck (QuickCheckTests, testProperties) import Text.Show.Pretty (ppShow) @@ -37,8 +56,19 @@ main = do defaultMain . adjustOption go . testGroup "Laws" $ [ testGroup "Accum" - [ accumLaws lowerBaseline, - accumLaws lowerMaybe + [ accumLaws lowerBase, + accumLaws lowerMaybe, + accumLaws lowerExcept, + accumLaws lowerIdentity, + accumLaws lowerRWSLazy, + accumLaws lowerRWSStrict, + accumLaws lowerRWSCPS, + accumLaws lowerReader, + accumLaws lowerStateLazy, + accumLaws lowerStateStrict, + accumLaws lowerWriterLazy, + accumLaws lowerWriterStrict, + accumLaws lowerWriterCPS ] ] where @@ -48,70 +78,231 @@ main = do -- Law generators accumLaws :: - forall (m :: Type -> Type) (f :: Type -> Type -> Type). - ( MonadAccum M m, - Typeable m, - forall b. Eq b => Eq (f M b), - forall b. Show b => Show (f M b) - ) => - (forall (a :: Type). m a -> M -> f M a) -> + forall (m :: Type -> Type) (t :: Type). + (MonadAccum M m, Typeable m, Arbitrary t, Show t) => + (forall (a :: Type). (Eq a) => t -> m a -> m a -> Bool) -> TestTree -accumLaws lower = +accumLaws runAndCompare = testProperties testName [ ("look *> look = look", lookLookProp), ("add mempty = pure ()", addMemptyProp), ("add x *> add y = add (x <> y)", addAddProp), - ("add x *> look = look >>= \\w -> add x $> w <> x", addLookProp) + ("add x *> look = look >>= \\w -> add x $> w <> x", addLookProp), + ("accum (const (x, mempty)) = pure x", accumPureProp), + ("accum f *> accum g law (too long)", accumFGProp), + ("look = accum $ \\acc -> (acc, mempty)", lookAccumProp), + ("add x = accum $ \\acc -> ((), x)", addAccumProp), + ("accum f = look >>= \\acc -> let (res, v) = f acc in add v $> res", accumAddProp) ] where testName :: String testName = "MonadAccum laws for " <> typeName @(m A) + addAccumProp :: Property + addAccumProp = theNeedful $ \(w, x) -> + let lhs = add x + rhs = accum $ const ((), x) + in property . runAndCompare w lhs $ rhs + accumAddProp :: Property + accumAddProp = theNeedful $ \(w, Blind (f :: M -> (A, M))) -> + let lhs = accum f + rhs = look >>= \acc -> let (res, v) = f acc in add v $> res + in property . runAndCompare w lhs $ rhs lookLookProp :: Property lookLookProp = theNeedful $ \w -> let lhs = look *> look rhs = look - in lower lhs w === lower rhs w + in property . runAndCompare w lhs $ rhs addMemptyProp :: Property addMemptyProp = theNeedful $ \w -> let lhs = add mempty rhs = pure () - in lower lhs w === lower rhs w + in property . runAndCompare w lhs $ rhs addAddProp :: Property addAddProp = theNeedful $ \(w, x, y) -> let lhs = add x *> add y rhs = add (x <> y) - in lower lhs w === lower rhs w + in property . runAndCompare w lhs $ rhs addLookProp :: Property addLookProp = theNeedful $ \(w, x) -> let lhs = add x *> look rhs = look >>= \w' -> add x $> w' <> x - in lower lhs w === lower rhs w + in property . runAndCompare w lhs $ rhs + accumPureProp :: Property + accumPureProp = theNeedful $ \(w, x :: A) -> + let lhs = accum (const (x, mempty)) + rhs = pure x + in property . runAndCompare w lhs $ rhs + accumFGProp :: Property + accumFGProp = theNeedful $ \(w', Blind (f :: M -> (A, M)), Blind (g :: M -> (M, M))) -> + let lhs = accum f *> accum g + rhs = accum $ \acc -> + let (_, v) = f acc + (res, w) = g (acc <> v) + in (res, v <> w) + in property . runAndCompare w' lhs $ rhs + lookAccumProp :: Property + lookAccumProp = theNeedful $ \w -> + let lhs = look + rhs = accum (,mempty) + in property . runAndCompare w lhs $ rhs -- Lowerings -lowerBaseline :: - forall (w :: Type) (a :: Type). - AccumT w Identity a -> - w -> - Result Identity w a -lowerBaseline comp acc = case runAccum comp acc of - (x, acc') -> Result (Identity x, acc') +lowerBase :: + forall (a :: Type). + (Eq a) => + M -> + AccumT M Identity a -> + AccumT M Identity a -> + Bool +lowerBase w lhs rhs = runAccum lhs w == runAccum rhs w lowerMaybe :: - forall (w :: Type) (a :: Type). - MaybeT (AccumT w Identity) a -> - w -> - Result Maybe w a -lowerMaybe comp acc = case runAccum (runMaybeT comp) acc of - (x, acc') -> Result (x, acc') + forall (a :: Type). + (Eq a) => + M -> + MaybeT (Accum M) a -> + MaybeT (Accum M) a -> + Bool +lowerMaybe w lhs rhs = + let leftRun = runAccum (runMaybeT lhs) w + rightRun = runAccum (runMaybeT rhs) w + in leftRun == rightRun --- Helpers +lowerExcept :: + forall (a :: Type). + (Eq a) => + M -> + ExceptT A (Accum M) a -> + ExceptT A (Accum M) a -> + Bool +lowerExcept w lhs rhs = + let leftRun = runAccum (runExceptT lhs) w + rightRun = runAccum (runExceptT rhs) w + in leftRun == rightRun -newtype Result (f :: Type -> Type) (w :: Type) (a :: Type) - = Result (f a, w) - deriving (Eq) via (f a, w) - deriving stock (Show) +lowerIdentity :: + forall (a :: Type). + (Eq a) => + M -> + IdentityT (Accum M) a -> + IdentityT (Accum M) a -> + Bool +lowerIdentity w lhs rhs = + let leftRun = runAccum (runIdentityT lhs) w + rightRun = runAccum (runIdentityT rhs) w + in leftRun == rightRun + +lowerRWSLazy :: + forall (a :: Type). + (Eq a) => + (M, A, B) -> + RWSLazy.RWST A M B (Accum M) a -> + RWSLazy.RWST A M B (Accum M) a -> + Bool +lowerRWSLazy (w, r, s) lhs rhs = + let leftRun = runAccum (RWSLazy.runRWST lhs r s) w + rightRun = runAccum (RWSLazy.runRWST rhs r s) w + in leftRun == rightRun + +lowerRWSStrict :: + forall (a :: Type). + (Eq a) => + (M, A, B) -> + RWSStrict.RWST A M B (Accum M) a -> + RWSStrict.RWST A M B (Accum M) a -> + Bool +lowerRWSStrict (w, r, s) lhs rhs = + let leftRun = runAccum (RWSStrict.runRWST lhs r s) w + rightRun = runAccum (RWSStrict.runRWST rhs r s) w + in leftRun == rightRun + +lowerRWSCPS :: + forall (a :: Type). + (Eq a) => + (M, A, B) -> + RWSCPS.RWST A M B (Accum M) a -> + RWSCPS.RWST A M B (Accum M) a -> + Bool +lowerRWSCPS (w, r, s) lhs rhs = + let leftRun = runAccum (RWSCPS.runRWST lhs r s) w + rightRun = runAccum (RWSCPS.runRWST rhs r s) w + in leftRun == rightRun + +lowerReader :: + forall (a :: Type). + (Eq a) => + (M, A) -> + ReaderT A (Accum M) a -> + ReaderT A (Accum M) a -> + Bool +lowerReader (w, r) lhs rhs = + let leftRun = runAccum (runReaderT lhs r) w + rightRun = runAccum (runReaderT rhs r) w + in leftRun == rightRun + +lowerStateLazy :: + forall (a :: Type). + (Eq a) => + (M, A) -> + StateLazy.StateT A (Accum M) a -> + StateLazy.StateT A (Accum M) a -> + Bool +lowerStateLazy (w, s) lhs rhs = + let leftRun = runAccum (StateLazy.runStateT lhs s) w + rightRun = runAccum (StateLazy.runStateT rhs s) w + in leftRun == rightRun + +lowerStateStrict :: + forall (a :: Type). + (Eq a) => + (M, A) -> + StateStrict.StateT A (Accum M) a -> + StateStrict.StateT A (Accum M) a -> + Bool +lowerStateStrict (w, s) lhs rhs = + let leftRun = runAccum (StateStrict.runStateT lhs s) w + rightRun = runAccum (StateStrict.runStateT rhs s) w + in leftRun == rightRun + +lowerWriterLazy :: + forall (a :: Type). + (Eq a) => + M -> + WriterLazy.WriterT N (Accum M) a -> + WriterLazy.WriterT N (Accum M) a -> + Bool +lowerWriterLazy w lhs rhs = + let leftRun = runAccum (WriterLazy.runWriterT lhs) w + rightRun = runAccum (WriterLazy.runWriterT rhs) w + in leftRun == rightRun + +lowerWriterStrict :: + forall (a :: Type). + (Eq a) => + M -> + WriterStrict.WriterT N (Accum M) a -> + WriterStrict.WriterT N (Accum M) a -> + Bool +lowerWriterStrict w lhs rhs = + let leftRun = runAccum (WriterStrict.runWriterT lhs) w + rightRun = runAccum (WriterStrict.runWriterT rhs) w + in leftRun == rightRun + +lowerWriterCPS :: + forall (a :: Type). + (Eq a) => + M -> + WriterCPS.WriterT N (Accum M) a -> + WriterCPS.WriterT N (Accum M) a -> + Bool +lowerWriterCPS w lhs rhs = + let leftRun = runAccum (WriterCPS.runWriterT lhs) w + rightRun = runAccum (WriterCPS.runWriterT rhs) w + in leftRun == rightRun + +-- Helpers -- A type that's a 'non-specific monoid', similar to how 'A' and 'B' work in -- QuickCheck. @@ -122,9 +313,37 @@ newtype M = M [Int] deriving stock (Show) instance Arbitrary M where + arbitrary = M . pure <$> sized (\size -> chooseInt (0, abs size)) + shrink (M xs) = + M <$> do + xs' <- shrinkList (const []) xs + guard (not . null $ xs') + pure xs' + +instance CoArbitrary M where + coarbitrary (M xs) = coarbitrary xs + +instance Function M where + function = functionMap (\(M xs) -> xs) M + +newtype N = N M + deriving (Eq, Semigroup, Monoid, Arbitrary) via M + deriving stock (Show) + +-- Avoids orphans +newtype AccumArbitrary (w :: Type) (a :: Type) + = AccumArbitrary (Fun w (a, w), AccumT w Identity a) + +instance + (Function w, Monoid w, CoArbitrary w, Arbitrary a, Arbitrary w) => + Arbitrary (AccumArbitrary w a) + where arbitrary = do - x <- sized $ \size -> chooseInt (0, abs size) - pure . M . pure $ x + f <- arbitrary + pure . AccumArbitrary $ (f, accum . applyFun $ f) + shrink (AccumArbitrary (f, _)) = do + f' <- shrink f + pure . AccumArbitrary $ (f', accum . applyFun $ f') typeName :: forall (a :: Type). (Typeable a) => String typeName = tyConName . typeRepTyCon $ typeRep @a From 3816deb83164d77f29ebf40182537af6fe9cf58b Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Sat, 21 May 2022 15:44:06 +1200 Subject: [PATCH 4/6] Refactor, test rigging for ContT --- mtl.cabal | 1 + test/properties/Accum.hs | 231 +++++++++++++++++++++++++++++++++++++++ test/properties/Main.hs | 185 +++++-------------------------- 3 files changed, 261 insertions(+), 156 deletions(-) create mode 100644 test/properties/Accum.hs diff --git a/mtl.cabal b/mtl.cabal index 0b22515..8c6a100 100644 --- a/mtl.cabal +++ b/mtl.cabal @@ -70,6 +70,7 @@ test-suite properties import: common-lang type: exitcode-stdio-1.0 main-is: Main.hs + other-modules: Accum build-depends: , mtl , QuickCheck ^>= 2.14.0 diff --git a/test/properties/Accum.hs b/test/properties/Accum.hs new file mode 100644 index 0000000..d2a0fbd --- /dev/null +++ b/test/properties/Accum.hs @@ -0,0 +1,231 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} + +module Accum + ( M (..), + N (..), + AccumArb (..), + accumLaws, + accumLawsCont, + ) +where + +import Control.Monad (guard) +import Control.Monad.Accum (MonadAccum (accum, add, look)) +import Data.Functor (($>)) +import Data.Kind (Type) +import Test.QuickCheck + ( Arbitrary (arbitrary, shrink), + Blind (Blind), + CoArbitrary (coarbitrary), + Property, + chooseInt, + forAllShrinkShow, + property, + shrinkList, + sized, + (===), + ) +import Test.QuickCheck.Poly (A, B) +import Test.Tasty (TestTree) +import Test.Tasty.QuickCheck (testProperties) +import Text.Show.Pretty (ppShow) +import Type.Reflection + ( Typeable, + tyConModule, + tyConName, + typeRep, + typeRepTyCon, + ) + +newtype M = M [Int] + deriving (Eq, Semigroup, Monoid) via [Int] + deriving stock (Show) + +instance Arbitrary M where + arbitrary = M . pure <$> sized (\size -> chooseInt (0, abs size)) + shrink (M xs) = + M <$> do + xs' <- shrinkList (const []) xs + guard (not . null $ xs') + pure xs' + +instance CoArbitrary M where + coarbitrary (M xs) = coarbitrary xs + +newtype N = N M + deriving (Eq, Semigroup, Monoid, Arbitrary) via M + deriving stock (Show) + +newtype AccumArb (w :: Type) (a :: Type) + = AccumArb (w -> (a, w)) + deriving (Arbitrary) via (w -> (a, w)) + +runAccumArb :: AccumArb w a -> w -> (a, w) +runAccumArb (AccumArb f) = f + +accumLawsCont :: + forall (m :: Type -> Type) (t :: Type). + (MonadAccum M m, Typeable m, Arbitrary t, Show t) => + (forall (a :: Type). t -> m a -> (a -> AccumArb M B) -> AccumArb M B) -> + TestTree +accumLawsCont lowerCont = + testProperties + testName + [ ("look *> look = look", lookLookProp), + ("add mempty = pure ()", addMemptyProp), + ("add x *> add y = add (x <> y)", addAddProp), + ("add x *> look = look >>= \\w -> add x $> w <> x", addLookProp), + ("accum (const (x, mempty)) = pure x", accumPureProp), + ("accum f *> accum g law (too long)", accumFGProp), + ("look = accum $ \\acc -> (acc, mempty)", lookAccumProp), + ("add x = accum $ \\acc -> ((), x)", addAccumProp), + ("accum f = look >>= \\acc -> let (res, v) = f acc in add v $> res", accumAddProp) + ] + where + testName :: String + testName = "MonadAccum laws for " <> typeName @(m A) + addAccumProp :: Property + addAccumProp = theNeedful $ \(w, arg, x, Blind f) -> + let lhs = lowerCont arg (add x) f + rhs = lowerCont arg (accum $ const ((), x)) f + in runAccumArb lhs w === runAccumArb rhs w + accumAddProp :: Property + accumAddProp = theNeedful $ \(w, arg, Blind (f :: M -> (A, M)), Blind g) -> + let lhs = lowerCont arg (accum f) g + rhs = lowerCont arg (look >>= \acc -> let (res, v) = f acc in add v $> res) g + in runAccumArb lhs w === runAccumArb rhs w + lookAccumProp :: Property + lookAccumProp = theNeedful $ \(w, arg, Blind f) -> + let lhs = lowerCont arg look f + rhs = lowerCont arg (accum (,mempty)) f + in runAccumArb lhs w === runAccumArb rhs w + lookLookProp :: Property + lookLookProp = theNeedful $ \(w, arg, Blind f) -> + let lhs = lowerCont arg look f + rhs = lowerCont arg (look *> look) f + in runAccumArb lhs w === runAccumArb rhs w + addMemptyProp :: Property + addMemptyProp = theNeedful $ \(w, arg, Blind f) -> + let lhs = lowerCont arg (add mempty) f + rhs = lowerCont arg (pure ()) f + in runAccumArb lhs w === runAccumArb rhs w + addAddProp :: Property + addAddProp = theNeedful $ \(w, arg, x, y, Blind f) -> + let lhs = lowerCont arg (add x *> add y) f + rhs = lowerCont arg (add (x <> y)) f + in runAccumArb lhs w === runAccumArb rhs w + addLookProp :: Property + addLookProp = theNeedful $ \(w, arg, x, Blind f) -> + let lhs = lowerCont arg (add x *> look) f + rhs = lowerCont arg (look >>= \w' -> add x $> w' <> x) f + in runAccumArb lhs w === runAccumArb rhs w + accumPureProp :: Property + accumPureProp = theNeedful $ \(w, arg, x :: A, Blind f) -> + let lhs = lowerCont arg (accum (const (x, mempty))) f + rhs = lowerCont arg (pure x) f + in runAccumArb lhs w === runAccumArb rhs w + accumFGProp :: Property + accumFGProp = theNeedful $ \(w', arg, Blind (f :: M -> (A, M)), Blind (g :: M -> (M, M)), Blind h) -> + let lhs = lowerCont arg (accum f *> accum g) h + rhs = + lowerCont + arg + ( accum $ \acc -> + let (_, v) = f acc + (res, w) = g (acc <> v) + in (res, v <> w) + ) + h + in runAccumArb lhs w' === runAccumArb rhs w' + +accumLaws :: + forall (m :: Type -> Type) (t :: Type). + (MonadAccum M m, Typeable m, Arbitrary t, Show t) => + (forall (a :: Type). (Eq a) => t -> m a -> m a -> Bool) -> + TestTree +accumLaws runAndCompare = + testProperties + testName + [ ("look *> look = look", lookLookProp), + ("add mempty = pure ()", addMemptyProp), + ("add x *> add y = add (x <> y)", addAddProp), + ("add x *> look = look >>= \\w -> add x $> w <> x", addLookProp), + ("accum (const (x, mempty)) = pure x", accumPureProp), + ("accum f *> accum g law (too long)", accumFGProp), + ("look = accum $ \\acc -> (acc, mempty)", lookAccumProp), + ("add x = accum $ \\acc -> ((), x)", addAccumProp), + ("accum f = look >>= \\acc -> let (res, v) = f acc in add v $> res", accumAddProp) + ] + where + testName :: String + testName = "MonadAccum laws for " <> typeName @(m A) + addAccumProp :: Property + addAccumProp = theNeedful $ \(w, x) -> + let lhs = add x + rhs = accum $ const ((), x) + in property . runAndCompare w lhs $ rhs + accumAddProp :: Property + accumAddProp = theNeedful $ \(w, Blind (f :: M -> (A, M))) -> + let lhs = accum f + rhs = look >>= \acc -> let (res, v) = f acc in add v $> res + in property . runAndCompare w lhs $ rhs + lookLookProp :: Property + lookLookProp = theNeedful $ \w -> + let lhs = look *> look + rhs = look + in property . runAndCompare w lhs $ rhs + addMemptyProp :: Property + addMemptyProp = theNeedful $ \w -> + let lhs = add mempty + rhs = pure () + in property . runAndCompare w lhs $ rhs + addAddProp :: Property + addAddProp = theNeedful $ \(w, x, y) -> + let lhs = add x *> add y + rhs = add (x <> y) + in property . runAndCompare w lhs $ rhs + addLookProp :: Property + addLookProp = theNeedful $ \(w, x) -> + let lhs = add x *> look + rhs = look >>= \w' -> add x $> w' <> x + in property . runAndCompare w lhs $ rhs + accumPureProp :: Property + accumPureProp = theNeedful $ \(w, x :: A) -> + let lhs = accum (const (x, mempty)) + rhs = pure x + in property . runAndCompare w lhs $ rhs + accumFGProp :: Property + accumFGProp = theNeedful $ \(w', Blind (f :: M -> (A, M)), Blind (g :: M -> (M, M))) -> + let lhs = accum f *> accum g + rhs = accum $ \acc -> + let (_, v) = f acc + (res, w) = g (acc <> v) + in (res, v <> w) + in property . runAndCompare w' lhs $ rhs + lookAccumProp :: Property + lookAccumProp = theNeedful $ \w -> + let lhs = look + rhs = accum (,mempty) + in property . runAndCompare w lhs $ rhs + +-- Helpers + +typeName :: forall (a :: Type). (Typeable a) => String +typeName = + let ourTyCon = typeRepTyCon $ typeRep @ a + in tyConModule ourTyCon <> "." <> tyConName ourTyCon + +theNeedful :: + forall (a :: Type). + (Arbitrary a, Show a) => + (a -> Property) -> + Property +theNeedful = forAllShrinkShow arbitrary shrink ppShow diff --git a/test/properties/Main.hs b/test/properties/Main.hs index 43e1a82..5f96af7 100644 --- a/test/properties/Main.hs +++ b/test/properties/Main.hs @@ -1,18 +1,12 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE NumericUnderscores #-} -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} module Main (main) where -import Control.Monad (guard) -import Control.Monad.Accum (MonadAccum (accum, add, look)) -import Control.Monad.Trans.Accum (Accum, AccumT, runAccum) +import Accum (AccumArb (AccumArb), M, N, accumLaws, accumLawsCont) +import Control.Monad.Trans.Accum (Accum, AccumT (AccumT), accum, runAccum) +import Control.Monad.Trans.Cont (ContT, runContT) import Control.Monad.Trans.Except (ExceptT, runExceptT) import Control.Monad.Trans.Identity (IdentityT, runIdentityT) import Control.Monad.Trans.Maybe (MaybeT, runMaybeT) @@ -25,30 +19,12 @@ import qualified Control.Monad.Trans.State.Strict as StateStrict import qualified Control.Monad.Trans.Writer.CPS as WriterCPS import qualified Control.Monad.Trans.Writer.Lazy as WriterLazy import qualified Control.Monad.Trans.Writer.Strict as WriterStrict -import Data.Functor (($>)) -import Data.Functor.Identity (Identity) +import Data.Functor.Identity (Identity, runIdentity) import Data.Kind (Type) import GHC.IO.Encoding (setLocaleEncoding, utf8) -import Test.QuickCheck - ( Arbitrary (arbitrary, shrink), - Blind (Blind), - CoArbitrary (coarbitrary), - Fun, - Function (function), - Property, - applyFun, - chooseInt, - forAllShrinkShow, - functionMap, - property, - shrinkList, - sized, - ) import Test.QuickCheck.Poly (A, B) -import Test.Tasty (TestTree, adjustOption, defaultMain, testGroup) -import Test.Tasty.QuickCheck (QuickCheckTests, testProperties) -import Text.Show.Pretty (ppShow) -import Type.Reflection (Typeable, tyConName, typeRep, typeRepTyCon) +import Test.Tasty (adjustOption, defaultMain, testGroup) +import Test.Tasty.QuickCheck (QuickCheckTests) main :: IO () main = do @@ -68,87 +44,37 @@ main = do accumLaws lowerStateStrict, accumLaws lowerWriterLazy, accumLaws lowerWriterStrict, - accumLaws lowerWriterCPS + accumLaws lowerWriterCPS, + accumLawsCont lowerCont ] ] where go :: QuickCheckTests -> QuickCheckTests go = max 1_000_000 --- Law generators - -accumLaws :: - forall (m :: Type -> Type) (t :: Type). - (MonadAccum M m, Typeable m, Arbitrary t, Show t) => - (forall (a :: Type). (Eq a) => t -> m a -> m a -> Bool) -> - TestTree -accumLaws runAndCompare = - testProperties - testName - [ ("look *> look = look", lookLookProp), - ("add mempty = pure ()", addMemptyProp), - ("add x *> add y = add (x <> y)", addAddProp), - ("add x *> look = look >>= \\w -> add x $> w <> x", addLookProp), - ("accum (const (x, mempty)) = pure x", accumPureProp), - ("accum f *> accum g law (too long)", accumFGProp), - ("look = accum $ \\acc -> (acc, mempty)", lookAccumProp), - ("add x = accum $ \\acc -> ((), x)", addAccumProp), - ("accum f = look >>= \\acc -> let (res, v) = f acc in add v $> res", accumAddProp) - ] - where - testName :: String - testName = "MonadAccum laws for " <> typeName @(m A) - addAccumProp :: Property - addAccumProp = theNeedful $ \(w, x) -> - let lhs = add x - rhs = accum $ const ((), x) - in property . runAndCompare w lhs $ rhs - accumAddProp :: Property - accumAddProp = theNeedful $ \(w, Blind (f :: M -> (A, M))) -> - let lhs = accum f - rhs = look >>= \acc -> let (res, v) = f acc in add v $> res - in property . runAndCompare w lhs $ rhs - lookLookProp :: Property - lookLookProp = theNeedful $ \w -> - let lhs = look *> look - rhs = look - in property . runAndCompare w lhs $ rhs - addMemptyProp :: Property - addMemptyProp = theNeedful $ \w -> - let lhs = add mempty - rhs = pure () - in property . runAndCompare w lhs $ rhs - addAddProp :: Property - addAddProp = theNeedful $ \(w, x, y) -> - let lhs = add x *> add y - rhs = add (x <> y) - in property . runAndCompare w lhs $ rhs - addLookProp :: Property - addLookProp = theNeedful $ \(w, x) -> - let lhs = add x *> look - rhs = look >>= \w' -> add x $> w' <> x - in property . runAndCompare w lhs $ rhs - accumPureProp :: Property - accumPureProp = theNeedful $ \(w, x :: A) -> - let lhs = accum (const (x, mempty)) - rhs = pure x - in property . runAndCompare w lhs $ rhs - accumFGProp :: Property - accumFGProp = theNeedful $ \(w', Blind (f :: M -> (A, M)), Blind (g :: M -> (M, M))) -> - let lhs = accum f *> accum g - rhs = accum $ \acc -> - let (_, v) = f acc - (res, w) = g (acc <> v) - in (res, v <> w) - in property . runAndCompare w' lhs $ rhs - lookAccumProp :: Property - lookAccumProp = theNeedful $ \w -> - let lhs = look - rhs = accum (,mempty) - in property . runAndCompare w lhs $ rhs - -- Lowerings +lowerCont :: + forall (a :: Type). + () -> + ContT B (Accum M) a -> + (a -> AccumArb M B) -> + AccumArb M B +lowerCont _ comp handler = + demote . runContT comp $ (promote . handler) + +promote :: + forall (w :: Type) (a :: Type). + AccumArb w a -> + Accum w a +promote (AccumArb f) = accum f + +demote :: + forall (w :: Type) (a :: Type). + Accum w a -> + AccumArb w a +demote (AccumT f) = AccumArb $ \w -> runIdentity . f $ w + lowerBase :: forall (a :: Type). (Eq a) => @@ -301,56 +227,3 @@ lowerWriterCPS w lhs rhs = let leftRun = runAccum (WriterCPS.runWriterT lhs) w rightRun = runAccum (WriterCPS.runWriterT rhs) w in leftRun == rightRun - --- Helpers - --- A type that's a 'non-specific monoid', similar to how 'A' and 'B' work in --- QuickCheck. --- --- We've deliberately made it _not_ commutative. -newtype M = M [Int] - deriving (Eq, Semigroup, Monoid) via [Int] - deriving stock (Show) - -instance Arbitrary M where - arbitrary = M . pure <$> sized (\size -> chooseInt (0, abs size)) - shrink (M xs) = - M <$> do - xs' <- shrinkList (const []) xs - guard (not . null $ xs') - pure xs' - -instance CoArbitrary M where - coarbitrary (M xs) = coarbitrary xs - -instance Function M where - function = functionMap (\(M xs) -> xs) M - -newtype N = N M - deriving (Eq, Semigroup, Monoid, Arbitrary) via M - deriving stock (Show) - --- Avoids orphans -newtype AccumArbitrary (w :: Type) (a :: Type) - = AccumArbitrary (Fun w (a, w), AccumT w Identity a) - -instance - (Function w, Monoid w, CoArbitrary w, Arbitrary a, Arbitrary w) => - Arbitrary (AccumArbitrary w a) - where - arbitrary = do - f <- arbitrary - pure . AccumArbitrary $ (f, accum . applyFun $ f) - shrink (AccumArbitrary (f, _)) = do - f' <- shrink f - pure . AccumArbitrary $ (f', accum . applyFun $ f') - -typeName :: forall (a :: Type). (Typeable a) => String -typeName = tyConName . typeRepTyCon $ typeRep @a - -theNeedful :: - forall (a :: Type). - (Arbitrary a, Show a) => - (a -> Property) -> - Property -theNeedful = forAllShrinkShow arbitrary shrink ppShow From 0708feaddb6f1cefe4c9dad96be08da62fd8f432 Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Sat, 21 May 2022 15:59:08 +1200 Subject: [PATCH 5/6] Select handler --- test/properties/Accum.hs | 76 ++++++++++++++++++++++++++++++++++++++++ test/properties/Main.hs | 22 ++++++++++-- 2 files changed, 96 insertions(+), 2 deletions(-) diff --git a/test/properties/Accum.hs b/test/properties/Accum.hs index d2a0fbd..f84ac67 100644 --- a/test/properties/Accum.hs +++ b/test/properties/Accum.hs @@ -14,6 +14,7 @@ module Accum AccumArb (..), accumLaws, accumLawsCont, + accumLawsSelect, ) where @@ -71,6 +72,81 @@ newtype AccumArb (w :: Type) (a :: Type) runAccumArb :: AccumArb w a -> w -> (a, w) runAccumArb (AccumArb f) = f +accumLawsSelect :: + forall (m :: Type -> Type) (t :: Type). + (MonadAccum M m, Typeable m, Arbitrary t, Show t) => + (forall (a :: Type). t -> m a -> (a -> AccumArb M B) -> AccumArb M a) -> + TestTree +accumLawsSelect lowerSelect = + testProperties + testName + [ ("look *> look = look", lookLookProp), + ("add mempty = pure ()", addMemptyProp), + ("add x *> add y = add (x <> y)", addAddProp), + ("add x *> look = look >>= \\w -> add x $> w <> x", addLookProp), + ("accum (const (x, mempty)) = pure x", accumPureProp), + ("accum f *> accum g law (too long)", accumFGProp), + ("look = accum $ \\acc -> (acc, mempty)", lookAccumProp), + ("add x = accum $ \\acc -> ((), x)", addAccumProp), + ("accum f = look >>= \\acc -> let (res, v) = f acc in add v $> res", accumAddProp) + ] + where + testName :: String + testName = "MonadAccum laws for " <> typeName @(m A) + addAccumProp :: Property + addAccumProp = theNeedful $ \(w, arg, x, Blind f) -> + let lhs = lowerSelect arg (add x) f + rhs = lowerSelect arg (accum $ const ((), x)) f + in runAccumArb lhs w === runAccumArb rhs w + accumAddProp :: Property + accumAddProp = theNeedful $ \(w, arg, Blind (f :: M -> (A, M)), Blind g) -> + let lhs = lowerSelect arg (accum f) g + rhs = lowerSelect arg (look >>= \acc -> let (res, v) = f acc in add v $> res) g + in runAccumArb lhs w === runAccumArb rhs w + lookAccumProp :: Property + lookAccumProp = theNeedful $ \(w, arg, Blind f) -> + let lhs = lowerSelect arg look f + rhs = lowerSelect arg (accum (,mempty)) f + in runAccumArb lhs w === runAccumArb rhs w + lookLookProp :: Property + lookLookProp = theNeedful $ \(w, arg, Blind f) -> + let lhs = lowerSelect arg look f + rhs = lowerSelect arg (look *> look) f + in runAccumArb lhs w === runAccumArb rhs w + addMemptyProp :: Property + addMemptyProp = theNeedful $ \(w, arg, Blind f) -> + let lhs = lowerSelect arg (add mempty) f + rhs = lowerSelect arg (pure ()) f + in runAccumArb lhs w === runAccumArb rhs w + addAddProp :: Property + addAddProp = theNeedful $ \(w, arg, x, y, Blind f) -> + let lhs = lowerSelect arg (add x *> add y) f + rhs = lowerSelect arg (add (x <> y)) f + in runAccumArb lhs w === runAccumArb rhs w + addLookProp :: Property + addLookProp = theNeedful $ \(w, arg, x, Blind f) -> + let lhs = lowerSelect arg (add x *> look) f + rhs = lowerSelect arg (look >>= \w' -> add x $> w' <> x) f + in runAccumArb lhs w === runAccumArb rhs w + accumPureProp :: Property + accumPureProp = theNeedful $ \(w, arg, x :: A, Blind f) -> + let lhs = lowerSelect arg (accum (const (x, mempty))) f + rhs = lowerSelect arg (pure x) f + in runAccumArb lhs w === runAccumArb rhs w + accumFGProp :: Property + accumFGProp = theNeedful $ \(w', arg, Blind (f :: M -> (A, M)), Blind (g :: M -> (M, M)), Blind h) -> + let lhs = lowerSelect arg (accum f *> accum g) h + rhs = + lowerSelect + arg + ( accum $ \acc -> + let (_, v) = f acc + (res, w) = g (acc <> v) + in (res, v <> w) + ) + h + in runAccumArb lhs w' === runAccumArb rhs w' + accumLawsCont :: forall (m :: Type -> Type) (t :: Type). (MonadAccum M m, Typeable m, Arbitrary t, Show t) => diff --git a/test/properties/Main.hs b/test/properties/Main.hs index 5f96af7..d33ac3a 100644 --- a/test/properties/Main.hs +++ b/test/properties/Main.hs @@ -4,7 +4,14 @@ module Main (main) where -import Accum (AccumArb (AccumArb), M, N, accumLaws, accumLawsCont) +import Accum + ( AccumArb (AccumArb), + M, + N, + accumLaws, + accumLawsCont, + accumLawsSelect, + ) import Control.Monad.Trans.Accum (Accum, AccumT (AccumT), accum, runAccum) import Control.Monad.Trans.Cont (ContT, runContT) import Control.Monad.Trans.Except (ExceptT, runExceptT) @@ -14,6 +21,7 @@ import qualified Control.Monad.Trans.RWS.CPS as RWSCPS import qualified Control.Monad.Trans.RWS.Lazy as RWSLazy import qualified Control.Monad.Trans.RWS.Strict as RWSStrict import Control.Monad.Trans.Reader (ReaderT, runReaderT) +import Control.Monad.Trans.Select (SelectT, runSelectT) import qualified Control.Monad.Trans.State.Lazy as StateLazy import qualified Control.Monad.Trans.State.Strict as StateStrict import qualified Control.Monad.Trans.Writer.CPS as WriterCPS @@ -45,7 +53,8 @@ main = do accumLaws lowerWriterLazy, accumLaws lowerWriterStrict, accumLaws lowerWriterCPS, - accumLawsCont lowerCont + accumLawsCont lowerCont, + accumLawsSelect lowerSelect ] ] where @@ -54,6 +63,15 @@ main = do -- Lowerings +lowerSelect :: + forall (a :: Type). + () -> + SelectT B (Accum M) a -> + (a -> AccumArb M B) -> + AccumArb M a +lowerSelect _ comp handler = + demote . runSelectT comp $ (promote . handler) + lowerCont :: forall (a :: Type). () -> From f11655edc3e6f22bed7cb371a8a7d456487ecc3e Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Sat, 21 May 2022 16:00:23 +1200 Subject: [PATCH 6/6] Enable test running in CI --- .github/workflows/ci.yml | 4 +++- test/properties/Accum.hs | 2 +- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 01631c0..93220d8 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -24,7 +24,7 @@ jobs: ghc-version: ${{ matrix.ghc }} cabal-version: 'latest' - name: Configure - run: cabal new-configure + run: cabal new-configure --enable-tests - name: Freeze run: cabal freeze - name: Cache @@ -35,3 +35,5 @@ jobs: restore-keys: ${{ runner.os }}-${{ matrix.ghc }}- - name: Build run: cabal build + - name: Run tests + run: cabal test diff --git a/test/properties/Accum.hs b/test/properties/Accum.hs index f84ac67..33698bc 100644 --- a/test/properties/Accum.hs +++ b/test/properties/Accum.hs @@ -296,7 +296,7 @@ accumLaws runAndCompare = typeName :: forall (a :: Type). (Typeable a) => String typeName = - let ourTyCon = typeRepTyCon $ typeRep @ a + let ourTyCon = typeRepTyCon $ typeRep @a in tyConModule ourTyCon <> "." <> tyConName ourTyCon theNeedful ::