lawful-classes-hedgehog 0.1.1.1 → 0.1.2.0

raw patch · 4 files changed

+119/−2 lines, 4 filesdep +lawful-classes-hedgehogdep +mtldep +tasty-expected-failurePVP ok

version bump matches the API change (PVP)

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

API changes (from Hackage documentation)

Files

• CHANGELOG.md +4/−0
• lawful-classes-hedgehog.cabal +18/−1
• src/Test/Lawful/Hedgehog.hs +27/−1
• test/Main.hs +70/−0

@@ -1,5 +1,9 @@ # Revision history for lawful-classes-hedgehog +## 0.1.2.0 -- 2023-02-02++* Add `Test.Lawful.Hedgehog.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-hedgehog-version:         0.1.1.1+version:         0.1.2.0 synopsis:        Hedgehog support for lawful-classes description:   Support code to check @lawful-classes@ laws using Hedgehog and,@@ -41,6 +41,23 @@     , lawful-classes-types  ^>=0.1.0.0     , tasty                 ^>=1.4.3     , tasty-hedgehog        ^>=1.4.0.0+    , transformers          ^>=0.5.6.2    hs-source-dirs:   src   default-language: Haskell2010++test-suite lawful-classes-hedgehog-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+    , hedgehog                 ^>=1.2+    , lawful-classes-hedgehog  ^>=0.1.2.0+    , lawful-classes-types     ^>=0.1.0.0+    , mtl                      ^>=2.2.2+    , tasty                    ^>=1.4.3+    , tasty-expected-failure   ^>=0.12.3+    , transformers             ^>=0.5.6.2

@@ -15,12 +15,19 @@     testLaws,     testLawsWith, +    -- * Utilities+    forAll,+    forAllShow,+     -- * Plumbing     toProperty,   ) where -import Hedgehog (Property, PropertyT, assert, discard, evalM, property)+import Control.Monad.Trans.Class (MonadTrans, lift)+import GHC.Stack (HasCallStack, withFrozenCallStack)+import Hedgehog (Gen, Property, PropertyT, assert, discard, evalM, property)+import qualified Hedgehog as H import Test.Lawful.Types (Law, Laws) import Test.Tasty (TestName, TestTree, testGroup) import Test.Tasty.Hedgehog (testProperty)@@ -46,3 +53,22 @@ -- @since 0.1.1.0 testLawsWith :: (Property -> Property) -> TestName -> (forall a. m a -> PropertyT IO a) -> Laws m -> TestTree testLawsWith fn name run laws = testGroup name [testProperty n (fn $ toProperty run l) | (n, l) <- laws]++-- | Lifted version of 'H.forAll'.+--+-- This can be used to easily create generators for laws which need them.+--+-- @since 0.1.2.0+forAll :: (MonadTrans t, Monad m, Show a, HasCallStack) => Gen a -> t (PropertyT m) a+forAll gen = withFrozenCallStack $ lift (H.forAll gen)++-- | Lifted version of 'H.forAllWith'.+--+-- Like 'forAll', but for types without a 'Show' instance (or, for which+-- another stringification functions but 'show' should be used).+--+-- This can be used to earily create generators for laws which need them.+--+-- @since 0.1.2.0+forAllShow :: (MonadTrans t, Monad m, HasCallStack) => (a -> String) -> Gen a -> t (PropertyT m) a+forAllShow shw gen = withFrozenCallStack $ lift (H.forAllWith shw gen)

@@ -0,0 +1,70 @@+module Main (main) where++import Control.Monad.State (evalState)+import Control.Monad.State.Class (MonadState, get, put)+import Control.Monad.Trans.State (evalStateT)+import Hedgehog (withTests)+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range+import Test.Lawful.Hedgehog (forAll, forAllShow, testLaws, testLawsWith)+import Test.Lawful.Types (Laws, assert, discard)+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 $ Gen.integral Range.linearBounded)+        ],+      testGroup+        "StateT NoShow"+        [ testLaws+            "monadStateLaws"+            (`evalStateT` NoShow 0)+            (monadStateLaws (forAllShow (\(NoShow _) -> "NoShow") (NoShow <$> Gen.integral Range.linearBounded)))+        ],+      testGroup+        "StateT ()"+        [ expectFailBecause "() has only one possible value" $+            testLaws+              "monadStateLaws"+              (`evalStateT` ())+              (monadStateLaws $ forAll $ pure ())+        ],+      testGroup+        "State Int"+        [ testLawsWith+            (withTests 1)+            "monadStateLaws"+            (pure . flip evalState (0 :: Int))+            (monadStateLaws $ pure 1)+        ]+    ]