diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Version history for `ImpSpec` + +## 0.1.0.0 + +* diff --git a/ImpSpec.cabal b/ImpSpec.cabal new file mode 100644 --- /dev/null +++ b/ImpSpec.cabal @@ -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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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 diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain diff --git a/src/Test/ImpSpec.hs b/src/Test/ImpSpec.hs new file mode 100644 --- /dev/null +++ b/src/Test/ImpSpec.hs @@ -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 diff --git a/src/Test/ImpSpec/Expectations.hs b/src/Test/ImpSpec/Expectations.hs new file mode 100644 --- /dev/null +++ b/src/Test/ImpSpec/Expectations.hs @@ -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 + } diff --git a/src/Test/ImpSpec/Expectations/Lifted.hs b/src/Test/ImpSpec/Expectations/Lifted.hs new file mode 100644 --- /dev/null +++ b/src/Test/ImpSpec/Expectations/Lifted.hs @@ -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 diff --git a/src/Test/ImpSpec/Internal.hs b/src/Test/ImpSpec/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Test/ImpSpec/Internal.hs @@ -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 diff --git a/src/Test/ImpSpec/Main.hs b/src/Test/ImpSpec/Main.hs new file mode 100644 --- /dev/null +++ b/src/Test/ImpSpec/Main.hs @@ -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 diff --git a/src/Test/ImpSpec/Random.hs b/src/Test/ImpSpec/Random.hs new file mode 100644 --- /dev/null +++ b/src/Test/ImpSpec/Random.hs @@ -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 diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,7 @@ +module Main where + +import Test.ImpSpec +import Test.Suite.ImpSpec (spec) + +main :: IO () +main = impSpecMain $ describe "ImpSpec" spec diff --git a/test/Test/Suite/ImpSpec.hs b/test/Test/Suite/ImpSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Suite/ImpSpec.hs @@ -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'