lawful-classes-quickcheck 0.1.1.1 → 0.1.2.0

raw patch · 4 files changed

+123/−3 lines, 4 filesdep +lawful-classes-quickcheckdep +mtldep +tasty-expected-failurePVP ok

version bump matches the API change (PVP)

Dependencies added: lawful-classes-quickcheck, mtl, tasty-expected-failure, transformers

API changes (from Hackage documentation)

Files

• CHANGELOG.md +4/−0
• lawful-classes-quickcheck.cabal +18/−1
• src/Test/Lawful/QuickCheck.hs +33/−2
• test/Main.hs +68/−0

@@ -1,5 +1,9 @@ # Revision history for lawful-classes-quickcheck +## 0.1.2.0 -- 2023-02-02++* Add `Test.Lawful.QuickCheck.forAll(Show)`.+ ## 0.1.1.1 -- 2023-02-01  * Support GHC 9.2.4 / base 4.16.3.0.

@@ -1,6 +1,6 @@ cabal-version:   3.0 name:            lawful-classes-quickcheck-version:         0.1.1.1+version:         0.1.2.0 synopsis:        QuickCheck support for lawful-classes description:   Support code to check @lawful-classes@ laws using QuickCheck and,@@ -41,6 +41,23 @@     , QuickCheck            ^>=2.14.2     , tasty                 ^>=1.4.3     , tasty-quickcheck      ^>=0.10.2+    , transformers          ^>=0.5.6.2    hs-source-dirs:   src   default-language: Haskell2010++test-suite lawful-classes-quickcheck-test+  import:           warnings+  default-language: Haskell2010+  type:             exitcode-stdio-1.0+  hs-source-dirs:   test+  main-is:          Main.hs+  build-depends:+    , base                       ^>=4.14.3.0 || ^>=4.15.1.0 || ^>=4.16.3.0 || ^>=4.17.0.0+    , lawful-classes-quickcheck  ^>=0.1.2.0+    , lawful-classes-types       ^>=0.1.0.0+    , mtl                        ^>=2.2.2+    , QuickCheck                 ^>=2.14.2+    , tasty                      ^>=1.4.3+    , tasty-expected-failure     ^>=0.12.3+    , transformers               ^>=0.5.6.2

@@ -15,14 +15,20 @@     testLaws,     testLawsWith, +    -- * Utilities+    forAll,+    forAllShow,+     -- * Plumbing     toProperty,   ) where +import Control.Monad.Trans.Class (MonadTrans, lift) import Test.Lawful.Types (Law, Laws)-import Test.QuickCheck (Property, discard)-import Test.QuickCheck.Monadic (PropertyM, assert, monadicIO)+import Test.QuickCheck (Gen, Property, discard)+import qualified Test.QuickCheck as Q+import Test.QuickCheck.Monadic (PropertyM (MkPropertyM), assert, monadicIO, pick) import Test.Tasty (TestName, TestTree, testGroup) import Test.Tasty.QuickCheck (testProperty) @@ -47,3 +53,28 @@ -- @since 0.1.1.0 testLawsWith :: (Property -> Property) -> TestName -> (forall a. m a -> PropertyM IO a) -> Laws m -> TestTree testLawsWith fn name run laws = testGroup name [testProperty n (fn $ toProperty run l) | (n, l) <- laws]++-- | Lifted version of 'pick'.+--+-- This can be used to easily create generators for laws which need them.+--+-- __Note__: like 'pick', values generated by 'forAll' do not shrink.+forAll :: (MonadTrans t, Monad m, Show a) => Gen a -> t (PropertyM m) a+forAll = lift . pick++-- | Like 'forAll', but for types without a 'Show' instance (or, for which+-- another stringification functions but 'show' should be used).+--+-- Like 'Test.QuickCheck.forAllShow', but in a monadic context.+--+-- This can be used to earily create generators for laws which need them.+--+-- __Note__: like 'forAll', values generated by 'forAllShow' do not shrink.+forAllShow :: (MonadTrans t, Monad m) => (a -> String) -> Gen a -> t (PropertyM m) a+forAllShow shw = lift . pickShow+  where+    pickShow gen = MkPropertyM $ \k -> do+      a <- gen+      mp <- k a+      return $+        Q.forAllShow (return a) shw . const <$> mp

@@ -0,0 +1,68 @@+module Main (main) where++import Control.Monad.State (evalState)+import Control.Monad.State.Class (MonadState, get, put)+import Control.Monad.Trans.State (evalStateT)+import Test.Lawful.QuickCheck (forAll, forAllShow, testLaws, testLawsWith)+import Test.Lawful.Types (Laws, assert, discard)+import Test.QuickCheck (arbitrary, once)+import Test.Tasty (TestTree, defaultMain, testGroup)+import Test.Tasty.ExpectedFailure (expectFailBecause)++main :: IO ()+main = defaultMain tests++monadStateLaws :: (MonadState s m, Eq s) => m s -> Laws m+monadStateLaws gen =+  [ ( "get returns what was put",+      do+        a0 <- get+        a <- gen++        if a == a0+          then discard+          else do+            put a+            a' <- get+            assert $ a' == a+    )+  ]++newtype NoShow = NoShow Int+  deriving (Eq)++tests :: TestTree+tests =+  testGroup+    "lawful-classes-hedgehog"+    [ testGroup+        "StateT Int"+        [ testLaws+            "monadStateLaws"+            (`evalStateT` (0 :: Int))+            (monadStateLaws $ forAll arbitrary)+        ],+      testGroup+        "StateT NoShow"+        [ testLaws+            "monadStateLaws"+            (`evalStateT` NoShow 0)+            (monadStateLaws (forAllShow (\(NoShow _) -> "NoShow") (NoShow <$> arbitrary)))+        ],+      testGroup+        "StateT ()"+        [ expectFailBecause "() has only one possible value" $+            testLaws+              "monadStateLaws"+              (`evalStateT` ())+              (monadStateLaws $ forAll $ pure ())+        ],+      testGroup+        "State Int"+        [ testLawsWith+            once+            "monadStateLaws"+            (pure . flip evalState (0 :: Int))+            (monadStateLaws $ pure 1)+        ]+    ]