packages feed

assert4hs (empty) → 0.0.0.1

raw patch · 13 files changed

+1016/−0 lines, 13 filesdep +assert4hsdep +basedep +data-defaultsetup-changed

Dependencies added: assert4hs, base, data-default, pretty-diff, tasty, text

Files

+ ChangeLog.md view
@@ -0,0 +1,7 @@+# Changelog for assert4hs++## 0.0.0.1++- Initial release++## Unreleased changes
+ LICENSE view
@@ -0,0 +1,22 @@+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.+>>>>>>> af6fb2e (Initial commit)
+ README.md view
@@ -0,0 +1,149 @@+# 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-tasty](https://github.com/paweln1986/assert4hs-tasty) - assert4hs provider for tasty
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ assert4hs.cabal view
@@ -0,0 +1,71 @@+cabal-version:      1.12+name:               assert4hs+version:            0.0.0.1+license:            MIT+license-file:       LICENSE+copyright:          2021 Pawel Nosal+maintainer:         p.nosal1986@gmail.com+author:             Pawel Nosal+homepage:           https://github.com/paweln1986/assert4hs#readme+bug-reports:        https://github.com/paweln1986/assert4hs/issues+synopsis:           A set of assertion for writing more readable tests cases+description:+    Please see the README on GitHub at <https://github.com/paweln1986/assert4hs#readme>++category:           Testing+build-type:         Simple+extra-source-files:+    README.md+    ChangeLog.md++source-repository head+    type:     git+    location: https://github.com/paweln1986/assert4hs++library+    exposed-modules:+        Test.Fluent.Assertions+        Test.Fluent.Assertions.Either+        Test.Fluent.Assertions.Exceptions+        Test.Fluent.Assertions.Maybe+        Test.Fluent.Diff+        Test.Fluent.Internal.Assertions++    hs-source-dirs:     src+    other-modules:      Paths_assert4hs+    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-test+    type:               exitcode-stdio-1.0+    main-is:            Spec.hs+    hs-source-dirs:     test+    other-modules:+        TestCase+        Paths_assert4hs++    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 -any,+        base >=4.7 && <5,+        data-default >=0.7.1.1,+        pretty-diff >=0.4.0.0,+        tasty >=1.4.1,+        text >=1.2.4.1
+ src/Test/Fluent/Assertions.hs view
@@ -0,0 +1,275 @@+{-# 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 util functions+    assertThat,++    -- * 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.Assertions+  ( Assertion,+    Assertion',+    AssertionDefinition (SequentialAssertions),+    FluentTestFailure (..),+    assertThat,+    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 (== False) 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)++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
+ src/Test/Fluent/Assertions/Either.hs view
@@ -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)
+ src/Test/Fluent/Assertions/Exceptions.hs view
@@ -0,0 +1,90 @@+{-# 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 mudule provide an assertion for check if expected Exception has been throw by IO action.+module Test.Fluent.Assertions.Exceptions+  ( -- ** Assertion util functions+    assertThrowing,+    assertThrowing',++    -- ** Exception selectors+    anyException,+    anyIOException,+    exceptionOfType,++    -- ** Exception selector type+    ExceptionSelector,+  )+where++import Control.Exception+  ( Exception (fromException),+    IOException,+    SomeException,+    throwIO,+    try,+  )+import Data.Data (typeOf)+import GHC.Exception+  ( getCallStack,+  )+import GHC.Stack (HasCallStack, callStack)+import Test.Fluent.Assertions (simpleAssertion)+import Test.Fluent.Internal.Assertions+  ( Assertion',+    FluentTestFailure (FluentTestFailure),+    assertThat',+  )++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++assertThrowing' :: (HasCallStack, Exception e) => IO a -> ExceptionSelector e -> IO ()+assertThrowing' givenIO selector = assertThrowing givenIO selector (simpleAssertion (const True) (const "should not be invoked"))++assertThrowing :: (HasCallStack, Exception e) => IO a -> ExceptionSelector e -> Assertion' e b -> IO ()+assertThrowing givenIO predicate = assertThat' 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
+ src/Test/Fluent/Assertions/Maybe.hs view
@@ -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
+ src/Test/Fluent/Diff.hs view
@@ -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
+ src/Test/Fluent/Internal/Assertions.hs view
@@ -0,0 +1,142 @@+{-# 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)++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 []++assertThat :: HasCallStack => a -> Assertion' a b -> IO ()+assertThat given = assertThat' (pure given) id++assertThat' :: HasCallStack => IO a -> (IO a -> IO b) -> Assertion' b c -> IO ()+assertThat' 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 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 :: a -> AssertionDefinition a -> IO [Either AssertionFailure ()]+flattenAssertions a (SimpleAssertion assert assertionLabel) = sequence [try $ assert assertionLabel a]+flattenAssertions a (ParallelAssertions assertions) = concat <$> traverse (flattenAssertions a) assertions+flattenAssertions _ (SequentialAssertions []) = pure []+flattenAssertions a (SequentialAssertions (x : xs)) = do+  results <- flattenAssertions a x+  let isFailed = any isLeft results+  if isFailed+    then pure results+    else flattenAssertions a (SequentialAssertions xs)++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
+ test/Spec.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -Wno-incomplete-patterns #-}++import Control.Exception (Exception, throwIO)+import Test.Fluent.Assertions+import Test.Fluent.Assertions.Exceptions+  ( assertThrowing,+    exceptionOfType,+  )+import TestCase (fluentTestCase)+import Test.Tasty (TestTree, defaultMain, testGroup)++main :: IO ()+main = defaultMain tests++tests :: TestTree+tests = testGroup "Tests" [unitTests]++data Foo = Foo {name :: String, age :: Int} deriving (Show, Eq)++data MyException = ThisException | ThatException+  deriving (Show)++instance Exception MyException++data MyException1 = ThisException1 | ThatException1+  deriving (Show)++instance Exception MyException1++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))++unitTests :: TestTree+unitTests =+  testGroup+    "Unit tests"+    [ testGroup+        "Unit tests"+        [],+      -- fluentTestCase "test fluent1" $+      -- assertThat @String "1    " $ isNotEqualTo "" . focus length . isEqualTo 10 . tag "sdfadasdaf"++      -- fluentTestCase "sadf" $+      --   assertThat (Foo "someName" 15) $+      --     tag "foo" . isEqualTo (Foo "someN1ame" 15)+      --       . inside age (tag "age" . isGreaterThan 20 . isLowerThan 10)+      --       . tag "not equal to"+      --       . isNotEqualTo (Foo "someName" 15),+      -- fluentTestCase "sadf" $+      --   assertThrowing (throwIO ThatException) (exceptionOfType @MyException1) $+      --     shouldSatisfy+      --       ( \case+      --           ThisException1 -> True+      --       ),++      fluentTestCase "chaining assertions" $ do+        let result = 4+        assertThat result $+          isGreaterThan 5+            . isLowerThan 20,+      fluentTestCase "focusing on part of data structure" $ do+        assertThat (Foo "someName" 15) $+          isEqualTo (Foo "someName" 15)+            . focus age+            . isGreaterThan 20+            . isLowerEqualThan 5,+      fluentTestCase "Changing subject uder test" $ do+        assertThat (Foo "someName" 15) $+          inside age (isGreaterThan 20 . isLowerEqualThan 5)+            . focus name+            . isEqualTo "someName1",+      fluentTestCase "Tagging assertions" $ do+        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",+      fluentTestCase "Custom assertions" $ do+        assertThat (Foo "someName" 15) isSuitableForEmployment,+        fluentTestCase "Custom assertions" $ do+        assertThat (Foo "someName" 76) isSuitableForEmployment+    ]
+ test/TestCase.hs view
@@ -0,0 +1,47 @@+module TestCase (fluentTestCase) where++import Control.Exception (try)+import Data.Data (Typeable)+import Data.List (intercalate)+import GHC.Exception (SrcLoc (srcLocFile, srcLocStartLine))+import Test.Fluent.Assertions+  ( FluentTestFailure (FluentTestFailure),+  )+import Test.Tasty.Providers+  ( IsTest (..),+    TestName,+    TestTree,+    singleTest,+    testFailedDetails,+    testPassed,+  )+import Test.Tasty.Providers.ConsoleFormat+  ( ResultDetailsPrinter (..),+    failFormat,+  )++newtype FluentTestCase = FluentTestCase (IO String)+  deriving (Typeable)++failedAssertionResultPrinter :: Int -> Int -> ResultDetailsPrinter+failedAssertionResultPrinter errors successes = ResultDetailsPrinter $ \ident formater ->+  formater failFormat (putStrLn $ replicate (ident + 2) ' ' ++ "passed: " ++ show successes ++ ", failed: " ++ show errors ++ ", total: " ++ show (errors + successes))++instance IsTest FluentTestCase where+  run _ (FluentTestCase assertions) _ = do+    result <- try assertions+    pure $+      case result of+        Right info -> testPassed info+        Left (FluentTestFailure _ msg errors successes) -> testFailedDetails (prependLocation msg) (failedAssertionResultPrinter errors successes)+  testOptions = pure []++prependLocation :: [(String, Maybe SrcLoc)] -> String+prependLocation assertionErrors = intercalate "\n\n" $ fmap toLine assertionErrors+  where+    toLine (s, mbloc) = case mbloc of+      Nothing -> s+      Just loc -> "(" <> srcLocFile loc ++ ":" ++ show (srcLocStartLine loc) <> "): \n" <> s++fluentTestCase :: TestName -> IO () -> TestTree+fluentTestCase name = singleTest name . FluentTestCase . fmap (const "")