diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,15 @@ +# Changelog for assert4hs + +## 0.1.0 + +- Initial release +- Assertions for `Either` type +- Assertions for `Maybe` type +- Assertions for `List` type +- Assertions for `Exceptions` +- Basic assertions for `Foldable` types +- Implementation of core assertions +- assertion over infinitive data structure or not terminating predicates do not hang all test and timeout is reported +- the timeout for assertion is configurable now + +## Unreleased changes diff --git a/LICENSE.md b/LICENSE.md new file mode 100644 --- /dev/null +++ b/LICENSE.md @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2021 Pawel Nosal + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,151 @@ +# assert4hs + + This library aims to provide a set of combinators to assert arbitrary nested data structures. + The inspiration of this library is AssertJ for Java, the composition of assertions was inspired by `lens` library. + + New assertions can be easily written and composed with other assertions. All failed assertions are gathered and presented to the user. + +```haskell + data Foo = Foo {name :: String, age :: Int} deriving (Show, Eq) + + assertThat (Foo "someName" 15) $ + isEqualTo (Foo "someN1ame" 15) + . focus age + . tag "age" + . isGreaterThan 20 +``` + + result in + +```haskell + given Foo {name = "someName", age = 15} should be equal to Foo {name = "someN1ame", age = 15} + Foo {name = "someName", age = 15} + ╷ + │ + ╵ + Foo {name = "someN1ame", age = 15} + ▲ + [age] given 15 should be greater than 20 +``` + +#### Examples + +##### Simple assertion + +```haskell + result = 10 + assertThat result $ isEqual 10 +``` + +##### Composing assertion + + Assertions are composable, this allows verifying multiple conditions during one test case. + +```haskell + result = 10 + assertThat result $ + isGreaterThan 5 + . isLowerThan 20 + + + >>> given 4 should be greater than 5 +``` + +##### Focusing on part of data structure + + Sometimes it is convenient to transform the subject under test and execute assertions on the extracted part of it. For this purpose, we have a `focus` function. + +```haskell + data Foo = Foo {name :: String, age :: Int} deriving (Show, Eq) + + assertThat (Foo "someName" 15) $ + isEqualTo (Foo "someName" 15) + . focus age + . isGreaterThan 20 + . isLowerEqualThan 5 + + >>> given 15 should be greater than 20 + >>> given 15 should be lower or equal to 5 +``` + +##### Changing subject uder test + +The `focus` function allows to transform the subject under test, but the original subject is lost. Function `inside` is similar to the function `focus`, but preserve theoriginal subject under test. + +```haskell +data Foo = Foo {name :: String, age :: Int} deriving (Show, Eq) + +assertThat (Foo "someName" 15) $ + inside age (isGreaterThan 20 . isLowerEqualThan 5) + . focus name + . isEqualTo "someName1" + +>>> given 15 should be greater than 20 +>>> +>>> given 15 should be lower or equal to 5 +>>> +>>> given "someName" should be equal to "someName1" +>>> "someName" +>>> ╷ +>>> │ +>>> ╵ +>>> "someName1" +>>> ▲ +``` + +##### Tagging assertions + +Once our test grows, it is hard to spot which assertions failed and why. That is why function `tag` exists, one can name assertion and give it a more readable name for failure message. + +```haskell + +data Foo = Foo {name :: String, age :: Int} deriving (Show, Eq) + +assertThat (Foo "someName" 15) $ + inside age (tag "age" . isGreaterThan 20 . isLowerEqualThan 5) + . tag "name" + . focus name + . isEqualTo "someName1" + . tag "should not be equal" + . isNotEqualTo "someName" + +>>> [age] given 15 should be greater than 20 +>>> +>>> [age] given 15 should be lower or equal to 5 +>>> +>>> [name] given "someName" should be equal to "someName1" +>>> "someName" +>>> ╷ +>>> │ +>>> ╵ +>>> "someName1" +>>> ▲ +>>> +>>> [name.should not be equal] given "someName" should be not equal to "someName" +``` + +##### Custom assertions + + It is sometimes convenient to create a custom assertion which explicitly describes what is testing. For this purpose we have `simpleAssertion` function + +```haskell +isSuitableForEmployment :: Assertion Foo +isSuitableForEmployment = + simpleAssertion (\a -> age a > 17) (\a -> "new employee must be 18 years or older, but it has " <> show (age a)) + . simpleAssertion (\a -> age a < 70) (\a -> "must be younger than 70 years old, but it has " <> show (age a)) + +assertThat (Foo "someName" 15) isSuitableForEmployment + +>>> new employee must be 18 years or older, but it has 15 + +assertThat (Foo "someName" 76) isSuitableForEmployment + +>>> must be younger than 70 years old, but it has 76 + +``` + +#### Related projects + +[assert4hs-hspec](https://github.com/paweln1986/assert4hs-hspec) - integration point of assert4hs and [hspec](https://hackage.haskell.org/package/hspec) + +[assert4hs-tasty](https://github.com/paweln1986/assert4hs-tasty) - integration point of assert4hs and [tasty](https://hackage.haskell.org/package/tasty) diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/assert4hs-core.cabal b/assert4hs-core.cabal new file mode 100644 --- /dev/null +++ b/assert4hs-core.cabal @@ -0,0 +1,78 @@ +cabal-version: 1.12 +name: assert4hs-core +version: 0.1.0 +license: MIT +license-file: LICENSE.md +copyright: 2021 Pawel Nosal +maintainer: p.nosal1986@gmail.com +author: Pawel Nosal +homepage: https://github.com/paweln1986/assert4hs-core#readme +bug-reports: https://github.com/paweln1986/assert4hs-core/issues +synopsis: A set of assertion for writing more readable tests cases +description: + Please see the README on GitHub at + +category: Testing +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + +source-repository head + type: git + location: https://github.com/paweln1986/assert4hs-core + +library + exposed-modules: + Test.Fluent.Assertions + Test.Fluent.Assertions.Core + Test.Fluent.Assertions.Either + Test.Fluent.Assertions.Exceptions + Test.Fluent.Assertions.List + Test.Fluent.Assertions.Maybe + Test.Fluent.Diff + Test.Fluent.Internal.AssertionConfig + Test.Fluent.Internal.Assertions + + hs-source-dirs: src + other-modules: Paths_assert4hs_core + default-language: Haskell2010 + default-extensions: OverloadedStrings BangPatterns + ghc-options: + -haddock -Wall -Wcompat -Wincomplete-record-updates + -Wincomplete-uni-patterns -Wredundant-constraints + -Wno-unused-do-bind -Werror=incomplete-patterns + + build-depends: + base >=4.7 && <5, + data-default >=0.7.1.1, + pretty-diff >=0.4.0.0, + text >=1.2.4.1 + +test-suite assert4hs-core-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: test + other-modules: + Assertions.ListsSpec + Assertions.MaybeSpec + AssertionSpecUtils + AssertionsSpec + Paths_assert4hs_core + + default-language: Haskell2010 + default-extensions: OverloadedStrings BangPatterns + ghc-options: + -haddock -Wall -Wcompat -Wincomplete-record-updates + -Wincomplete-uni-patterns -Wredundant-constraints + -Wno-unused-do-bind -Werror=incomplete-patterns -threaded -rtsopts + -with-rtsopts=-N + + build-depends: + assert4hs-core -any, + base >=4.7 && <5, + data-default >=0.7.1.1, + hspec >=2.7.8, + hspec-discover >=2.7.8, + pretty-diff >=0.4.0.0, + text >=1.2.4.1 diff --git a/src/Test/Fluent/Assertions.hs b/src/Test/Fluent/Assertions.hs new file mode 100644 --- /dev/null +++ b/src/Test/Fluent/Assertions.hs @@ -0,0 +1,281 @@ +{-# OPTIONS_HADDOCK show-extensions #-} + +-- | +-- Module : Test.Fluent.Assertions +-- Description : Set of combinators and primitives to use fluen assertions +-- Copyright : (c) Pawel Nosal, 2021 +-- License : MIT +-- Maintainer : p.nosal1986@gmail.com +-- Stability : experimental +-- +-- This library aims to provide a set of combinators to assert arbitrary nested data structures. +-- The inspiration of this library is AssertJ for Java, the composition of assertions was inspired by `lens` library. +-- +-- Example: +-- +-- @ +-- data Foo = Foo {name :: String, age :: Int} deriving (Show, Eq) +-- +-- assertThat (Foo "someName" 15) $ +-- isEqualTo (Foo "someN1ame" 15) +-- . focus age +-- . tag "age" +-- . isGreaterThan 20 +-- @ +-- +-- result in +-- +-- @ +-- given Foo {name = "someName", age = 15} should be equal to Foo {name = "someN1ame", age = 15} +-- Foo {name = "someName", age = 15} +-- ╷ +-- │ +-- ╵ +-- Foo {name = "someN1ame", age = 15} +-- ▲ +-- [age] given 15 should be greater than 20 +-- @ +module Test.Fluent.Assertions + ( -- * Assertions + + -- ** Basic assertions + simpleAssertion, + isEqualTo, + isNotEqualTo, + isGreaterThan, + isGreaterEqualThan, + isLowerThan, + isLowerEqualThan, + shouldSatisfy, + hasSize, + isEmpty, + isNotEmpty, + contains, + + -- ** Assertion util functions + focus, + inside, + tag, + forceError, + + -- ** Assertion configuration + AssertionConfig, + defaultConfig, + setAssertionTimeout, + + -- * Types + + -- ** Assertion defitions + Assertion, + Assertion', + + -- ** Assertion failure + FluentTestFailure (..), + ) +where + +import Data.Functor.Contravariant (Contravariant (contramap)) +import GHC.Stack (HasCallStack) +import Test.Fluent.Diff (pretty) +import Test.Fluent.Internal.AssertionConfig + ( AssertionConfig, + defaultConfig, + setAssertionTimeout, + ) +import Test.Fluent.Internal.Assertions (Assertion, Assertion', AssertionDefinition (SequentialAssertions), FluentTestFailure (..), basicAssertion, transformAssertions, updateLabel) + +-- | The 'simpleAssertion' function is a building block of more complicated assertions. +-- +-- It takes one predicate and function to format error message. +-- +-- @ +-- myIsEqual x = simpleAssertion (== x) (\\x' -> show x' <> " is not equal to " <> show x) +-- @ +simpleAssertion :: + HasCallStack => + -- | A predicate that should be met by the subject under test + (a -> Bool) -> + -- | A function that allows formatting an error message once the predicate is not met + (a -> String) -> + Assertion a +simpleAssertion predicate formatter f s = basicAssertion predicate formatter (f s) + +-- | assert if subject under test is equal to given value +-- +-- @ +-- assertThat 15 $ isEqualTo 16 +-- @ +-- +-- result +-- +-- @ +-- given 15 should be equal to 16 +-- ▼ +-- 15 +-- ╷ +-- │ +-- ╵ +-- 16 +-- ▲ +-- @ +isEqualTo :: (Eq a, Show a, HasCallStack) => a -> Assertion a +isEqualTo a = simpleAssertion (a ==) (formatMessage True "should be equal to" a) + +isNotEqualTo :: (Eq a, Show a, HasCallStack) => a -> Assertion a +isNotEqualTo a = simpleAssertion (a /=) (formatMessage False "should be not equal to" a) + +-- | assert if the subject under test is greater than given value +-- +-- @ +-- assertThat 15 $ isGreaterThan 16 +-- @ +-- +-- result +-- +-- @ +-- given 15 should be greater than 16 +-- @ +isGreaterThan :: (Ord a, Show a, HasCallStack) => a -> Assertion a +isGreaterThan a = simpleAssertion (a <) (formatMessage False "should be greater than" a) + +isGreaterEqualThan :: (Ord a, Show a, HasCallStack) => a -> Assertion a +isGreaterEqualThan a = simpleAssertion (a <=) (formatMessage False "should be greater or equal to" a) + +-- | assert if the subject under test is lower than given value +-- +-- @ +-- assertThat 16 $ isLowerThan 15 +-- @ +-- +-- result +-- +-- @ +-- given 16 should be lower than 15 +-- @ +isLowerThan :: (Ord a, Show a, HasCallStack) => a -> Assertion a +isLowerThan a = simpleAssertion (a >) (formatMessage False "should be lower than" a) + +isLowerEqualThan :: (Ord a, Show a, HasCallStack) => a -> Assertion a +isLowerEqualThan a = simpleAssertion (a >=) (formatMessage False "should be lower or equal to" a) + +shouldSatisfy :: (Show a, HasCallStack) => (a -> Bool) -> Assertion a +shouldSatisfy predicate = simpleAssertion predicate (formatMessage' "does not met a predicate") + +hasSize :: (Foldable t, HasCallStack) => Int -> Assertion (t a) +hasSize expectedSize = inside length (simpleAssertion (== expectedSize) assertionMessage) + where + assertionMessage currentSize = "expected size " <> show expectedSize <> " is not equal actual size " <> show currentSize + +isEmpty :: (Foldable t, HasCallStack) => Assertion (t a) +isEmpty = inside null (simpleAssertion (== True) assertionMessage) + where + assertionMessage _ = "should be empty, but is not" + +isNotEmpty :: (Foldable t, HasCallStack) => Assertion (t a) +isNotEmpty = inside null (simpleAssertion (== False) assertionMessage) + where + assertionMessage _ = "should be not empty" + +contains :: (Foldable t, Eq a, Show a, HasCallStack) => a -> Assertion (t a) +contains expectedElem = inside (elem expectedElem) (simpleAssertion (== True) assertionMessage) + where + assertionMessage _ = "should contain element " <> show expectedElem <> ", but it doesn't" + +-- | allow changing subject under test using a transformation function +-- +-- @ +-- assertThat "1 " $ +-- isNotEqualTo "" +-- . focus length +-- . isEqualTo 10 +-- @ +-- +-- result +-- +-- @ +-- given 5 should be equal to 10 +-- ▼ +-- 5 +-- ╷ +-- │ +-- ╵ +-- 10 +-- ▲▲ +-- @ +focus :: (a -> b) -> Assertion' a b +focus f assert s = contramap f (assert (f s)) + +-- | like 'focus', this function allow changing subject under test, it takes an assertion for modified value, then it allows us to continue assertion on the original value +-- +-- @ +-- assertThat (Foo "someName" 15) $ +-- isEqualTo (Foo "someN1ame" 15) +-- . inside age (tag "age" . isGreaterThan 20 . isLowerThan 10) +-- . isEqualTo (Foo "someName" 15) +-- @ +-- +-- result +-- +-- @ +-- given Foo {name = "someName", age = 15} should be equal to Foo {name = "someN1ame", age = 15} +-- Foo {name = "someName", age = 15} +-- ╷ +-- │ +-- ╵ +-- Foo {name = "someN1ame", age = 15} +-- ▲ +-- [age] given 15 should be greater than 20 +-- [age] given 15 should be lower than 10 +-- @ +inside :: (b -> a) -> Assertion a -> Assertion b +inside f assert' b s = b s <> mconcat (transformAssertions [assert' mempty (f s)] f) + +-- | this combinator allows marking following assertion with a given prefix +-- +-- @ +-- assertThat (Foo "someName" 15) $ +-- tag "foo" . isEqualTo (Foo "someN1ame" 15) +-- . inside age (tag "age" . isGreaterThan 20 . isLowerThan 10) +-- . tag "foo not equal" +-- . isNotEqualTo (Foo "someName" 15) +-- @ +-- +-- result +-- +-- @ +-- [foo] given Foo {name = "someName", age = 15} should be equal to Foo {name = "someN1ame", age = 15} +-- Foo {name = "someName", age = 15} +-- ╷ +-- │ +-- ╵ +-- Foo {name = "someN1ame", age = 15} +-- ▲ +-- [foo.age] given 15 should be greater than 20 +-- [foo.age] given 15 should be lower than 10 +-- [foo.not equal to] given Foo {name = "someName", age = 15} should be not equal to Foo {name = "someName", age = 15} +-- Foo {name = "someName", age = 15} +-- ╷ +-- │ +-- ╵ +-- Foo {name = "someName", age = 15} +-- @ +tag :: String -> Assertion a +tag label assert s = updateLabel label (assert s) + +-- | Sometimes it is handy to stop the assertions chain. +-- +-- This combinator gets an assertion that should be forced, any following assertion will be not executed then +-- +-- @ +-- extracting :: HasCallStack => Assertion' (Maybe a) a +-- extracting = forceError isJust . focus Maybe.fromJust +-- @ +forceError :: Assertion a -> Assertion a +forceError assert' b s = SequentialAssertions [b s] <> mconcat (transformAssertions [assert' mempty s] id) + +formatMessage :: Show a => Bool -> String -> a -> a -> String +formatMessage True message a a' = "given " <> show a' <> " " <> message <> " " <> show a <> "\n" <> pretty a' a +formatMessage False message a a' = "given " <> show a' <> " " <> message <> " " <> show a + +formatMessage' :: Show a => String -> a -> String +formatMessage' message a = "given " <> show a <> " " <> message diff --git a/src/Test/Fluent/Assertions/Core.hs b/src/Test/Fluent/Assertions/Core.hs new file mode 100644 --- /dev/null +++ b/src/Test/Fluent/Assertions/Core.hs @@ -0,0 +1,69 @@ +{-# OPTIONS_HADDOCK show-extensions #-} + +module Test.Fluent.Assertions.Core + ( -- ** Assertion util functions + assertThat, + assertThatIO, + assertThat', + assertThatIO', + assertThrown, + assertThrown', + assertThrows', + assertThrows, + ) +where + +import Control.Exception (Exception (fromException), throwIO, try) +import Data.Data (typeOf) +import GHC.Stack (HasCallStack, callStack, getCallStack) +import Test.Fluent.Assertions (FluentTestFailure (..), simpleAssertion) +import Test.Fluent.Assertions.Exceptions (ExceptionSelector) +import Test.Fluent.Internal.AssertionConfig + ( AssertionConfig, + defaultConfig, + ) +import Test.Fluent.Internal.Assertions + ( Assertion', + assertThat, + assertThat', + assertThatIO, + assertThatIO', + assertThatIO'', + ) + +-- | +-- Module : Test.Fluent.Assertions.Core +-- Description : Set util function to execute assertions against given value +-- Copyright : (c) Pawel Nosal, 2021 +-- License : MIT +-- Maintainer : p.nosal1986@gmail.com +-- Stability : experimental + +-- | Verify if given `IO` action throws expected exception. +assertThrows :: (HasCallStack, Exception e) => IO a -> ExceptionSelector e -> IO () +assertThrows givenIO selector = assertThrown' defaultConfig givenIO selector (simpleAssertion (const True) (const "should not be invoked")) + +assertThrows' :: (HasCallStack, Exception e) => AssertionConfig -> IO a -> ExceptionSelector e -> IO () +assertThrows' config givenIO selector = assertThrown' config givenIO selector (simpleAssertion (const True) (const "should not be invoked")) + +-- | Execute assertions against selected exception +assertThrown :: (HasCallStack, Exception e) => IO a -> ExceptionSelector e -> Assertion' e b -> IO () +assertThrown = assertThrown' defaultConfig + +assertThrown' :: (HasCallStack, Exception e) => AssertionConfig -> IO a -> ExceptionSelector e -> Assertion' e b -> IO () +assertThrown' config givenIO predicate = assertThatIO'' config givenIO $ \io -> do + res <- try io + case res of + Left e -> do + let thrownException = show e + case fromException e of + Just expectedException -> pure expectedException + Nothing -> throwIO (FluentTestFailure location [("should throw an exception of type " <> expectedExceptionName <> " , but " <> thrownException <> " has been thrown", location)] 1 0) + _ -> throwIO (FluentTestFailure location [("should throw an exception of type " <> expectedExceptionName <> ", but it doesn't", location)] 1 0) + where + expectedExceptionName = show $ typeOf (exceptionName predicate) + exceptionName :: (a -> a) -> a + exceptionName _ = error "instance of Typeable is broken" + location = case reverse (getCallStack callStack) of + (_, loc) : _ -> Just loc + [] -> Nothing diff --git a/src/Test/Fluent/Assertions/Either.hs b/src/Test/Fluent/Assertions/Either.hs new file mode 100644 --- /dev/null +++ b/src/Test/Fluent/Assertions/Either.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE LambdaCase #-} +{-# OPTIONS_GHC -Wno-incomplete-patterns #-} +{-# OPTIONS_HADDOCK show-extensions #-} + +-- | +-- Module : Test.Fluent.Assertions.Either +-- Description : Set of assertions for Either type +-- Copyright : (c) Pawel Nosal, 2021 +-- License : MIT +-- Maintainer : p.nosal1986@gmail.com +-- Stability : experimental +-- +-- This module provide a set of combinators to assert Either type. +module Test.Fluent.Assertions.Either (isLeft, isRight, extractingRight, extractingLeft) where + +import qualified Data.Either as Either +import GHC.Stack (HasCallStack) +import Test.Fluent.Assertions + ( Assertion, + Assertion', + focus, + forceError, + inside, + simpleAssertion, + ) + +-- | assert if subject under test is Left +-- +-- @ +-- assertThat (Left 10) isLeft +-- @ +isLeft :: HasCallStack => Assertion (Either a b) +isLeft = inside Either.isLeft (simpleAssertion (== True) assertionMessage) + where + assertionMessage _ = "should be Left, but is Right" + +-- | assert if subject under test is Right +-- +-- @ +-- assertThat (Left 10) isRight +-- @ +isRight :: HasCallStack => Assertion (Either a b) +isRight = inside Either.isRight (simpleAssertion (== True) assertionMessage) + where + assertionMessage _ = "should be Right, but is Left" + +-- | assert if subject under test is Right and extract contained value +-- +-- @ +-- assertThat (Left 10) extractingRight +-- @ +extractingRight :: HasCallStack => Assertion' (Either a b) b +extractingRight = forceError isRight . focus (\case (Right a) -> a) + +-- | assert if subject under test is Left and extract contained value +-- +-- @ +-- assertThat (Left 10) extractingLeft +-- @ +extractingLeft :: HasCallStack => Assertion' (Either a b) a +extractingLeft = forceError isLeft . focus (\case (Left a) -> a) diff --git a/src/Test/Fluent/Assertions/Exceptions.hs b/src/Test/Fluent/Assertions/Exceptions.hs new file mode 100644 --- /dev/null +++ b/src/Test/Fluent/Assertions/Exceptions.hs @@ -0,0 +1,52 @@ +{-# OPTIONS_GHC -Wno-redundant-constraints #-} +{-# OPTIONS_HADDOCK show-extensions #-} + +-- | +-- Module : Test.Fluent.Assertions.Exceptions +-- Description : Set of assertions for Exception type +-- Copyright : (c) Pawel Nosal, 2021 +-- License : MIT +-- Maintainer : p.nosal1986@gmail.com +-- Stability : experimental +-- +-- This module provide an assertion for check if expected Exception has been throw by IO action. +module Test.Fluent.Assertions.Exceptions + ( -- ** Exception selectors + anyException, + anyIOException, + exceptionOfType, + + -- ** Exception selector type + ExceptionSelector, + ) +where + +import Control.Exception + ( Exception, + IOException, + SomeException, + ) + +type ExceptionSelector a = a -> a + +-- | Select all exceptions. +anyException :: ExceptionSelector SomeException +anyException = id + +-- | Select all IOException. +anyIOException :: ExceptionSelector IOException +anyIOException = id + +-- | Select all an Exception of given type. +-- This selector should be used with `TypeApplications` +-- +-- @ +-- data MyException = ThisException | ThatException +-- deriving (Show) +-- +-- instance Exception MyException +-- +-- selectMyException = exceptionType @MyException +-- @ +exceptionOfType :: Exception e => ExceptionSelector e +exceptionOfType = id diff --git a/src/Test/Fluent/Assertions/List.hs b/src/Test/Fluent/Assertions/List.hs new file mode 100644 --- /dev/null +++ b/src/Test/Fluent/Assertions/List.hs @@ -0,0 +1,113 @@ +{-# OPTIONS_HADDOCK show-extensions #-} + +-- | +-- Module : Test.Fluent.Assertions.List +-- Description : Set of assertions for List type +-- Copyright : (c) Pawel Nosal, 2021 +-- License : MIT +-- Maintainer : p.nosal1986@gmail.com +-- Stability : experimental +-- +-- This library aims to provide a set of combinators to assert List type. +module Test.Fluent.Assertions.List where + +import Data.List (isPrefixOf) +import GHC.Stack (HasCallStack) +import Test.Fluent.Assertions (Assertion, forceError, simpleAssertion) +import Test.Fluent.Diff (pretty) + +-- | assert if given list has same length as expected list +-- +-- @ +-- assertThat [1..10] $ shouldHaveSameSizeAs [0..10] +-- @ +shouldHaveSameSizeAs :: HasCallStack => [a] -> Assertion [a] +shouldHaveSameSizeAs expected = simpleAssertion predicate message + where + predicate given = length given == length expected + message given = + "should have same leght, but they don't. Given: " + <> show (length given) + <> " is not equal to expected " + <> show (length expected) + +-- | verify if the given list has a length lower or equal to expected value +-- +-- @ +-- assertThat [1..10] $ shouldHaveSizeLowerOrEqual 10 +-- @ +shouldHaveSizeLowerOrEqual :: HasCallStack => Int -> Assertion [a] +shouldHaveSizeLowerOrEqual expected = simpleAssertion predicate message + where + predicate given = length given >= expected + message given = + "the lenght of given list is " + <> show (length given) + <> ", but should be lower or equal " + <> show expected + +-- | verify if the given list has expected prefix +-- +-- @ +-- assertThat [1..10] $ shouldStartWith [0..4] +-- @ +shouldStartWith :: (Eq a, Show a, HasCallStack) => [a] -> Assertion [a] +shouldStartWith expected = forceError (shouldHaveSizeLowerOrEqual expectedLenght) . simpleAssertion predicate message + where + predicate = (expected `isPrefixOf`) + expectedLenght = length expected + actualPrefix x = take expectedLenght x + message x = + "should start with " + <> show expected + <> ", but it start with " + <> show (actualPrefix x) + +-- | verify if the given list does not start with prefix +-- +-- @ +-- assertThat [1..10] $ shouldNotStartWith [1..4] +-- @ +shouldNotStartWith :: (Eq a, Show a, HasCallStack) => [a] -> Assertion [a] +shouldNotStartWith expected = simpleAssertion predicate message + where + predicate = not . (expected `isPrefixOf`) + message _ = + "should not start with " + <> show expected + <> ", but it does" + +shouldBeSameAs :: (Eq a, HasCallStack, Show a) => [a] -> Assertion [a] +shouldBeSameAs expected = simpleAssertion predicate message + where + predicate = (== expected) + message given = "given list should be same as expected list, but is not.\n" <> pretty given expected + +shouldContain :: (Eq a, HasCallStack, Show a) => a -> Assertion [a] +shouldContain expected = simpleAssertion predicate message + where + predicate = elem expected + message _ = "given list should contain element " <> show expected <> ", but it doesn't." + +shouldNotContain :: (Eq a, HasCallStack, Show a) => a -> Assertion [a] +shouldNotContain expected = simpleAssertion predicate message + where + predicate = notElem expected + message _ = "given list should not contain element " <> show expected <> ", but it doesn." + +-- | verify if the given list contains same elements as expected list in any order +-- +-- @ +-- assertThat [1..10] $ shouldNotStartWith [1..4] +-- @ +shouldHaveSameElements :: (HasCallStack, Eq a, Show a) => [a] -> Assertion [a] +shouldHaveSameElements expected = forceError (shouldHaveSameSizeAs expected) . simpleAssertion predicate errorMessage + where + predicate given = all (`elem` expected) given + inGiven given = filter (`notElem` given) expected + inExpected given = filter (`notElem` expected) given + errorMessage given = "two lists should have same elements but:\n " ++ message + where + message = case (inGiven given, inExpected given) of + ([], []) -> "bug in shouldHaveSameElements assertion, please report this to the maintainer" + (xs, ys) -> "given list don't have " ++ show xs ++ "\nexpected list don't have " ++ show ys diff --git a/src/Test/Fluent/Assertions/Maybe.hs b/src/Test/Fluent/Assertions/Maybe.hs new file mode 100644 --- /dev/null +++ b/src/Test/Fluent/Assertions/Maybe.hs @@ -0,0 +1,50 @@ +{-# OPTIONS_HADDOCK show-extensions #-} + +-- | +-- Module : Test.Fluent.Assertions.Maybe +-- Description : Set of assertions for Maybe type +-- Copyright : (c) Pawel Nosal, 2021 +-- License : MIT +-- Maintainer : p.nosal1986@gmail.com +-- Stability : experimental +-- +-- This library aims to provide a set of combinators to assert Maybe type. +module Test.Fluent.Assertions.Maybe (isNothing, isJust, extracting) where + +import qualified Data.Maybe as Maybe +import GHC.Stack (HasCallStack) +import Test.Fluent.Assertions + ( focus, + forceError, + inside, + simpleAssertion, + ) +import Test.Fluent.Internal.Assertions (Assertion, Assertion') + +-- | assert if subject under is empty +-- +-- @ +-- assertThat (Just 10) isNothing +-- @ +isNothing :: HasCallStack => Assertion (Maybe a) +isNothing = inside Maybe.isNothing (simpleAssertion (== True) assertionMessage) + where + assertionMessage _ = "should be Nothing" + +-- | assert if subject under is not empty +-- +-- @ +-- assertThat (Just 10) isJust +-- @ +isJust :: HasCallStack => Assertion (Maybe a) +isJust = inside Maybe.isJust (simpleAssertion (== True) assertionMessage) + where + assertionMessage _ = "should be Just" + +-- | assert if subject under is not empty and extract contained value +-- +-- @ +-- assertThat (Just 10) extracting +-- @ +extracting :: HasCallStack => Assertion' (Maybe a) a +extracting = forceError isJust . focus Maybe.fromJust diff --git a/src/Test/Fluent/Diff.hs b/src/Test/Fluent/Diff.hs new file mode 100644 --- /dev/null +++ b/src/Test/Fluent/Diff.hs @@ -0,0 +1,11 @@ +module Test.Fluent.Diff where + +import Data.Default (Default (def)) +import qualified Data.Text as T +import qualified Pretty.Diff as Diff + +pretty :: Show a => a -> a -> String +pretty a b = + let x = T.pack $ show a + y = T.pack $ show b + in T.unpack $ Diff.pretty def x y diff --git a/src/Test/Fluent/Internal/AssertionConfig.hs b/src/Test/Fluent/Internal/AssertionConfig.hs new file mode 100644 --- /dev/null +++ b/src/Test/Fluent/Internal/AssertionConfig.hs @@ -0,0 +1,17 @@ +module Test.Fluent.Internal.AssertionConfig where + +newtype AssertionConfig = AssertionConfig + { assertionTimeout :: Int + } + deriving (Show) + +-- | Default configuration used for `assertThat` and `assertThatIO`. +-- - default timeout is set to 5 seconds +defaultConfig :: AssertionConfig +defaultConfig = + AssertionConfig + 5000000 -- 5 seconds + +-- | Allow to modify timeout of single assertion +setAssertionTimeout :: Int -> AssertionConfig -> AssertionConfig +setAssertionTimeout newTimeout config = config {assertionTimeout = newTimeout} diff --git a/src/Test/Fluent/Internal/Assertions.hs b/src/Test/Fluent/Internal/Assertions.hs new file mode 100644 --- /dev/null +++ b/src/Test/Fluent/Internal/Assertions.hs @@ -0,0 +1,180 @@ +{-# LANGUAGE BangPatterns #-} +{-# OPTIONS_HADDOCK hide, prune, ignore-exports #-} + +module Test.Fluent.Internal.Assertions where + +import Control.Exception (Exception, throwIO, try) +import Data.Either (isLeft, lefts, rights) +import Data.Functor.Contravariant (Contravariant (contramap)) +import GHC.Exception (SrcLoc, getCallStack) +import GHC.Stack (HasCallStack, callStack) +import System.Timeout (timeout) +import Test.Fluent.Internal.AssertionConfig + ( AssertionConfig (assertionTimeout), + defaultConfig, + ) + +data FluentTestFailure = FluentTestFailure + { srcLoc :: !(Maybe SrcLoc), + msg :: ![(String, Maybe SrcLoc)], + errorsCount :: !Int, + successCount :: !Int + } + deriving (Show) + +instance Exception FluentTestFailure + +data AssertionFailure = AssertionFailure + { message :: !String, + assertionSrcLoc :: !(Maybe SrcLoc) + } + deriving (Show) + +instance Exception AssertionFailure + +data AssertionDefinition a + = ParallelAssertions [AssertionDefinition a] + | SequentialAssertions [AssertionDefinition a] + | SimpleAssertion + { assertion :: Maybe String -> a -> IO (), + label :: Maybe String + } + +instance Show (AssertionDefinition a) where + show (ParallelAssertions a) = "ParallelAssertions " <> show a + show (SequentialAssertions a) = "SequentialAssertions " <> show a + show (SimpleAssertion _ assertionLabel) = "SimpleAssertion - " <> show assertionLabel + +instance Contravariant AssertionDefinition where + contramap f (ParallelAssertions assertions) = ParallelAssertions (fmap (contramap f) assertions) + contramap f (SequentialAssertions assertions) = SequentialAssertions (fmap (contramap f) assertions) + contramap f (SimpleAssertion assert assertionLabel) = SimpleAssertion (\l -> assert l . f) assertionLabel + +instance Semigroup (AssertionDefinition a) where -- TODO: looks like this instance is not lawful, should be removed and replaced by plain function + ParallelAssertions a <> ParallelAssertions b = ParallelAssertions (b <> a) + ParallelAssertions a <> b@(SequentialAssertions _) = ParallelAssertions (b : a) + SequentialAssertions a <> b@(ParallelAssertions _) = SequentialAssertions (b : a) + SequentialAssertions a <> SequentialAssertions b = SequentialAssertions (b <> a) + s@(SimpleAssertion _ _) <> ParallelAssertions a = ParallelAssertions (a ++ [s]) + ParallelAssertions a <> s@(SimpleAssertion _ _) = ParallelAssertions (s : a) + s@(SimpleAssertion _ _) <> SequentialAssertions a = SequentialAssertions (a ++ [s]) + SequentialAssertions a <> s@(SimpleAssertion _ _) = SequentialAssertions (s : a) + a@(SimpleAssertion _ _) <> b@(SimpleAssertion _ _) = ParallelAssertions [b, a] + +instance Monoid (AssertionDefinition a) where + mempty = ParallelAssertions [] + +updateLabel :: String -> AssertionDefinition a -> AssertionDefinition a +updateLabel newLabel (SimpleAssertion assert (Just oldLabel)) = SimpleAssertion assert (Just $ newLabel <> "." <> oldLabel) +updateLabel assertionLabel (SimpleAssertion a Nothing) = SimpleAssertion a (Just assertionLabel) +updateLabel assertionLabel (ParallelAssertions (x : xs)) = ParallelAssertions (updateLabel assertionLabel x : fmap (updateLabel assertionLabel) xs) +updateLabel assertionLabel (SequentialAssertions (x : xs)) = SequentialAssertions (updateLabel assertionLabel x : fmap (updateLabel assertionLabel) xs) +updateLabel _ (ParallelAssertions []) = ParallelAssertions [] +updateLabel _ (SequentialAssertions []) = SequentialAssertions [] + +-- | Execute assertions against given subject under test. +assertThat :: HasCallStack => a -> Assertion' a b -> IO () +assertThat given = assertThatIO (pure given) + +-- | Execute assertions against given subject under test extracted from IO action. +assertThatIO :: HasCallStack => IO a -> Assertion' a b -> IO () +assertThatIO given = assertThatIO'' defaultConfig given id + +-- | A variant of `assertThat` which allow to pass additional configuration. +assertThat' :: HasCallStack => AssertionConfig -> a -> Assertion' a b -> IO () +assertThat' config given = assertThatIO' config (pure given) + +-- | A variant of `assertThatIO` which allow to pass additional configuration. +assertThatIO' :: HasCallStack => AssertionConfig -> IO a -> Assertion' a c -> IO () +assertThatIO' config givenIO = assertThatIO'' config givenIO id + +assertThatIO'' :: HasCallStack => AssertionConfig -> IO a -> (IO a -> IO b) -> Assertion' b c -> IO () +assertThatIO'' config givenIO f b = do + given <- f givenIO + case b (const mempty) given of + SimpleAssertion assert assertionLabel -> do + assertionResult <- try (assert assertionLabel given) + case assertionResult of + Right () -> pure () + Left (AssertionFailure failureMessage assertionLocation) -> throwIO (FluentTestFailure location [(failureMessage, assertionLocation)] 1 0) + assertions -> do + assertionResults <- flattenAssertions config given assertions + let errors = (\assertionError -> (message assertionError, assertionSrcLoc assertionError)) <$> lefts assertionResults + let successes = length $ rights assertionResults + if null errors then pure () else throwIO (FluentTestFailure location errors (length errors) successes) + where + location = case reverse (getCallStack callStack) of + (_, loc) : _ -> Just loc + [] -> Nothing + +flattenAssertions :: HasCallStack => AssertionConfig -> a -> AssertionDefinition a -> IO [Either AssertionFailure ()] +flattenAssertions config a (SimpleAssertion assert assertionLabel) = sequence [executeAssertion config assert assertionLabel a] +flattenAssertions config a (ParallelAssertions assertions) = concat <$> traverse (flattenAssertions config a) assertions +flattenAssertions _ _ (SequentialAssertions []) = pure [] +flattenAssertions config a (SequentialAssertions (x : xs)) = do + results <- flattenAssertions config a x + let isFailed = any isLeft results + if isFailed + then pure results + else flattenAssertions config a (SequentialAssertions xs) + +executeAssertion :: HasCallStack => AssertionConfig -> (Maybe String -> t2 -> IO ()) -> Maybe String -> t2 -> IO (Either AssertionFailure ()) +executeAssertion config assert assertionLabel given = do + result <- withTimeout $ do + !assertionResult <- try $ assert assertionLabel given + return assertionResult + case result of + Nothing -> + pure (Left $ AssertionFailure (maybe "" (\x -> "[" <> x <> "] ") assertionLabel <> timeoutMessage) location) + Just a -> pure a + where + withTimeout = timeout $ assertionTimeout config + timeoutMessage = "Timeout occurred, probably some infinitive data structure or not terminating predicate has been used. Timeout: " <> show timeoutInSeconds <> "s" + timeoutInSeconds :: Double + timeoutInSeconds = fromIntegral (assertionTimeout config) / 1000000.0 + location :: Maybe SrcLoc + location = case reverse (getCallStack callStack) of + (_, loc) : _ -> Just loc + [] -> Nothing + +transformAssertions :: [AssertionDefinition a] -> (b -> a) -> [AssertionDefinition b] +transformAssertions ((SimpleAssertion assert assertionLabel) : xs) f = SimpleAssertion (\l b -> assert (orElse l assertionLabel) (f b)) assertionLabel : transformAssertions xs f +transformAssertions ((ParallelAssertions assertions) : xs) f = ParallelAssertions (transformAssertions assertions f) : transformAssertions xs f +transformAssertions ((SequentialAssertions assertions) : xs) f = SequentialAssertions (transformAssertions assertions f) : transformAssertions xs f +transformAssertions [] _ = [] + +orElse :: Maybe a -> Maybe a -> Maybe a +x `orElse` y = case x of + Just _ -> x + Nothing -> y + +basicAssertion :: HasCallStack => (a -> Bool) -> (a -> String) -> AssertionDefinition a -> AssertionDefinition a +basicAssertion predicate messageFormatter b = b <> SimpleAssertion assert Nothing + where + assert assertionLabel a' = + if predicate a' + then pure () + else throwIO (AssertionFailure (maybe "" (\x -> "[" <> x <> "] ") assertionLabel <> messageFormatter a') location) + location :: Maybe SrcLoc + location = case reverse (getCallStack callStack) of + (_, loc) : _ -> Just loc + [] -> Nothing + +basicIOAssertion :: HasCallStack => (a -> Bool) -> (a -> String) -> AssertionDefinition (IO a) -> AssertionDefinition (IO a) +basicIOAssertion predicate messageFormatter b = b <> SimpleAssertion assert Nothing + where + assert assertionLabel a' = do + aaa <- a' + if predicate aaa + then pure () + else throwIO (AssertionFailure (maybe "" (\x -> "[" <> x <> "] ") assertionLabel <> messageFormatter aaa) location) + location :: Maybe SrcLoc + location = case reverse (getCallStack callStack) of + (_, loc) : _ -> Just loc + [] -> Nothing + +type Assertion'' s t a b = (a -> AssertionDefinition b) -> s -> AssertionDefinition t + +type Assertion' a b = Assertion'' a a b b + +type Assertion a = Assertion' a a diff --git a/test/AssertionSpecUtils.hs b/test/AssertionSpecUtils.hs new file mode 100644 --- /dev/null +++ b/test/AssertionSpecUtils.hs @@ -0,0 +1,29 @@ +module AssertionSpecUtils where + +import Control.Exception (try) +import Data.Bifunctor (Bifunctor (second), first) +import Data.Maybe (listToMaybe) +import GHC.Exception + ( SrcLoc (SrcLoc, srcLocEndLine, srcLocStartLine), + getCallStack, + ) +import GHC.Stack (HasCallStack, callStack) +import Test.Fluent.Assertions (FluentTestFailure (msg, srcLoc)) + +assertionMessage :: HasCallStack => String -> Int -> Int -> (String, Maybe SrcLoc) +assertionMessage message startLine endLine = (message, updateLocation loc) + where + loc = snd <$> listToMaybe (getCallStack callStack) + updateLocation (Just (SrcLoc a b c _ _ _ _)) = Just (SrcLoc a b c startLine 0 endLine 0) + updateLocation Nothing = Nothing + +testLocation :: HasCallStack => Int -> IO () -> IO ((Int, Int), Either FluentTestFailure ()) +testLocation offsetLine assertionToTest = do + res <- try assertionToTest + let updatedRes = first (\f -> f {srcLoc = updateLocation (srcLoc f), msg = updateAssertionLocation (msg f)}) res + pure ((srcLocStartLine loc + offsetLine, srcLocEndLine loc + offsetLine), updatedRes) + where + loc = snd $ head $ getCallStack callStack + updateLocation (Just (SrcLoc a b c lineStart _ lineEnd _)) = Just (SrcLoc a b c lineStart 0 lineEnd 0) + updateLocation Nothing = Nothing + updateAssertionLocation x = fmap (second updateLocation) x diff --git a/test/Assertions/ListsSpec.hs b/test/Assertions/ListsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Assertions/ListsSpec.hs @@ -0,0 +1,66 @@ +{-# OPTIONS_GHC -Wno-type-defaults #-} + +module Assertions.ListsSpec where + +import AssertionSpecUtils (assertionMessage, testLocation) +import Data.Either (fromLeft, isLeft, isRight) +import Test.Fluent.Assertions + ( FluentTestFailure (FluentTestFailure), + ) +import Test.Fluent.Assertions.Core + ( assertThat, + ) +import Test.Fluent.Assertions.List + ( shouldHaveSameElements, + shouldStartWith, + ) +import Test.Hspec + ( SpecWith, + describe, + hspec, + it, + shouldBe, + ) + +main :: IO () +main = hspec spec + +spec :: SpecWith () +spec = do + describe "lists" $ do + describe "shouldStartWith" $ do + it "fail once prefix has more elements than given list" $ do + ((startLine, endLine), res) <- testLocation 0 $ assertThat [0 .. 9] $ shouldStartWith [0 .. 10] + isLeft res `shouldBe` True + let (FluentTestFailure _ messages _ _) = fromLeft undefined res + messages + `shouldBe` [assertionMessage "the lenght of given list is 10, but should be lower or equal 11" startLine endLine] + it "fail once prefix is not same as expected" $ do + ((startLine, endLine), res) <- testLocation 0 $ assertThat [0 .. 9] $ shouldStartWith [1 .. 10] + isLeft res `shouldBe` True + let (FluentTestFailure _ messages _ _) = fromLeft undefined res + messages + `shouldBe` [assertionMessage "should start with [1,2,3,4,5,6,7,8,9,10], but it start with [0,1,2,3,4,5,6,7,8,9]" startLine endLine] + it "success once prefix match expected one" $ do + (_, res) <- testLocation 0 $ assertThat [0 .. 9] $ shouldStartWith [0 .. 9] + isRight res `shouldBe` True + describe "shouldHaveExactSameElements" $ do + it "fail once two lists have different lenght" $ do + ((startLine, endLine), res) <- testLocation 0 $ assertThat [0 .. 1000] $ shouldHaveSameElements [500 .. 50090] + isLeft res `shouldBe` True + let (FluentTestFailure _ messages _ _) = fromLeft undefined res + messages + `shouldBe` [assertionMessage "should have same leght, but they don't. Given: 1001 is not equal to expected 49591" startLine endLine] + it "fail once list don't have same elements as expected list" $ do + ((startLine, endLine), res) <- testLocation 0 $ assertThat [1, 2, 3] $ shouldHaveSameElements [1, 2, 4] + isLeft res `shouldBe` True + let (FluentTestFailure _ messages _ _) = fromLeft undefined res + messages + `shouldBe` [assertionMessage "two lists should have same elements but:\n given list don't have [4]\nexpected list don't have [3]" startLine endLine] + it "success once two lists are equal" $ do + let list = [1 .. 100] + (_, res) <- testLocation 0 $ assertThat list $ shouldHaveSameElements list + isRight res `shouldBe` True + it "success once two lists have same elements in different order" $ do + (_, res) <- testLocation 0 $ assertThat [1, 2, 3, 4, 5] $ shouldHaveSameElements [5, 2, 1, 3, 4] + isRight res `shouldBe` True diff --git a/test/Assertions/MaybeSpec.hs b/test/Assertions/MaybeSpec.hs new file mode 100644 --- /dev/null +++ b/test/Assertions/MaybeSpec.hs @@ -0,0 +1,58 @@ +{-# OPTIONS_GHC -Wno-type-defaults #-} + +module Assertions.MaybeSpec where + +import AssertionSpecUtils (assertionMessage, testLocation) +import Data.Either (fromLeft, isRight) +import Test.Fluent.Assertions + ( FluentTestFailure (FluentTestFailure), + isEqualTo, + ) +import Test.Fluent.Assertions.Core + ( assertThat, + ) +import Test.Fluent.Assertions.Maybe (extracting, isJust, isNothing) +import Test.Hspec (SpecWith, describe, hspec, it, shouldBe) + +main :: IO () +main = hspec spec + +spec :: SpecWith () +spec = do + describe "isJust" $ do + it "should pass" $ do + (_, res) <- testLocation 0 $ assertThat (Just 10) isJust + isRight res `shouldBe` True + it "should fail" $ do + ((startLine, endLine), res) <- testLocation 0 $ assertThat Nothing isJust + isRight res `shouldBe` False + let (FluentTestFailure _ messages _ _) = fromLeft undefined res + messages `shouldBe` [assertionMessage "should be Just" startLine endLine] + describe "isNothing" $ do + it "should pass" $ do + (_, res) <- testLocation 0 $ assertThat Nothing isNothing + isRight res `shouldBe` True + it "should fail" $ do + ((startLine, endLine), res) <- testLocation 0 $ assertThat (Just 10) isNothing + isRight res `shouldBe` False + let (FluentTestFailure _ messages _ _) = fromLeft undefined res + messages `shouldBe` [assertionMessage "should be Nothing" startLine endLine] + describe "extracting" $ do + it "should success when is Just" $ do + (_, res) <- testLocation 0 $ assertThat (Just 10) extracting + isRight res `shouldBe` True + it "should fail when given value is Nothing" $ do + ((startLine, endLine), res) <- testLocation 0 $ assertThat Nothing extracting + isRight res `shouldBe` False + let (FluentTestFailure _ messages _ _) = fromLeft undefined res + messages + `shouldBe` [assertionMessage "should be Just" startLine endLine] + it "should execute assertion on the extracted value" $ do + (_, res) <- testLocation 0 $ assertThat (Just 10) $ extracting . isEqualTo 10 + isRight res `shouldBe` True + it "should execute failed assertion on the extracted value" $ do + ((startLine, endLine), res) <- testLocation 0 $ assertThat (Just 10) $ extracting . isEqualTo 99 + isRight res `shouldBe` False + let (FluentTestFailure _ messages _ _) = fromLeft undefined res + messages + `shouldBe` [assertionMessage "given 10 should be equal to 99\n\9660\9660\n10\n\9591\n\9474\n\9589\n99\n\9650\9650\n" startLine endLine] diff --git a/test/AssertionsSpec.hs b/test/AssertionsSpec.hs new file mode 100644 --- /dev/null +++ b/test/AssertionsSpec.hs @@ -0,0 +1,215 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-type-defaults #-} + +module AssertionsSpec where + +import AssertionSpecUtils (assertionMessage, testLocation) +import Data.Either (fromLeft, isRight) +import Data.Function ((&)) +import Data.Maybe () +import GHC.Stack + ( SrcLoc + ( SrcLoc + ), + ) +import Test.Fluent.Assertions + ( contains, + defaultConfig, + hasSize, + isEmpty, + isEqualTo, + isGreaterEqualThan, + isGreaterThan, + isLowerEqualThan, + isLowerThan, + isNotEmpty, + isNotEqualTo, + setAssertionTimeout, + shouldSatisfy, + ) +import Test.Fluent.Internal.Assertions + ( FluentTestFailure (FluentTestFailure), + assertThat, + assertThat', + ) +import Test.Hspec (Spec, describe, hspec, it, shouldBe) + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + describe "chaining assertions" $ do + it "should accumulate errors" $ do + ((startLine, endLine), res) <- + testLocation 1 $ + assertThat "someString" $ + isLowerThan "someString" + . isNotEqualTo "someString" + . isGreaterThan "someString" + isRight res `shouldBe` False + let (FluentTestFailure assertThatLoc messages erros success) = fromLeft undefined res + erros `shouldBe` 3 + success `shouldBe` 0 + assertThatLoc `shouldBe` Just (SrcLoc "main" "AssertionsSpec" "test/AssertionsSpec.hs" startLine 0 endLine 0) + messages + `shouldBe` [ assertionMessage "given \"someString\" should be lower than \"someString\"" (startLine + 1) (endLine + 1), + assertionMessage "given \"someString\" should be not equal to \"someString\"" (startLine + 2) (endLine + 2), + assertionMessage "given \"someString\" should be greater than \"someString\"" (startLine + 3) (endLine + 3) + ] + describe "failing assertions" $ do + it "isEqualTo should report correct message" $ do + ((startLine, endLine), res) <- + testLocation 1 $ + assertThat "someString" $ + isEqualTo "otherString" + isRight res `shouldBe` False + let (FluentTestFailure assertThatLoc messages erros success) = fromLeft undefined res + erros `shouldBe` 1 + success `shouldBe` 0 + assertThatLoc `shouldBe` Just (SrcLoc "main" "AssertionsSpec" "test/AssertionsSpec.hs" startLine 0 endLine 0) + messages + `shouldBe` [assertionMessage "given \"someString\" should be equal to \"otherString\"\n \9660 \9660\n\"someString\"\n\9591\n\9474\n\9589\n\"otherString\"\n \9650\9650 \9650\n" (startLine + 1) (endLine + 1)] + it "isNotEqualTo should report correct message" $ do + ((startLine, endLine), res) <- + testLocation 1 $ + assertThat "someString" $ + isNotEqualTo "someString" + isRight res `shouldBe` False + let (FluentTestFailure assertThatLoc messages erros success) = fromLeft undefined res + erros `shouldBe` 1 + success `shouldBe` 0 + assertThatLoc `shouldBe` Just (SrcLoc "main" "AssertionsSpec" "test/AssertionsSpec.hs" startLine 0 endLine 0) + messages + `shouldBe` [assertionMessage "given \"someString\" should be not equal to \"someString\"" (startLine + 1) (endLine + 1)] + it "isGreaterThan should report correct message" $ do + ((startLine, endLine), res) <- testLocation 0 $ assertThat 5 $ isGreaterThan 6 + isRight res `shouldBe` False + let (FluentTestFailure assertThatLoc messages erros success) = fromLeft undefined res + erros `shouldBe` 1 + success `shouldBe` 0 + assertThatLoc `shouldBe` Just (SrcLoc "main" "AssertionsSpec" "test/AssertionsSpec.hs" startLine 0 endLine 0) + messages + `shouldBe` [assertionMessage "given 5 should be greater than 6" startLine endLine] + it "isGreaterEqualThan should report correct message" $ do + ((startLine, endLine), res) <- testLocation 0 $ assertThat 5 $ isGreaterEqualThan 6 + isRight res `shouldBe` False + let (FluentTestFailure assertThatLoc messages erros success) = fromLeft undefined res + erros `shouldBe` 1 + success `shouldBe` 0 + assertThatLoc `shouldBe` Just (SrcLoc "main" "AssertionsSpec" "test/AssertionsSpec.hs" startLine 0 endLine 0) + messages + `shouldBe` [assertionMessage "given 5 should be greater or equal to 6" startLine endLine] + it "isLowerThan should report correct message" $ do + ((startLine, endLine), res) <- testLocation 0 $ assertThat 5 $ isLowerThan 4 + isRight res `shouldBe` False + let (FluentTestFailure assertThatLoc messages erros success) = fromLeft undefined res + erros `shouldBe` 1 + success `shouldBe` 0 + assertThatLoc `shouldBe` Just (SrcLoc "main" "AssertionsSpec" "test/AssertionsSpec.hs" startLine 0 endLine 0) + messages + `shouldBe` [assertionMessage "given 5 should be lower than 4" startLine endLine] + it "isLowerEqualThan should report correct message" $ do + ((startLine, endLine), res) <- testLocation 0 $ assertThat 5 $ isLowerEqualThan 4 + isRight res `shouldBe` False + let (FluentTestFailure assertThatLoc messages erros success) = fromLeft undefined res + erros `shouldBe` 1 + success `shouldBe` 0 + assertThatLoc `shouldBe` Just (SrcLoc "main" "AssertionsSpec" "test/AssertionsSpec.hs" startLine 0 endLine 0) + messages + `shouldBe` [assertionMessage "given 5 should be lower or equal to 4" startLine endLine] + it "shouldSatisfy should report correct message" $ do + ((startLine, endLine), res) <- testLocation 0 $ assertThat 5 $ shouldSatisfy (< 5) + isRight res `shouldBe` False + let (FluentTestFailure assertThatLoc messages erros success) = fromLeft undefined res + erros `shouldBe` 1 + success `shouldBe` 0 + assertThatLoc `shouldBe` Just (SrcLoc "main" "AssertionsSpec" "test/AssertionsSpec.hs" startLine 0 endLine 0) + messages + `shouldBe` [assertionMessage "given 5 does not met a predicate" startLine endLine] + it "hasSize should report correct message" $ do + ((startLine, endLine), res) <- testLocation 0 $ assertThat [1 .. 7] $ hasSize 5 + isRight res `shouldBe` False + let (FluentTestFailure assertThatLoc messages erros success) = fromLeft undefined res + erros `shouldBe` 1 + success `shouldBe` 0 + assertThatLoc `shouldBe` Just (SrcLoc "main" "AssertionsSpec" "test/AssertionsSpec.hs" startLine 0 endLine 0) + messages + `shouldBe` [assertionMessage "expected size 5 is not equal actual size 7" startLine endLine] + it "isEmpty should report correct message" $ do + ((startLine, endLine), res) <- testLocation 0 $ assertThat (Just 1) $ isEmpty + isRight res `shouldBe` False + let (FluentTestFailure assertThatLoc messages erros success) = fromLeft undefined res + erros `shouldBe` 1 + success `shouldBe` 0 + assertThatLoc `shouldBe` Just (SrcLoc "main" "AssertionsSpec" "test/AssertionsSpec.hs" startLine 0 endLine 0) + messages + `shouldBe` [assertionMessage "should be empty, but is not" startLine endLine] + it "isNotEmpty should report correct message" $ do + ((startLine, endLine), res) <- testLocation 0 $ assertThat Nothing $ isNotEmpty + isRight res `shouldBe` False + let (FluentTestFailure assertThatLoc messages erros success) = fromLeft undefined res + erros `shouldBe` 1 + success `shouldBe` 0 + assertThatLoc `shouldBe` Just (SrcLoc "main" "AssertionsSpec" "test/AssertionsSpec.hs" startLine 0 endLine 0) + messages + `shouldBe` [assertionMessage "should be not empty" startLine endLine] + it "contains should report correct message" $ do + ((startLine, endLine), res) <- testLocation 0 $ assertThat (Just 1) $ contains 10 + isRight res `shouldBe` False + let (FluentTestFailure assertThatLoc messages erros success) = fromLeft undefined res + erros `shouldBe` 1 + success `shouldBe` 0 + assertThatLoc `shouldBe` Just (SrcLoc "main" "AssertionsSpec" "test/AssertionsSpec.hs" startLine 0 endLine 0) + messages + `shouldBe` [assertionMessage "should contain element 10, but it doesn't" startLine endLine] + it "report timeout" $ do + let config = defaultConfig & setAssertionTimeout 100000 + ((startLine, endLine), res) <- testLocation 0 $ assertThat' config [0 ..] $ isEqualTo [0 ..] + isRight res `shouldBe` False + let (FluentTestFailure assertThatLoc messages erros success) = fromLeft undefined res + erros `shouldBe` 1 + success `shouldBe` 0 + assertThatLoc `shouldBe` Just (SrcLoc "main" "AssertionsSpec" "test/AssertionsSpec.hs" startLine 0 endLine 0) + messages + `shouldBe` [assertionMessage "Timeout occurred, probably some infinitive data structure or not terminating predicate has been used. Timeout: 0.1s" startLine endLine] + describe "success assertions" $ do + it "isEqualTo should report correct message" $ do + (_, res) <- + testLocation 1 $ + assertThat "someString" $ + isEqualTo "someString" + isRight res `shouldBe` True + it "isNotEqualTo should report correct message" $ do + (_, res) <- + testLocation 1 $ + assertThat "someString" $ + isNotEqualTo "otherString" + isRight res `shouldBe` True + it "isGreaterThan should report correct message" $ do + (_, res) <- testLocation 0 $ assertThat 5 $ isGreaterThan 4 + isRight res `shouldBe` True + it "isGreaterEqualThan should report correct message" $ do + (_, res) <- testLocation 0 $ assertThat 5 $ isGreaterEqualThan 5 + isRight res `shouldBe` True + it "isLowerThan should report correct message" $ do + (_, res) <- testLocation 0 $ assertThat 5 $ isLowerThan 6 + isRight res `shouldBe` True + it "isLowerEqualThan should report correct message" $ do + (_, res) <- testLocation 0 $ assertThat 5 $ isLowerEqualThan 5 + isRight res `shouldBe` True + it "shouldSatisfy should report correct message" $ do + (_, res) <- testLocation 0 $ assertThat 5 $ shouldSatisfy (> 4) + isRight res `shouldBe` True + it "hasSize should report correct message" $ do + (_, res) <- testLocation 0 $ assertThat [0 .. 4] $ hasSize 5 + isRight res `shouldBe` True + it "isEmpty should report correct message" $ do + (_, res) <- testLocation 0 $ assertThat Nothing $ isEmpty + isRight res `shouldBe` True + it "isNotEmpty should report correct message" $ do + (_, res) <- testLocation 0 $ assertThat (Just 1) $ isNotEmpty + isRight res `shouldBe` True + it "contains should report correct message" $ do + (_, res) <- testLocation 0 $ assertThat (Just 10) $ contains 10 + isRight res `shouldBe` True diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}