diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,7 @@ +# Changelog for assert4hs + +## 0.0.0.1 + +- Initial release + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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) diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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 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.cabal b/assert4hs.cabal new file mode 100644 --- /dev/null +++ b/assert4hs.cabal @@ -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 + +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 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,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 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,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 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/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,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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -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 + ] diff --git a/test/TestCase.hs b/test/TestCase.hs new file mode 100644 --- /dev/null +++ b/test/TestCase.hs @@ -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 "")