ImpSpec (empty) → 0.1.0.0
raw patch · 13 files changed
+1145/−0 lines, 13 filesdep +HUnitdep +ImpSpecdep +QuickChecksetup-changed
Dependencies added: HUnit, ImpSpec, QuickCheck, base, bytestring, deepseq, hspec, hspec-core, hspec-expectations-lifted, mtl, prettyprinter, prettyprinter-ansi-terminal, quickcheck-transformer, random, text, unliftio
Files
- CHANGELOG.md +5/−0
- ImpSpec.cabal +79/−0
- LICENSE +177/−0
- README.md +29/−0
- Setup.hs +3/−0
- src/Test/ImpSpec.hs +8/−0
- src/Test/ImpSpec/Expectations.hs +163/−0
- src/Test/ImpSpec/Expectations/Lifted.hs +148/−0
- src/Test/ImpSpec/Internal.hs +393/−0
- src/Test/ImpSpec/Main.hs +31/−0
- src/Test/ImpSpec/Random.hs +81/−0
- test/Main.hs +7/−0
- test/Test/Suite/ImpSpec.hs +21/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Version history for `ImpSpec`++## 0.1.0.0++*
+ ImpSpec.cabal view
@@ -0,0 +1,79 @@+cabal-version: 1.18+name: ImpSpec+version: 0.1.0.0+license: Apache-2.0+license-file: LICENSE+maintainer: operations@iohk.io+author: IOHK+homepage: https://github.com/input-output-hk/ImpSpec+synopsis:+ Imperative approach to testing stateful applications. ImpSpec is build on top of HSpec and QuickCheck+description:+ Let a little imp help you discover all the bugs in your stateful Haskell program.+category: Control+build-type: Simple+extra-doc-files: CHANGELOG.md+extra-source-files: README.md+tested-with: GHC == 8.2.2+ , GHC == 8.4.4+ , GHC == 8.6.5+ , GHC == 8.8.4+ , GHC == 8.10.7+ , GHC == 9.0.2+ , GHC == 9.2.8+ , GHC == 9.4.8+ , GHC == 9.6.6+ , GHC == 9.8.2+ , GHC == 9.10.1++source-repository head+ type: git+ location: https://github.com/intersectmbo/cardano-ledger+ subdir: libs/ImpSpec++library+ exposed-modules:+ Test.ImpSpec+ Test.ImpSpec.Expectations+ Test.ImpSpec.Expectations.Lifted+ Test.ImpSpec.Main+ Test.ImpSpec.Random++ hs-source-dirs: src+ other-modules: Test.ImpSpec.Internal+ default-language: Haskell2010+ ghc-options:+ -Wall -Wcompat -Wincomplete-record-updates+ -Wincomplete-uni-patterns -Wredundant-constraints++ build-depends:+ base >=4.9 && <5,+ bytestring,+ deepseq,+ hspec,+ hspec-core >=2.11,+ hspec-expectations-lifted,+ HUnit,+ mtl,+ QuickCheck,+ quickcheck-transformer,+ prettyprinter >=1.7,+ prettyprinter-ansi-terminal >=1.1.2,+ random >=1.2,+ text,+ unliftio++test-suite tests+ type: exitcode-stdio-1.0+ main-is: Main.hs+ hs-source-dirs: test+ other-modules: Test.Suite.ImpSpec+ default-language: Haskell2010+ ghc-options:+ -Wall -Wcompat -Wincomplete-record-updates+ -Wincomplete-uni-patterns -Wredundant-constraints+ -threaded -rtsopts++ build-depends:+ base,+ ImpSpec
+ LICENSE view
@@ -0,0 +1,177 @@++ Apache License+ Version 2.0, January 2004+ http://www.apache.org/licenses/++ TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION++ 1. Definitions.++ "License" shall mean the terms and conditions for use, reproduction,+ and distribution as defined by Sections 1 through 9 of this document.++ "Licensor" shall mean the copyright owner or entity authorized by+ the copyright owner that is granting the License.++ "Legal Entity" shall mean the union of the acting entity and all+ other entities that control, are controlled by, or are under common+ control with that entity. For the purposes of this definition,+ "control" means (i) the power, direct or indirect, to cause the+ direction or management of such entity, whether by contract or+ otherwise, or (ii) ownership of fifty percent (50%) or more of the+ outstanding shares, or (iii) beneficial ownership of such entity.++ "You" (or "Your") shall mean an individual or Legal Entity+ exercising permissions granted by this License.++ "Source" form shall mean the preferred form for making modifications,+ including but not limited to software source code, documentation+ source, and configuration files.++ "Object" form shall mean any form resulting from mechanical+ transformation or translation of a Source form, including but+ not limited to compiled object code, generated documentation,+ and conversions to other media types.++ "Work" shall mean the work of authorship, whether in Source or+ Object form, made available under the License, as indicated by a+ copyright notice that is included in or attached to the work+ (an example is provided in the Appendix below).++ "Derivative Works" shall mean any work, whether in Source or Object+ form, that is based on (or derived from) the Work and for which the+ editorial revisions, annotations, elaborations, or other modifications+ represent, as a whole, an original work of authorship. For the purposes+ of this License, Derivative Works shall not include works that remain+ separable from, or merely link (or bind by name) to the interfaces of,+ the Work and Derivative Works thereof.++ "Contribution" shall mean any work of authorship, including+ the original version of the Work and any modifications or additions+ to that Work or Derivative Works thereof, that is intentionally+ submitted to Licensor for inclusion in the Work by the copyright owner+ or by an individual or Legal Entity authorized to submit on behalf of+ the copyright owner. For the purposes of this definition, "submitted"+ means any form of electronic, verbal, or written communication sent+ to the Licensor or its representatives, including but not limited to+ communication on electronic mailing lists, source code control systems,+ and issue tracking systems that are managed by, or on behalf of, the+ Licensor for the purpose of discussing and improving the Work, but+ excluding communication that is conspicuously marked or otherwise+ designated in writing by the copyright owner as "Not a Contribution."++ "Contributor" shall mean Licensor and any individual or Legal Entity+ on behalf of whom a Contribution has been received by Licensor and+ subsequently incorporated within the Work.++ 2. Grant of Copyright License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ copyright license to reproduce, prepare Derivative Works of,+ publicly display, publicly perform, sublicense, and distribute the+ Work and such Derivative Works in Source or Object form.++ 3. Grant of Patent License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ (except as stated in this section) patent license to make, have made,+ use, offer to sell, sell, import, and otherwise transfer the Work,+ where such license applies only to those patent claims licensable+ by such Contributor that are necessarily infringed by their+ Contribution(s) alone or by combination of their Contribution(s)+ with the Work to which such Contribution(s) was submitted. If You+ institute patent litigation against any entity (including a+ cross-claim or counterclaim in a lawsuit) alleging that the Work+ or a Contribution incorporated within the Work constitutes direct+ or contributory patent infringement, then any patent licenses+ granted to You under this License for that Work shall terminate+ as of the date such litigation is filed.++ 4. Redistribution. You may reproduce and distribute copies of the+ Work or Derivative Works thereof in any medium, with or without+ modifications, and in Source or Object form, provided that You+ meet the following conditions:++ (a) You must give any other recipients of the Work or+ Derivative Works a copy of this License; and++ (b) You must cause any modified files to carry prominent notices+ stating that You changed the files; and++ (c) You must retain, in the Source form of any Derivative Works+ that You distribute, all copyright, patent, trademark, and+ attribution notices from the Source form of the Work,+ excluding those notices that do not pertain to any part of+ the Derivative Works; and++ (d) If the Work includes a "NOTICE" text file as part of its+ distribution, then any Derivative Works that You distribute must+ include a readable copy of the attribution notices contained+ within such NOTICE file, excluding those notices that do not+ pertain to any part of the Derivative Works, in at least one+ of the following places: within a NOTICE text file distributed+ as part of the Derivative Works; within the Source form or+ documentation, if provided along with the Derivative Works; or,+ within a display generated by the Derivative Works, if and+ wherever such third-party notices normally appear. The contents+ of the NOTICE file are for informational purposes only and+ do not modify the License. You may add Your own attribution+ notices within Derivative Works that You distribute, alongside+ or as an addendum to the NOTICE text from the Work, provided+ that such additional attribution notices cannot be construed+ as modifying the License.++ You may add Your own copyright statement to Your modifications and+ may provide additional or different license terms and conditions+ for use, reproduction, or distribution of Your modifications, or+ for any such Derivative Works as a whole, provided Your use,+ reproduction, and distribution of the Work otherwise complies with+ the conditions stated in this License.++ 5. Submission of Contributions. Unless You explicitly state otherwise,+ any Contribution intentionally submitted for inclusion in the Work+ by You to the Licensor shall be under the terms and conditions of+ this License, without any additional terms or conditions.+ Notwithstanding the above, nothing herein shall supersede or modify+ the terms of any separate license agreement you may have executed+ with Licensor regarding such Contributions.++ 6. Trademarks. This License does not grant permission to use the trade+ names, trademarks, service marks, or product names of the Licensor,+ except as required for reasonable and customary use in describing the+ origin of the Work and reproducing the content of the NOTICE file.++ 7. Disclaimer of Warranty. Unless required by applicable law or+ agreed to in writing, Licensor provides the Work (and each+ Contributor provides its Contributions) on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or+ implied, including, without limitation, any warranties or conditions+ of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A+ PARTICULAR PURPOSE. You are solely responsible for determining the+ appropriateness of using or redistributing the Work and assume any+ risks associated with Your exercise of permissions under this License.++ 8. Limitation of Liability. In no event and under no legal theory,+ whether in tort (including negligence), contract, or otherwise,+ unless required by applicable law (such as deliberate and grossly+ negligent acts) or agreed to in writing, shall any Contributor be+ liable to You for damages, including any direct, indirect, special,+ incidental, or consequential damages of any character arising as a+ result of this License or out of the use or inability to use the+ Work (including but not limited to damages for loss of goodwill,+ work stoppage, computer failure or malfunction, or any and all+ other commercial damages or losses), even if such Contributor+ has been advised of the possibility of such damages.++ 9. Accepting Warranty or Additional Liability. While redistributing+ the Work or Derivative Works thereof, You may choose to offer,+ and charge a fee for, acceptance of support, warranty, indemnity,+ or other liability obligations and/or rights consistent with this+ License. However, in accepting such obligations, You may act only+ on Your own behalf and on Your sole responsibility, not on behalf+ of any other Contributor, and only if You agree to indemnify,+ defend, and hold each Contributor harmless for any liability+ incurred by, or claims asserted against, such Contributor by reason+ of your accepting any such warranty or additional liability.++ END OF TERMS AND CONDITIONS
+ README.md view
@@ -0,0 +1,29 @@+# ImpSpec++__Imperative specification__.++Let a little imp help you discover all the bugs in your stateful Haskell program.++## Overview++`ImpSpec` is a testing library that is build on top of+[`hspec`](https://hackage.haskell.org/package/hspec) and+[`QuickCheck`](https://hackage.haskell.org/package/QuickCheck). It was designed for easier+testing of stateful applications.++## Status++| Github Actions | Coveralls | Hackage | Nightly | LTS |+|:--------------:|:---------:|:-------:|:-------:|:---:|+| [![Build Status][GA-badge]][GA-link] | [![Coverage Status][Coveralls-badge]][Coveralls-link] | [![Hackage][Hackage-badge]][Hackage-link] | [![Nightly][Nightly-badge]][Nightly-link] | [![LTS][LTS-badge]][LTS-link]++[GA-badge]: https://github.com/lehins/ImpSpec/workflows/CI/badge.svg+[GA-link]: https://github.com/lehins/ImpSpec/actions+[Coveralls-badge]: https://coveralls.io/repos/github/lehins/ImpSpec/badge.svg?branch=master+[Coveralls-link]: https://coveralls.io/github/lehins/ImpSpec?branch=master+[Hackage-badge]: https://img.shields.io/hackage/v/ImpSpec.svg+[Hackage-link]: https://hackage.haskell.org/package/ImpSpec+[Nightly-badge]: https://www.stackage.org/package/ImpSpec/badge/nightly+[Nightly-link]: https://www.stackage.org/nightly/package/ImpSpec+[LTS-badge]: https://www.stackage.org/package/ImpSpec/badge/lts+[LTS-link]: https://www.stackage.org/lts/package/ImpSpec
+ Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple++main = defaultMain
+ src/Test/ImpSpec.hs view
@@ -0,0 +1,8 @@+module Test.ImpSpec (module X) where++import Test.Hspec as X (Spec, SpecWith, describe, fdescribe, fit, it, xdescribe, xit)+import Test.Hspec.QuickCheck as X (fprop, prop, xprop)+import Test.ImpSpec.Expectations.Lifted as X+import Test.ImpSpec.Internal as X+import Test.ImpSpec.Main as X+import Test.ImpSpec.Random as X
+ src/Test/ImpSpec/Expectations.hs view
@@ -0,0 +1,163 @@+{-# LANGUAGE ImplicitParams #-}++module Test.ImpSpec.Expectations (+ -- * Expectations++ -- ** Common+ assertBool,+ assertFailure,+ expectationFailure,+ shouldBe,+ shouldSatisfy,+ shouldStartWith,+ shouldEndWith,+ shouldContain,+ shouldMatchList,+ shouldReturn,+ shouldNotBe,+ shouldNotSatisfy,+ shouldNotContain,+ shouldNotReturn,+ shouldThrow,+ Selector,++ -- ** Custom+ assertColorFailure,++ -- *** Either+ shouldBeRight,+ shouldBeLeft,+ expectRight,+ expectRightDeep,+ expectRightDeep_,+ expectLeft,+ expectLeftDeep,+ expectLeftDeep_,++ -- *** Maybe+ shouldBeJust,+ expectJust,+ expectJustDeep,+ expectJustDeep_,+ expectNothing,++ -- * CallStack helpers+ callStackToLocation,+ srcLocToLocation,+) where++import Control.DeepSeq (NFData)+import Control.Monad (void, (>=>))+import GHC.Stack (CallStack, HasCallStack, SrcLoc (..), getCallStack)+import Test.HUnit.Base (assertBool, assertFailure)+import Test.Hspec (+ Expectation,+ Selector,+ expectationFailure,+ shouldBe,+ shouldContain,+ shouldEndWith,+ shouldMatchList,+ shouldNotBe,+ shouldNotContain,+ shouldNotReturn,+ shouldNotSatisfy,+ shouldReturn,+ shouldSatisfy,+ shouldStartWith,+ shouldThrow,+ )+import Test.Hspec.Core.Spec (FailureReason (ColorizedReason), Location (..), ResultStatus (Failure))+import UnliftIO.Exception (evaluateDeep, throwIO)++infix 1 `shouldBeRight`+ , `shouldBeLeft`++-- | Similar to `assertFailure`, except hspec will not interfer with any escape sequences+-- that indicate color output.+assertColorFailure :: HasCallStack => String -> IO a+assertColorFailure msg =+ throwIO $ Failure (callStackToLocation ?callStack) (ColorizedReason msg)++-- | Return value on the `Right` and fail otherwise.+--+-- Difference from @`shouldSatisfy` action `Data.Either.isRight`@ in that `expectRight`+-- will force the content of the `Right` to WHNF and return it. This expectation will also+-- show the content of the `Left` when expectation fails.+expectRight :: (HasCallStack, Show a) => Either a b -> IO b+expectRight (Right r) = pure $! r+expectRight (Left l) = assertFailure $ "Expected Right, got Left:\n" ++ show l++-- | Same as `expectRight`, but also evaluate the returned value to NF+expectRightDeep :: (HasCallStack, Show a, NFData b) => Either a b -> IO b+expectRightDeep = expectRight >=> evaluateDeep++-- | Same as `expectRightDeep`, but discards the result+expectRightDeep_ :: (HasCallStack, Show a, NFData b) => Either a b -> IO ()+expectRightDeep_ = void . expectRightDeep++-- | Same as `shouldBe`, except it checks that the value is `Right`+shouldBeRight :: (HasCallStack, Show a, Show b, Eq b) => Either a b -> b -> Expectation+shouldBeRight e x = expectRight e >>= (`shouldBe` x)++-- | Return value on the `Left` an fail otherwise+--+-- Difference from @`shouldSatisfy` action `Data.Either.isLeft`@ in that `expectLeft` will+-- force the content of the `Left` to WHNF and and return it. This expectation will also+-- show the content of the `Right` when expectation fails.+expectLeft :: (HasCallStack, Show b) => Either a b -> IO a+expectLeft (Left l) = pure $! l+expectLeft (Right r) = assertFailure $ "Expected Left, got Right:\n" ++ show r++-- | Same as `expectLeft`, but also evaluate the returned value to NF+expectLeftDeep :: (HasCallStack, NFData a, Show b) => Either a b -> IO a+expectLeftDeep = expectLeft >=> evaluateDeep++-- | Same as `expectLeftDeep`, but discards the result+expectLeftDeep_ :: (HasCallStack, NFData a, Show b) => Either a b -> IO ()+expectLeftDeep_ = void . expectLeftDeep++-- | Same as `shouldBe`, except it checks that the value is `Left`+shouldBeLeft :: (HasCallStack, Show a, Eq a, Show b) => Either a b -> a -> Expectation+shouldBeLeft e x = expectLeft e >>= (`shouldBe` x)++-- | Same as `shouldBe`, except it checks that the value is `Just`+shouldBeJust :: (HasCallStack, Show a, Eq a) => Maybe a -> a -> Expectation+shouldBeJust e x = expectJust e >>= (`shouldBe` x)++-- | Return value from the `Just` an fail otherwise+--+-- Difference from @`shouldSatisfy` action `isJust`@ in that `expectJust` will force the+-- content of the `Just` to WHNF and it will also return it.+expectJust :: HasCallStack => Maybe a -> IO a+expectJust (Just x) = pure $! x+expectJust Nothing = assertFailure "Expected Just, got Nothing"++-- | Same as `expectJust`, but will force the value to NF+expectJustDeep :: (HasCallStack, NFData a) => Maybe a -> IO a+expectJustDeep = expectJust >=> evaluateDeep++-- | Same as `expectJustDeep`, but will discard the forced contents of `Just`+expectJustDeep_ :: (HasCallStack, NFData a) => Maybe a -> IO ()+expectJustDeep_ = void . expectJustDeep++-- | Same as @`shouldSatisfy` action `Data.Maybe.isNothing`@+expectNothing :: (HasCallStack, Show a) => Maybe a -> IO ()+expectNothing (Just x) = assertFailure $ "Expected Nothing, got Just: " ++ show x+expectNothing Nothing = pure ()++-- | Convert the top call from the `CallStack` to hspec's `Location`+callStackToLocation :: CallStack -> Maybe Location+callStackToLocation cs =+ case getCallStack cs of+ [] -> Nothing+ (_, loc) : _ -> Just $ srcLocToLocation loc++-- | Convert `SrcLoc` to hspec's `Location`+srcLocToLocation :: SrcLoc -> Location+srcLocToLocation loc =+ Location+ { locationFile = srcLocFile loc+ , locationLine = srcLocStartLine loc+ , locationColumn = srcLocStartCol loc+ }
+ src/Test/ImpSpec/Expectations/Lifted.hs view
@@ -0,0 +1,148 @@+module Test.ImpSpec.Expectations.Lifted (+ -- * Lifted Expectations+ io,++ -- ** Common+ assertBool,+ assertFailure,+ expectationFailure,+ shouldBe,+ shouldSatisfy,+ shouldStartWith,+ shouldEndWith,+ shouldContain,+ shouldMatchList,+ shouldReturn,+ shouldNotBe,+ shouldNotSatisfy,+ shouldNotContain,+ shouldNotReturn,+ shouldThrow,+ IO.Selector,++ -- ** Custom+ assertColorFailure,++ -- *** Either+ shouldBeRight,+ shouldBeLeft,+ expectRight,+ expectRightDeep,+ expectRightDeep_,+ expectLeft,+ expectLeftDeep,+ expectLeftDeep_,++ -- *** Maybe+ shouldBeJust,+ expectJust,+ expectJustDeep,+ expectJustDeep_,+ expectNothing,+) where++import Control.DeepSeq (NFData)+import GHC.Stack (HasCallStack)+import Test.Hspec.Expectations.Lifted (+ expectationFailure,+ shouldBe,+ shouldContain,+ shouldEndWith,+ shouldMatchList,+ shouldNotBe,+ shouldNotContain,+ shouldNotReturn,+ shouldNotSatisfy,+ shouldReturn,+ shouldSatisfy,+ shouldStartWith,+ )+import qualified Test.ImpSpec.Expectations as IO+import UnliftIO (Exception, MonadIO (liftIO), MonadUnliftIO, withRunInIO)++infix 1 `shouldThrow`+ , `shouldBeRight`+ , `shouldBeLeft`++-- | Enforce the type of expectation+--+-- Useful with polymorphic expectations that are defined below.+--+-- ===__Example__+--+-- Because `shouldBeExpr` is polymorphic in `m`, compiler will choke with a unification+-- error. This is due to the fact that hspec's `it` expects a polymorphic `Example`.+--+-- > it "MyTest" $ do+-- > "foo" `shouldBeExpr` "bar"+--+-- However, this is easily solved by `io`:+--+-- > it "MyTest" $ io $ do+-- > "foo" `shouldBeExpr` "bar"+io :: IO a -> IO a+io = id++-- | Just like `expectationFailure`, but does not force the return type to unit. Lifted+-- version of `H.assertFailure`+assertFailure :: (HasCallStack, MonadIO m) => String -> m a+assertFailure = liftIO . IO.assertFailure++assertColorFailure :: (HasCallStack, MonadIO m) => String -> m a+assertColorFailure = liftIO . IO.assertColorFailure++-- | Lifted version of `H.assertBool`+assertBool :: (HasCallStack, MonadIO m) => String -> Bool -> m ()+assertBool msg = liftIO . IO.assertBool msg++-- | Lifted version of `shouldThrow`.+shouldThrow :: (HasCallStack, Exception e, MonadUnliftIO m) => m a -> IO.Selector e -> m ()+shouldThrow f s = withRunInIO $ \run -> IO.shouldThrow (run f) s++-- | Return value on the `Right` and fail otherwise. Lifted version of `H.expectRight`.+expectRight :: (HasCallStack, Show a, MonadIO m) => Either a b -> m b+expectRight = liftIO . IO.expectRight++-- | Same as `expectRight`, but also evaluate the returned value to NF+expectRightDeep :: (HasCallStack, Show a, NFData b, MonadIO m) => Either a b -> m b+expectRightDeep = liftIO . IO.expectRightDeep++-- | Same as `expectRightDeep`, but discards the result+expectRightDeep_ :: (HasCallStack, Show a, NFData b, MonadIO m) => Either a b -> m ()+expectRightDeep_ = liftIO . IO.expectRightDeep_++-- | Same as `shouldBe`, except it checks that the value is `Right`+shouldBeRight :: (HasCallStack, Show a, Show b, Eq b, MonadIO m) => Either a b -> b -> m ()+shouldBeRight e = liftIO . IO.shouldBeRight e++-- | Return value on the `Left` and fail otherwise+expectLeft :: (HasCallStack, Show b, MonadIO m) => Either a b -> m a+expectLeft = liftIO . IO.expectLeft++-- | Same as `expectLeftDeep`, but discards the result+expectLeftDeep_ :: (HasCallStack, NFData a, Show b, MonadIO m) => Either a b -> m ()+expectLeftDeep_ = liftIO . IO.expectLeftDeep_++-- | Same as `expectLeft`, but also evaluate the returned value to NF+expectLeftDeep :: (HasCallStack, NFData a, Show b, MonadIO m) => Either a b -> m a+expectLeftDeep = liftIO . IO.expectLeftDeep++-- | Same as `shouldBe`, except it checks that the value is `Left`+shouldBeLeft :: (HasCallStack, Show a, Eq a, Show b, MonadIO m) => Either a b -> a -> m ()+shouldBeLeft e x = liftIO $ e `IO.shouldBeLeft` x++-- | Same as `shouldBe`, except it checks that the value is `Just`+shouldBeJust :: (HasCallStack, Show a, Eq a, MonadIO m) => Maybe a -> a -> m ()+shouldBeJust e x = liftIO $ e `IO.shouldBeJust` x++expectJust :: (HasCallStack, MonadIO m) => Maybe a -> m a+expectJust = liftIO . IO.expectJust++expectJustDeep :: (HasCallStack, NFData a, MonadIO m) => Maybe a -> m a+expectJustDeep = liftIO . IO.expectJustDeep++expectJustDeep_ :: (HasCallStack, NFData a, MonadIO m) => Maybe a -> m ()+expectJustDeep_ = liftIO . IO.expectJustDeep_++expectNothing :: (HasCallStack, Show a, MonadIO m) => Maybe a -> m ()+expectNothing = liftIO . IO.expectNothing
+ src/Test/ImpSpec/Internal.hs view
@@ -0,0 +1,393 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilyDependencies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Test.ImpSpec.Internal where++import Control.DeepSeq (NFData)+import Control.Monad (void)+import qualified Control.Monad.Fail as Fail+import Control.Monad.Reader (MonadReader (..), ReaderT (..), asks)+import Control.Monad.State.Strict (MonadState (..))+import Data.Kind (Type)+import Data.Maybe (fromMaybe)+import Data.Proxy (Proxy (..))+import Data.Text (Text)+import qualified Data.Text.Lazy as TL+import GHC.Stack (CallStack, HasCallStack, SrcLoc (..), getCallStack)+import Prettyprinter (+ Doc,+ Pretty (..),+ annotate,+ defaultLayoutOptions,+ hcat,+ indent,+ layoutPretty,+ line,+ vsep,+ )+import Prettyprinter.Render.Terminal (AnsiStyle, Color (..), color, renderLazy)+import System.Random (randomR, split)+import System.Random.Stateful (IOGenM, applyIOGen, newIOGenM)+import Test.HUnit.Lang (FailureReason (..), HUnitFailure (..))+import Test.Hspec (Spec, SpecWith, beforeAll, beforeAllWith)+import Test.Hspec.Core.Spec (+ Example (..),+ Result (..),+ paramsQuickCheckArgs,+ )+import qualified Test.Hspec.Core.Spec as H+import Test.ImpSpec.Expectations+import Test.ImpSpec.Random+import Test.QuickCheck (Arbitrary, Args (chatty, replay), Testable (..), counterexample, ioProperty)+import Test.QuickCheck.Gen (Gen (..))+import Test.QuickCheck.GenT (MonadGen (..))+import Test.QuickCheck.Random (QCGen (..), integerVariant, mkQCGen)+import UnliftIO (MonadIO (liftIO), MonadUnliftIO (..))+import UnliftIO.Exception (+ Exception (..),+ SomeException (..),+ catchAny,+ catchAnyDeep,+ throwIO,+ )+import UnliftIO.IORef+#if !MIN_VERSION_base(4,11,0)+import Data.Monoid ((<>))+#endif++data ImpState t = ImpState+ { impStateSpecState :: !(ImpSpecState t)+ , impStateLog :: !(Doc AnsiStyle)+ }++data ImpEnv t = ImpEnv+ { impEnvSpecEnv :: !(ImpSpecEnv t)+ , impEnvStateRef :: !(IORef (ImpState t))+ , impEnvQCGenRef :: !(IOGenM QCGen)+ , impEnvQCSize :: !Int+ }++class ImpSpec t where+ type ImpSpecEnv t = (r :: Type) | r -> t+ type ImpSpecEnv t = Proxy t+ type ImpSpecState t = (r :: Type) | r -> t+ type ImpSpecState t = Proxy t++ impInitIO :: QCGen -> IO (ImpInit t)+ default impInitIO :: (ImpSpecEnv t ~ Proxy t, ImpSpecState t ~ Proxy t) => QCGen -> IO (ImpInit t)+ impInitIO _ = pure $ ImpInit Proxy Proxy++ -- | This will be the very first action that will run in all `ImpM` specs.+ impPrepAction :: ImpM t ()+ impPrepAction = pure ()++data ImpInit t = ImpInit+ { impInitEnv :: ImpSpecEnv t+ , impInitState :: ImpSpecState t+ }+deriving instance (Eq (ImpSpecEnv t), Eq (ImpSpecState t)) => Eq (ImpInit t)+deriving instance (Ord (ImpSpecEnv t), Ord (ImpSpecState t)) => Ord (ImpInit t)+deriving instance (Show (ImpSpecEnv t), Show (ImpSpecState t)) => Show (ImpInit t)++-- | Stores extra information about the failure of the unit test+data ImpException = ImpException+ { ieAnnotation :: [Doc AnsiStyle]+ -- ^ Description of the IO action that caused the failure+ , ieThrownException :: SomeException+ -- ^ Exception that caused the test to fail+ }+ deriving (Show)++instance Exception ImpException where+ displayException = ansiDocToString . prettyImpException++prettyImpException :: ImpException -> Doc AnsiStyle+prettyImpException (ImpException ann e) =+ vsep $+ mconcat+ [ ["Annotations:"]+ , zipWith indent [0, 2 ..] ann+ , ["Failed with Exception:", indent 4 $ pretty (displayException e)]+ ]++newtype ImpM t a = ImpM {unImpM :: ReaderT (ImpEnv t) IO a}+ deriving+ ( Functor+ , Applicative+ , Monad+ , MonadIO+ , MonadUnliftIO+ )++instance env ~ ImpSpecEnv t => MonadReader env (ImpM t) where+ ask = impEnvSpecEnv <$> ImpM ask+ local f = ImpM . local (\e -> e{impEnvSpecEnv = f (impEnvSpecEnv e)}) . unImpM++instance Fail.MonadFail (ImpM t) where+ fail = liftIO . assertFailure++instance s ~ ImpSpecState t => MonadState s (ImpM t) where+ state f = do+ ImpEnv{impEnvStateRef} <- ImpM ask+ curState <- readIORef impEnvStateRef+ let !(result, !newSpecState) = f $ impStateSpecState curState+ writeIORef impEnvStateRef (curState{impStateSpecState = newSpecState})+ pure result+ get = fmap impStateSpecState . readIORef . impEnvStateRef =<< ImpM ask++instance MonadGen (ImpM t) where+ liftGen (MkGen f) = do+ qcSize <- ImpM $ asks impEnvQCSize+ qcGen <- applyQCGen split+ pure $ f qcGen qcSize+ variant n action = do+ applyQCGen $ \qcGen -> ((), integerVariant (toInteger n) qcGen)+ action+ sized f = ImpM (asks impEnvQCSize) >>= f+ resize n (ImpM f) = ImpM $ local (\env -> env{impEnvQCSize = n}) f+ choose r = applyQCGen (randomR r)++instance HasStatefulGen (IOGenM QCGen) (ImpM t) where+ askStatefulGen = ImpM $ asks impEnvQCGenRef++instance (ImpSpec t, Testable a) => Testable (ImpM t a) where+ property m = property $ MkGen $ \qcGen qcSize ->+ ioProperty $ do+ let (qcGen1, qcGen2) = split qcGen+ impInit <- impInitIO qcGen1+ evalImpM (Just qcGen2) (Just qcSize) impInit m++instance (ImpSpec t, Testable p) => Example (ImpM t p) where+ type Arg (ImpM t p) = ImpInit t++ evaluateExample impTest = evaluateExample (\() -> impTest)++instance (Arbitrary a, Show a, ImpSpec t, Testable p) => Example (a -> ImpM t p) where+ type Arg (a -> ImpM t p) = ImpInit t++ evaluateExample impTest params hook progressCallback = do+ let runImpExample impInit = property $ \x -> do+ let args = paramsQuickCheckArgs params+ mQC = replay (paramsQuickCheckArgs params)++ (r, testable, logs) <- evalImpM (fst <$> mQC) (snd <$> mQC) impInit $ do+ t <- impTest x+ qcSize <- ImpM $ asks impEnvQCSize+ qcGen <- applyQCGen split+ logs <- getLogs+ pure (Just (qcGen, qcSize), t, logs)+ let params' = params{paramsQuickCheckArgs = args{replay = r, chatty = False}}+ res <-+ evaluateExample+ (counterexample (ansiDocToString logs) testable)+ params'+ (\f -> hook (\_st -> f ()))+ progressCallback+ void $ throwIO $ resultStatus res+ evaluateExample runImpExample params hook progressCallback++applyQCGen :: (QCGen -> (b, QCGen)) -> ImpM t b+applyQCGen f = do+ qcGenRef <- ImpM $ asks impEnvQCGenRef+ applyIOGen f qcGenRef++getLogs :: ImpM t (Doc AnsiStyle)+getLogs = do+ ref <- ImpM $ asks impEnvStateRef+ impStateLog <$> readIORef ref++modifyLogs :: (Doc AnsiStyle -> Doc AnsiStyle) -> ImpM t ()+modifyLogs f = do+ ref <- ImpM $ asks impEnvStateRef+ modifyIORef ref $ \s -> s{impStateLog = f (impStateLog s)}++-- | Override the QuickCheck generator using a fixed seed.+impSetSeed :: Int -> ImpM t ()+impSetSeed seed = applyQCGen $ \_ -> ((), mkQCGen seed)++evalImpGenM :: ImpSpec t => ImpInit t -> ImpM t b -> Gen (IO b)+evalImpGenM impInit = fmap (fmap fst) . runImpGenM impInit++evalImpM :: ImpSpec t => Maybe QCGen -> Maybe Int -> ImpInit t -> ImpM t b -> IO b+evalImpM mQCGen mQCSize impInit = fmap fst . runImpM mQCGen mQCSize impInit++execImpGenM :: ImpSpec t => ImpInit t -> ImpM t b -> Gen (IO (ImpState t))+execImpGenM impInit = fmap (fmap snd) . runImpGenM impInit++execImpM ::+ ImpSpec t =>+ Maybe QCGen ->+ Maybe Int ->+ ImpInit t ->+ ImpM t b ->+ IO (ImpState t)+execImpM mQCGen mQCSize impInit = fmap snd . runImpM mQCGen mQCSize impInit++runImpGenM_ :: ImpSpec t => ImpInit t -> ImpM t b -> Gen (IO ())+runImpGenM_ impInit = fmap void . runImpGenM impInit++runImpM_ :: ImpSpec t => Maybe QCGen -> Maybe Int -> ImpInit t -> ImpM t b -> IO ()+runImpM_ mQCGen mQCSize impInit = void . runImpM mQCGen mQCSize impInit++runImpGenM :: ImpSpec t => ImpInit t -> ImpM t b -> Gen (IO (b, ImpState t))+runImpGenM impInit m =+ MkGen $ \qcGen qcSize -> runImpM (Just qcGen) (Just qcSize) impInit m++runImpM ::+ ImpSpec t =>+ Maybe QCGen ->+ Maybe Int ->+ ImpInit t ->+ ImpM t b ->+ IO (b, ImpState t)+runImpM mQCGen mQCSize ImpInit{impInitEnv, impInitState} action = do+ let qcSize = fromMaybe 30 mQCSize+ qcGen = fromMaybe (mkQCGen 2024) mQCGen+ ioRef <-+ newIORef $+ ImpState+ { impStateSpecState = impInitState+ , impStateLog = mempty+ }+ qcGenRef <- newIOGenM qcGen+ let+ env =+ ImpEnv+ { impEnvSpecEnv = impInitEnv+ , impEnvStateRef = ioRef+ , impEnvQCGenRef = qcGenRef+ , impEnvQCSize = qcSize+ }+ res <-+ runReaderT (unImpM (impPrepAction >> action)) env `catchAny` \exc -> do+ logs <- impStateLog <$> readIORef ioRef+ let x <?> my = case my of+ Nothing -> x+ Just y -> x ++ [pretty y]+ uncaughtException header excThrown =+ H.ColorizedReason $+ ansiDocToString $+ vsep $+ header ++ [pretty $ "Uncaught Exception: " <> displayException excThrown]+ fromHUnitFailure header (HUnitFailure mSrcLoc failReason) =+ case failReason of+ Reason msg ->+ H.Failure (srcLocToLocation <$> mSrcLoc) $+ H.ColorizedReason $+ ansiDocToString $+ vsep $+ header ++ [annotate (color Red) (pretty msg)]+ ExpectedButGot mMsg expected got ->+ H.Failure (srcLocToLocation <$> mSrcLoc) $+ H.ExpectedButGot (Just (ansiDocToString $ vsep (header <?> mMsg))) expected got+ adjustFailureReason header = \case+ H.Failure mLoc failureReason ->+ H.Failure mLoc $+ case failureReason of+ H.NoReason ->+ H.ColorizedReason $ ansiDocToString $ vsep $ header ++ [annotate (color Red) "NoReason"]+ H.Reason msg ->+ H.ColorizedReason $ ansiDocToString $ vsep $ header ++ [annotate (color Red) (pretty msg)]+ H.ColorizedReason msg ->+ H.ColorizedReason $ ansiDocToString $ vsep $ header ++ [pretty msg]+ H.ExpectedButGot mPreface expected actual ->+ H.ExpectedButGot (Just (ansiDocToString $ vsep (header <?> mPreface))) expected actual+ H.Error mInfo excThrown -> uncaughtException (header <?> mInfo) excThrown+ result -> result+ newExc+ | Just hUnitExc <- fromException exc = fromHUnitFailure [logs] hUnitExc+ | Just hspecFailure <- fromException exc = adjustFailureReason [logs] hspecFailure+ | Just (ImpException ann excThrown) <- fromException exc =+ let annLen = length ann+ header =+ logs+ : [ let prefix+ | annLen <= 1 = "╺╸"+ | n <= 0 = "┏╸"+ | n + 1 == annLen = indent (n - 1) "┗━╸"+ | otherwise = indent (n - 1) "┗┳╸"+ in annotate (color Red) prefix <> annotate (color Yellow) a+ | (n, a) <- zip [0 ..] ann+ ]+ ++ [""]+ in case fromException excThrown of+ Just hUnitExc -> fromHUnitFailure header hUnitExc+ Nothing ->+ case fromException excThrown of+ Just hspecFailure -> adjustFailureReason header hspecFailure+ Nothing -> H.Failure Nothing $ uncaughtException header excThrown+ | otherwise = H.Failure Nothing $ uncaughtException [logs] exc+ throwIO newExc+ endState <- readIORef ioRef+ pure (res, endState)++ansiDocToString :: Doc AnsiStyle -> String+ansiDocToString = TL.unpack . renderLazy . layoutPretty defaultLayoutOptions++withImpInit :: ImpSpec t => SpecWith (ImpInit t) -> Spec+withImpInit = beforeAll (impInitIO (mkQCGen 2024))++modifyImpInit :: (ImpInit t -> ImpInit t) -> SpecWith (ImpInit t) -> SpecWith (ImpInit t)+modifyImpInit f = beforeAllWith (pure . f)++-- | Annotation for when failure happens. All the logging done within annotation will be+-- discarded if there no failures within the annotation.+impAnn :: NFData a => String -> ImpM t a -> ImpM t a+impAnn msg = impAnnDoc (pretty msg)++impAnnDoc :: NFData a => Doc AnsiStyle -> ImpM t a -> ImpM t a+impAnnDoc msg m = do+ logs <- getLogs+ res <- catchAnyDeep m $ \exc ->+ throwIO $+ case fromException exc of+ Just (ImpException ann origExc) -> ImpException (msg : ann) origExc+ Nothing -> ImpException [msg] exc+ modifyLogs (const logs)+ pure res++-- | Adds a source location and Doc to the log, which are only shown if the test fails+logWithCallStack :: CallStack -> Doc AnsiStyle -> ImpM t ()+logWithCallStack callStack entry =+ modifyLogs (<> stack <> line <> indent 2 entry <> line)+ where+ prettySrcLoc' SrcLoc{srcLocModule, srcLocStartLine} =+ hcat+ [ annotate (color c) d+ | (c, d) <-+ [ (Yellow, "[")+ , (Blue, pretty srcLocModule)+ , (Yellow, ":")+ , (Magenta, pretty srcLocStartLine)+ , (Yellow, "]")+ ]+ ]+ prefix n = if n <= 0 then "" else indent (n - 1) "└"+ stack =+ vsep+ [prefix n <> prettySrcLoc' loc | (n, (_, loc)) <- zip [0, 2 ..] . reverse $ getCallStack callStack]++-- | Adds a Doc to the log, which is only shown if the test fails+logDoc :: HasCallStack => Doc AnsiStyle -> ImpM t ()+logDoc = logWithCallStack ?callStack++-- | Adds a Text to the log, which is only shown if the test fails+logText :: HasCallStack => Text -> ImpM t ()+logText = logWithCallStack ?callStack . pretty++-- | Adds a String to the log, which is only shown if the test fails+logString :: HasCallStack => String -> ImpM t ()+logString = logWithCallStack ?callStack . pretty
+ src/Test/ImpSpec/Main.hs view
@@ -0,0 +1,31 @@+module Test.ImpSpec.Main (+ impSpecMain,+ impSpecConfig,+ impSpecMainWithConfig,+) where++import System.IO (+ BufferMode (LineBuffering),+ hSetBuffering,+ hSetEncoding,+ stdout,+ utf8,+ )+import Test.Hspec+import Test.Hspec.Core.Runner (ColorMode (ColorAlways), Config (..), defaultConfig, hspecWith)++impSpecConfig :: Config+impSpecConfig =+ defaultConfig+ { configTimes = True+ , configColorMode = ColorAlways+ }++impSpecMainWithConfig :: Config -> Spec -> IO ()+impSpecMainWithConfig conf spec = do+ hSetBuffering stdout LineBuffering+ hSetEncoding stdout utf8+ hspecWith conf spec++impSpecMain :: Spec -> IO ()+impSpecMain = impSpecMainWithConfig impSpecConfig
+ src/Test/ImpSpec/Random.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module Test.ImpSpec.Random where++import Control.Monad (replicateM)+import Control.Monad.Reader (MonadReader (ask), ReaderT (..))+import Data.ByteString (ByteString)+import Data.ByteString.Short (ShortByteString)+import qualified System.Random.Stateful as R+import qualified Test.QuickCheck as QC (Arbitrary (arbitrary))+import Test.QuickCheck.GenT (MonadGen (liftGen))++class R.StatefulGen g m => HasStatefulGen g m | m -> g where+ askStatefulGen :: m g+ default askStatefulGen :: MonadReader g m => m g+ askStatefulGen = ask++class HasGenEnv env g | env -> g where+ getGenEnv :: env -> g++instance HasGenEnv g g where+ getGenEnv = id++instance+ (HasGenEnv env g, R.StatefulGen g (ReaderT env m), Monad m) =>+ HasStatefulGen g (ReaderT env m)+ where+ askStatefulGen = ReaderT (pure . getGenEnv)++uniformM ::+ ( HasStatefulGen g m+ , R.Uniform a+ ) =>+ m a+uniformM = askStatefulGen >>= R.uniformM+{-# INLINE uniformM #-}++uniformRM ::+ ( HasStatefulGen g m+ , R.UniformRange a+ ) =>+ (a, a) ->+ m a+uniformRM r = askStatefulGen >>= R.uniformRM r+{-# INLINE uniformRM #-}++uniformListM ::+ ( HasStatefulGen g m+ , R.Uniform a+ ) =>+ Int ->+ m [a]+uniformListM n = askStatefulGen >>= R.uniformListM n+{-# INLINE uniformListM #-}++uniformListRM ::+ (HasStatefulGen g m, R.UniformRange a) =>+ (a, a) ->+ Int ->+ m [a]+uniformListRM r n = askStatefulGen >>= replicateM n . R.uniformRM r+{-# INLINE uniformListRM #-}++uniformByteStringM :: HasStatefulGen a m => Int -> m ByteString+uniformByteStringM n = askStatefulGen >>= R.uniformByteStringM n+{-# INLINE uniformByteStringM #-}++uniformShortByteStringM :: HasStatefulGen a m => Int -> m ShortByteString+uniformShortByteStringM n = askStatefulGen >>= R.uniformShortByteString n+{-# INLINE uniformShortByteStringM #-}++-- | Lifted version of `QC.arbitrary`.+arbitrary :: (QC.Arbitrary a, MonadGen m) => m a+arbitrary = liftGen QC.arbitrary
+ test/Main.hs view
@@ -0,0 +1,7 @@+module Main where++import Test.ImpSpec+import Test.Suite.ImpSpec (spec)++main :: IO ()+main = impSpecMain $ describe "ImpSpec" spec
+ test/Test/Suite/ImpSpec.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE TypeApplications #-}++module Test.Suite.ImpSpec (spec) where++import Test.ImpSpec++data I++instance ImpSpec I++spec :: Spec+spec =+ describe "ImpSpec" $ do+ describe "Expectations" $ do+ it "shouldBeLeft" $ io $ do+ Left @() @Int () `shouldBeLeft` ()+ withImpInit @I $+ describe "ImpM" $ do+ it "impSetSeed" $ do+ impSetSeed 1234+ arbitrary `shouldReturn` 'F'