polysemy-test 0.3.0.1 → 0.3.0.2

raw patch · 8 files changed

+203/−27 lines, 8 filesdep +template-haskelldep ~polysemyPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: template-haskell

Dependency ranges changed: polysemy

API changes (from Hackage documentation)

Files

• Changelog.md +4/−0
• lib/Polysemy/Test.hs +12/−0
• lib/Polysemy/Test/Hedgehog.hs +98/−3
• lib/Polysemy/Test/Prelude.hs +6/−1
• lib/Polysemy/Test/Run.hs +28/−17
• polysemy-test.cabal +5/−3
• test/Main.hs +3/−2
• test/Polysemy/Test/Test/HedgehogTest.hs +47/−1

@@ -1,3 +1,7 @@+# 0.4.0.0++* Add Hedgehog assertion combinators for the difference between numeric values.+ # 0.3.0.0  * Add type parameter for the monad used by `TestT` to `Hedgehog`

@@ -19,10 +19,16 @@   (===),   (/==),   assertRight,+  assertRight2,+  assertRight3,   assertJust,   evalEither,+  evalLeft,+  assertLeft,   evalMaybe,   evalError,+  assertCloseBy,+  assertClose,   interpretHedgehog,   -- * Running 'Hedgehog' and 'Test' as 'TestT'   runTestAutoWith,@@ -49,10 +55,16 @@ import Polysemy.Test.Data.TestError (TestError(TestError)) import Polysemy.Test.Hedgehog (   assert,+  assertClose,+  assertCloseBy,   assertJust,+  assertLeft,   assertRight,+  assertRight2,+  assertRight3,   evalEither,   evalError,+  evalLeft,   evalMaybe,   interpretHedgehog,   (/==),

@@ -4,7 +4,7 @@  import qualified Control.Monad.Trans.Writer.Lazy as MTL import qualified Hedgehog as Native-import Hedgehog.Internal.Property (Failure, Journal, TestT(TestT))+import Hedgehog.Internal.Property (Failure, Journal, TestT(TestT), failWith) import Polysemy.Writer (Writer, tell)  import qualified Polysemy.Test.Data.Hedgehog as Hedgehog@@ -112,9 +112,72 @@   a ->   Either e a ->   Sem r ()-assertRight a e =-  withFrozenCallStack $ (a ===) =<< evalEither e+assertRight a =+  withFrozenCallStack $ (a ===) <=< evalEither +-- |Like 'assertRight', but for two nested Eithers.+assertRight2 ::+  ∀ a m e1 e2 r .+  Eq a =>+  Show e1 =>+  Show e2 =>+  Show a =>+  Monad m =>+  HasCallStack =>+  Member (Hedgehog m) r =>+  a ->+  Either e1 (Either e2 a) ->+  Sem r ()+assertRight2 a =+  withFrozenCallStack $ assertRight a <=< evalEither++-- |Like 'assertRight', but for three nested Eithers.+assertRight3 ::+  ∀ a m e1 e2 e3 r .+  Eq a =>+  Show e1 =>+  Show e2 =>+  Show e3 =>+  Show a =>+  Monad m =>+  HasCallStack =>+  Member (Hedgehog m) r =>+  a ->+  Either e1 (Either e2 (Either e3 a)) ->+  Sem r ()+assertRight3 a =+  withFrozenCallStack $ assertRight2 a <=< evalEither++-- |Like 'evalEither', but for 'Left'.+evalLeft ::+  ∀ a m e r .+  Show a =>+  Monad m =>+  HasCallStack =>+  Member (Hedgehog m) r =>+  Either e a ->+  Sem r e+evalLeft = \case+  Right a ->+    withFrozenCallStack $ liftH $ failWith Nothing $ show a+  Left e ->+    pure e++-- |Like 'assertRight', but for 'Left'.+assertLeft ::+  ∀ a m e r .+  Eq e =>+  Show e =>+  Show a =>+  Monad m =>+  HasCallStack =>+  Member (Hedgehog m) r =>+  e ->+  Either e a ->+  Sem r ()+assertLeft e =+  withFrozenCallStack $ (e ===) <=< evalLeft+ data ValueIsNothing =   ValueIsNothing   deriving Show@@ -155,3 +218,35 @@   Sem r a evalError sem =   withFrozenCallStack $ evalEither =<< runError sem++-- |Assert that two numeric values are closer to each other than the specified @delta@.+assertCloseBy ::+  ∀ a m r .+  Num a =>+  Ord a =>+  Show a =>+  Monad m =>+  HasCallStack =>+  Member (Hedgehog m) r =>+  a ->+  a ->+  a ->+  Sem r ()+assertCloseBy delta target scrutinee =+  withFrozenCallStack $ assert (abs (scrutinee - target) < delta)++-- |Assert that two fractional values are closer to each other than @0.001@.+assertClose ::+  ∀ a m r .+  Num a =>+  Ord a =>+  Fractional a =>+  Show a =>+  Monad m =>+  HasCallStack =>+  Member (Hedgehog m) r =>+  a ->+  a ->+  Sem r ()+assertClose =+  withFrozenCallStack $ assertCloseBy 0.001

@@ -6,7 +6,6 @@   module Data.Either.Combinators,   module Data.Foldable,   module Data.Map.Strict,-  module Data.String.Interpolate,   module Debug.Trace,   module GHC.Err,   module Polysemy,@@ -27,6 +26,7 @@ import Debug.Trace (trace, traceShow) import GHC.Err (undefined) import GHC.IO.Unsafe (unsafePerformIO)+import Language.Haskell.TH.Quote (QuasiQuoter) import Polysemy (   Effect,   EffectRow,@@ -235,3 +235,8 @@ mneToList =   maybe [] toList {-# INLINE mneToList #-}++qt :: QuasiQuoter+qt =+  i+{-# INLINE qt #-}

@@ -5,10 +5,11 @@ import Control.Exception (catch) import qualified Control.Monad.Trans.Writer.Lazy as MTL import qualified Data.Text as Text-import GHC.Stack.Types (SrcLoc(SrcLoc, srcLocModule, srcLocFile))+import GHC.Stack.Types (SrcLoc(SrcLoc, srcLocFile), srcLocModule) import Hedgehog.Internal.Property (Failure, Journal, TestT(TestT), failWith) import Path (Abs, Dir, Path, parseAbsDir, parseRelDir, (</>)) import Path.IO (canonicalizePath, createTempDir, getCurrentDir, getTempDir, removeDirRecur)+import Polysemy.Fail (Fail, failToError) import Polysemy.Resource (Resource, bracket, resourceToIOFinal) import Polysemy.Writer (runLazyWriter) import System.IO.Error (IOError)@@ -96,14 +97,6 @@   base <- embed (canonicalizePath @_ @IO prefixPath)   (interpretTest base) sem -type TestEffects =-  [-    Error TestError,-    Hedgehog IO,-    Embed IO,-    Final IO-  ]- errorToFailure ::   Monad m =>   Member (Hedgehog m) r =>@@ -113,11 +106,17 @@   Right a -> pure a   Left (TestError e) -> liftH (failWith Nothing (toString e)) +failToFailure ::+  Member (Error TestError) r =>+  InterpreterFor Fail r+failToFailure =+  failToError (TestError . toText)+ -- |Run 'Hedgehog' and its dependent effects that correspond to the monad stack of 'TestT', exposing the monadic state. unwrapLiftedTestT ::   Monad m =>   Member (Embed m) r =>-  Sem (Error TestError : Hedgehog m : r) a ->+  Sem (Fail : Error TestError : Hedgehog m : r) a ->   Sem r (Journal, Either Failure a) unwrapLiftedTestT =   runLazyWriter .@@ -125,14 +124,15 @@   rewriteHedgehog .   raiseUnder2 .   (>>= errorToFailure) .-  runError+  runError .+  failToFailure  -- |Run 'Hedgehog' with 'unwrapLiftedTestT' and wrap it back into the 'TestT' stack. semToTestT ::   Monad m =>   Member (Embed m) r =>   (∀ x . Sem r x -> m x) ->-  Sem (Error TestError : Hedgehog m : r) a ->+  Sem (Fail : Error TestError : Hedgehog m : r) a ->   TestT m a semToTestT run sem = do   (journal, result) <- lift (run (unwrapLiftedTestT sem))@@ -140,16 +140,27 @@  semToTestTFinal ::   Monad m =>-  Sem [Error TestError, Hedgehog m, Embed m, Final m] a ->+  Sem [Fail, Error TestError, Hedgehog m, Embed m, Final m] a ->   TestT m a semToTestTFinal =   semToTestT (runFinal . embedToFinal) +type TestEffects =+  [+    Test,+    Resource,+    Fail,+    Error TestError,+    Hedgehog IO,+    Embed IO,+    Final IO+  ]+ -- |Convenience combinator that runs both 'Hedgehog' and 'Test' and rewraps the result in @'TestT' IO@, ready for -- execution as a property. runTest ::   Path Abs Dir ->-  Sem [Test, Resource, Error TestError, Hedgehog IO, Embed IO, Final IO] a ->+  Sem TestEffects a ->   TestT IO a runTest dir =   semToTestTFinal .@@ -159,7 +170,7 @@ -- |Same as 'runTest', but uses 'interpretTestInSubdir'. runTestInSubdir ::   Text ->-  Sem (Test : Resource : TestEffects) a ->+  Sem TestEffects a ->   TestT IO a runTestInSubdir prefix =   semToTestTFinal .@@ -192,7 +203,7 @@   HasCallStack =>   Members [Resource, Embed IO] r =>   (∀ x . Sem r x -> IO x) ->-  Sem (Test : Error TestError : Hedgehog IO : r) a ->+  Sem (Test : Fail : Error TestError : Hedgehog IO : r) a ->   TestT IO a runTestAutoWith run sem =   semToTestT run do@@ -202,7 +213,7 @@ -- |Version of 'runTestAutoWith' specialized to @'Final' IO@ runTestAuto ::   HasCallStack =>-  Sem [Test, Error TestError, Hedgehog IO, Embed IO, Resource, Final IO] a ->+  Sem [Test, Fail, Error TestError, Hedgehog IO, Embed IO, Resource, Final IO] a ->   TestT IO a runTestAuto =   runTestAutoWith (runFinal . resourceToIOFinal . embedToFinal)

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           polysemy-test-version:        0.3.0.1+version:        0.3.0.2 synopsis:       Polysemy effects for testing description:    Please see the README on Github at <https://github.com/tek/polysemy-test> category:       Test@@ -45,12 +45,13 @@     , hedgehog >=1.0.2 && <1.1     , path >=0.8 && <0.9     , path-io >=0.3.1 && <0.4-    , polysemy >=1.3.0 && <1.4+    , polysemy >=1.3 && <1.5     , polysemy-plugin >=0.2.5 && <0.3     , relude >=0.7 && <0.8     , string-interpolate >=0.1 && <0.4     , tasty >=1.2.3 && <1.3     , tasty-hedgehog >=1 && <1.1+    , template-haskell     , text     , transformers   mixins:@@ -75,13 +76,14 @@     , hedgehog >=1.0.2 && <1.1     , path >=0.8 && <0.9     , path-io >=0.3.1 && <0.4-    , polysemy >=1.3.0 && <1.4+    , polysemy >=1.3 && <1.5     , polysemy-plugin >=0.2.5 && <0.3     , polysemy-test     , relude >=0.7 && <0.8     , string-interpolate >=0.1 && <0.4     , tasty     , tasty-hedgehog >=1 && <1.1+    , template-haskell     , text     , transformers   mixins:

@@ -4,14 +4,15 @@  import Polysemy.Test (unitTest) import Polysemy.Test.Test.FilesTest (test_fixture, test_tempFile)-import Polysemy.Test.Test.HedgehogTest (test_hedgehogRewrite)+import Polysemy.Test.Test.HedgehogTest (test_fail, test_hedgehogRewrite)  tests :: TestTree tests =   testGroup "all" [     unitTest "read fixtures" test_fixture,     unitTest "write and read temp files" test_tempFile,-    unitTest "rewrite TestT to Sem" test_hedgehogRewrite+    unitTest "rewrite TestT to Sem" test_hedgehogRewrite,+    unitTest "convert MonadFail to assertion" test_fail   ]  main :: IO ()

@@ -1,8 +1,54 @@ module Polysemy.Test.Test.HedgehogTest where -import Polysemy.Test (UnitTest, (/==))+import Hedgehog (TestT, assert)+import Hedgehog.Internal.Property (Failure(Failure), runTestT)++import Polysemy.Fail (Fail)+import Polysemy.Resource (Resource)+import Polysemy.Test (UnitTest, runTestAuto, (/==))+import Polysemy.Test.Data.Hedgehog (Hedgehog)+import Polysemy.Test.Data.Test (Test)+import Polysemy.Test.Data.TestError (TestError)+import Polysemy.Test.Hedgehog (assertClose) import Polysemy.Test.Run (semToTestTFinal)  test_hedgehogRewrite :: UnitTest test_hedgehogRewrite =   semToTestTFinal ((1 :: Int) /== 2)++hedgehogTest ::+  Sem [Test, Fail, Error TestError, Hedgehog IO, Embed IO, Resource, Final IO] () ->+  TestT IO Bool+hedgehogTest prog =+  extract . fst <$> liftIO (runTestT $ runTestAuto $ prog)+  where+    extract = \case+      Left (Failure (Just _) _ _) ->+        False+      _ ->+        True++hedgehogSuccess ::+  Sem [Test, Fail, Error TestError, Hedgehog IO, Embed IO, Resource, Final IO] () ->+  UnitTest+hedgehogSuccess =+  assert <=< hedgehogTest++hedgehogFail ::+  Sem [Test, Fail, Error TestError, Hedgehog IO, Embed IO, Resource, Final IO] () ->+  UnitTest+hedgehogFail =+  assert . not <=< hedgehogTest++test_fail :: UnitTest+test_fail = do+  hedgehogFail prog+  where+    prog = do+      Right _ <- pure (Left ("failed" :: Text))+      unit++test_close :: UnitTest+test_close = do+  hedgehogSuccess (assertClose (1.11111 :: Double) 1.111111111111)+  hedgehogFail (assertClose (1.11 :: Double) 1.111111111111)