diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Paolo Veronelli, Global Access GmbH (c) 2017-2020 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,39 @@ +[![CircleCI](https://circleci.com/gh/ptek/tasty-bdd/tree/master.svg?style=svg)](https://circleci.com/gh/ptek/tasty-bdd/tree/master) + +# Behavior-driven development + +## A [Haskell](https://www.haskell.org/) Behavior Driven Development framework featuring: + +* A type constrained language to express + * *Given* as ordered preconditions or + * *GivenAndAfter* as oredered preconditions with reversed order of teardown actions (sort of resource management) + * One only *When* to introduce a last precondition and catch it's output to be fed to + * Some *Then* tests that will receive the output of *When* +* Support for do notation via free monad for composing _givens_ and _thens_ +* One monad independent pure interpreter +* One driver for the great [tasty](https://github.com/feuerbach/tasty) test library, monad parametrized +* Support for [tasty-fail-fast](https://hackage.haskell.org/package/tasty-fail-fast) strategy flag which will not execute the teardown actions of the failed test +* A sophisticated form of value introspection to show the differences on equality failure from [tree-diff](https://github.com/phadej/tree-diffdifftree) package +* Recursive test decorators to prepend or append action to all the tests inside a test tree + +## Background + +[Behavior Driven Development](https://en.wikipedia.org/wiki/Behavior-driven_development) is a software development process that emerged from test-driven development (TDD) and is based on principles of [Hoare Logic](https://en.wikipedia.org/wiki/Hoare_logic). The process requires a strict structure of the tests - {Given} When {Then} - to make them understandable. + +## Example + +``` +import Test.Tasty.Bdd + +tests :: TestTree +tests = testBdd "Test sequence" + $ Given (print "Some effect") + $ Given (print "Another effect") + $ GivenAndAfter (print "Aquiring resource" >> return "Resource 1") + (print . ("Release "++)) + $ GivenAndAfter (print "Aquiring resource" >> return "Resource 2") + (print . ("Release "++)) + $ When (print "Action returning" >> return ([1..10]++[100..106]) :: IO [Int]) + $ Then (@?= ([1..10]++[700..706])) + $ End +``` 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/src/System/CaptureStdout.hs b/src/System/CaptureStdout.hs new file mode 100644 --- /dev/null +++ b/src/System/CaptureStdout.hs @@ -0,0 +1,27 @@ +{- +BSD3 credits to Merijn Verstraaten +-} + +module System.CaptureStdout (captureStdout) where + +import Control.Exception (SomeException, bracket, try) +import Data.Text +import Data.Text.IO (hGetContents) +import GHC.IO.Handle (hDuplicate, hDuplicateTo) +import System.IO (Handle, SeekMode (..), hFlush, hSeek, stdout) +import System.IO.Temp (withSystemTempFile) + +captureStdout :: String -> IO () -> IO Text +captureStdout tmp act = withSystemTempFile tmp $ \_ hnd -> do + let redirect :: IO Handle + redirect = do + hFlush stdout + hDuplicate stdout <* hDuplicateTo hnd stdout + + undo :: Handle -> IO () + undo h = hFlush stdout >> hDuplicateTo h stdout + + _ <- bracket redirect undo $ \_ -> try act :: IO (Either SomeException ()) + + hSeek hnd AbsoluteSeek 0 + hGetContents hnd diff --git a/src/Test/BDD/Language.hs b/src/Test/BDD/Language.hs new file mode 100644 --- /dev/null +++ b/src/Test/BDD/Language.hs @@ -0,0 +1,116 @@ +------------------------------------------------------------------------------- +------------------------------------------------------------------------------- +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- +-- Module : Test.BDD.Language +-- Copyright : (c) Paolo Veronelli, Pavlo Kerestey 2017 +-- License : BSD3 +-- Maintainer: paolo.veronelli@gmail.com +-- Stability : experimental +-- Portability: non-portable +-- +-- +-- The constrained language to define behaviors in BDD terminology +-- +-- @ +-- exampleL :: TestTree +-- exampleL = testBehavior "Test sequence" +-- $ Given (print "Some effect") +-- $ Given (print "Another effect") +-- $ GivenAndAfter (print "Aquiring resource" >> return "Resource 1") +-- (print . ("Release "++)) +-- $ GivenAndAfter (print "Aquiring resource" >> return "Resource 2") +-- (print . ("Release "++)) +-- $ When (print "Action returning" >> return ([1..10]++[100..106]) :: IO [Int]) +-- $ Then (@?= ([1..10]++[700..706])) +-- $ End +-- @ +module Test.BDD.Language + ( Language (..) + , BDDPreparing + , BDDTesting + , BDDTest (..) + , TestContext (..) + , context + , when + , tests + , interpret + , Phase (..) + ) +where + +import Lens.Micro +import Lens.Micro.TH + +-- | Separating the 2 phases by type +data Phase = Preparing | Testing + +-- | Recording given actions and type related teardowns +data TestContext m = forall r. TestContext (m r) (r -> m ()) + +-- | Bare hoare language +data Language m t q a where + -- | action to prepare the test + Given + :: m () + -> Language m t q 'Preparing + -> Language m t q 'Preparing + -- | action to prepare the test, and related teardown action + GivenAndAfter + :: m r + -> (r -> m ()) + -> Language m t q 'Preparing + -> Language m t q 'Preparing + -- | core logic of the test (last preparing action) + When + :: m t + -> Language m t q 'Testing + -> Language m t q 'Preparing + -- | action producing a test + Then + :: (t -> m q) + -> Language m t q 'Testing + -> Language m t q 'Testing + -- | final placeholder + End :: Language m t q 'Testing + +-- | Result of this module interpreter +data BDDTest m t q = BDDTest + { -- | tests from 't' + _tests :: [t -> m q] + , -- | test context + _context :: [TestContext m] + , -- | when action to compute 't' + _when :: m t + } + +makeLenses ''BDDTest + +-- | Preparing language types +type BDDPreparing m t q = Language m t q 'Preparing + +-- | Testing language types +type BDDTesting m t q = Language m t q 'Testing + +-- | An interpreter collecting the actions +interpret :: Monad m => Language m t q a -> BDDTest m t q +interpret (Given given p) = + interpret $ GivenAndAfter given (const $ return ()) p +interpret (GivenAndAfter given after p) = + over context ((:) $ TestContext given after) $ + interpret p +interpret (When fa p) = + set when fa $ interpret p +interpret (Then ca p) = over tests ((:) ca) $ interpret p +interpret End = + BDDTest [] [] $ + error "End on its own does not make sense as a test" diff --git a/src/Test/BDD/LanguageFree.hs b/src/Test/BDD/LanguageFree.hs new file mode 100644 --- /dev/null +++ b/src/Test/BDD/LanguageFree.hs @@ -0,0 +1,142 @@ +------------------------------------------------------------------------------- +------------------------------------------------------------------------------- +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} + +-- | Free monads to introduce do notation in ''Language'' +-- +-- Module : +-- Copyright : (c) Paolo Veronelli 2017 +-- License : All rights reserved +-- Maintainer: paolo.veronelli@gmail.com +-- Stability : experimental +-- Portability: non-portable +module Test.BDD.LanguageFree + ( given + , givenAndAfter_ + , givenAndAfter + , then_ + , then__ + , when_ + , GivenFree + , ThenFree + , FreeBDD + , testFreeBDD + , BDDResult (..) + -- , testBehaviorFree + -- + -- + ) +where + +-- import Control.Exception +import Control.Monad.Catch +import Control.Monad.Cont +import Control.Monad.Free +import Control.Monad.Reader + +-- | Separating the 2 phases by type +data Phase t = Preparing | Testing t + +-- | Bare hoare language +data Language m a where + -- | action to prepare the test + Given :: m a -> (a -> Language m 'Preparing) -> Language m 'Preparing + -- | action to prepare the test, and related teardown action + GivenAndAfter :: m (a, r) -> (r -> m ()) -> (a -> Language m 'Preparing) -> Language m 'Preparing + -- | core logic of the test (last preparing action) + When :: m t -> Language m ('Testing t) -> Language m 'Preparing + -- | action producing a test + Then :: (t -> m ()) -> Language m ('Testing t) -> Language m ('Testing t) + -- | final placeholder + End :: Language m x + And :: Language m 'Preparing -> Language m 'Preparing -> Language m 'Preparing + +data BDDResult m = Failed SomeException (m ()) | Succeded (m ()) + +type CJR m = ReaderT (m ()) m (BDDResult m) + +catchCJR :: MonadCatch m => CJR m -> CJR m +catchCJR f = catch f $ asks . Failed + +stepIn :: MonadCatch m => m a -> (a -> CJR m) -> CJR m +stepIn g q = catchCJR (lift g >>= q) + +interpret :: forall m. MonadCatch m => Language m 'Preparing -> m (BDDResult m) +interpret y = runReaderT (interpret' y) (return ()) + where + interpret' :: Language m 'Preparing -> CJR m + interpret' (Given g p) = stepIn g $ interpret' . p + interpret' (GivenAndAfter g z p) = + stepIn g $ \(x, r) -> local (z r >>) $ interpret' $ p x + interpret' (When fa p) = + stepIn fa $ \x -> interpretT' x p + interpret' (And f g) = do + r <- interpret' f + case r of + Succeded _ -> interpret' g + w -> pure w + interpret' End = asks Succeded + interpretT' :: t -> Language m ('Testing t) -> CJR m + interpretT' _ End = asks Succeded + interpretT' x (Then f p) = + stepIn (f x) $ \() -> interpretT' x p + +data GivenFree m a where + GivenFree :: m b -> (b -> a) -> GivenFree m a + GivenAndAfterFree :: m (b, r) -> (r -> m ()) -> (b -> a) -> GivenFree m a + WhenFree :: m t -> Free (ThenFree m t) c -> a -> GivenFree m a + +data ThenFree m t a + = ThenFree (t -> m ()) a + deriving (Functor) + +instance Functor (GivenFree m) where + fmap f (GivenFree m x) = GivenFree m $ f <$> x + fmap f (GivenAndAfterFree mr rm x) = GivenAndAfterFree mr rm $ f <$> x + fmap f (WhenFree mt ft x) = WhenFree mt ft $ f x + +type FreeBDD m x = Free (GivenFree m) x + +given :: m a -> Free (GivenFree m) a +given m = liftF $ GivenFree m id + +givenAndAfter :: m (b, r) -> (r -> m ()) -> Free (GivenFree m) b +givenAndAfter g td = liftF $ GivenAndAfterFree g td id + +givenAndAfter_ :: Functor m => m r -> (r -> m ()) -> Free (GivenFree m) () +givenAndAfter_ g td = liftF $ GivenAndAfterFree (((),) <$> g) td id + +when_ :: m t -> Free (ThenFree m t) b -> Free (GivenFree m) () +when_ mt ts = liftF $ WhenFree mt ts () + +thens :: Free (ThenFree m t) a -> Language m ('Testing t) +thens (Free (ThenFree m f)) = Then m $ thens f +thens (Pure _) = End + +bddFree :: Free (GivenFree m) x -> Language m 'Preparing +bddFree (Free (GivenFree m f)) = Given m $ bddFree <$> f +bddFree (Free (GivenAndAfterFree mr rm f)) = + GivenAndAfter mr rm $ bddFree <$> f +bddFree (Free (WhenFree mt ts f)) = And (When mt $ thens ts) (bddFree f) +bddFree (Pure _) = End + +then_ :: (t -> m ()) -> Free (ThenFree m t) () +then_ m = liftF $ ThenFree m () + +then__ :: m () -> Free (ThenFree m t) () +then__ = then_ . const + +testFreeBDD + :: (MonadCatch m) + => Free (GivenFree m) x + -> m (BDDResult m) +testFreeBDD = interpret . bddFree diff --git a/src/Test/Tasty/Bdd.hs b/src/Test/Tasty/Bdd.hs new file mode 100644 --- /dev/null +++ b/src/Test/Tasty/Bdd.hs @@ -0,0 +1,228 @@ +------------------------------------------------------------------------------- +------------------------------------------------------------------------------- +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | +-- Module : Test.Tasty.Bdd +-- Copyright : (c) Paolo Veronelli, Pavlo Kerestey 2017 +-- License : All rights reserved +-- Maintainer: paolo.veronelli@gmail.com +-- Stability : experimental +-- Portability: non-portable +-- +-- Tasty driver for 'Language' +module Test.Tasty.Bdd + ( (@?=) + , (@?/=) + , (^?=) + , (^?/=) + , acquire + , acquirePure + , Phase (..) + , Language (..) + , testBehavior + , testBehaviorIO + , BDDTesting + , BDDPreparing + , TestableMonad (..) + , failFastIngredients + , failFastTester + , prettyDifferences + , beforeEach + , afterEach + , before + , after + , onEach + , captureStdout + , testBehaviorF + ) +where + +import Control.Monad.Catch + ( Exception (..) + , MonadCatch (..) + , MonadThrow (..) + ) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Tagged (Tagged (..)) +import Data.TreeDiff +import Data.Typeable (Proxy (..), Typeable) +import System.CaptureStdout +import System.IO.Unsafe (unsafePerformIO) +import Test.BDD.Language +import Test.BDD.LanguageFree +import Test.Tasty + ( withResource + ) +import Test.Tasty.Ingredients.FailFast (FailFast (..), failFast) +import Test.Tasty.Options (OptionDescription (..), lookupOption) +import Test.Tasty.Providers + ( IsTest (..) + , singleTest + , testFailed + , testPassed + ) +import Test.Tasty.Runners +import Text.Printf (printf) + +data FreeBDDCase m = FreeBDDCase (m Result -> IO Result) (m (BDDResult m)) + +testBehaviorF + :: (Typeable m, MonadCatch m) + => (m Result -> IO Result) + -> String + -> FreeBDD m x + -> TestTree +testBehaviorF f s = singleTest s . FreeBDDCase f . testFreeBDD + +instance (MonadCatch m, Typeable m) => IsTest (FreeBDDCase m) where + run _ (FreeBDDCase rc test) _ = rc $ test >>= g + where + g (Failed e td) = do + td + maybe + (throwM e) + (return . testFailed . testFailMessage) + $ fromException e + g (Succeded td) = td >> return (testPassed "") + testOptions = Tagged [Option (Proxy :: Proxy FailFast)] + +-- | testable monads can map to IO a Tasty Result +class (MonadCatch m, MonadIO m, Monad m, Typeable m) => TestableMonad m where + runCase :: m Result -> IO Result + +instance TestableMonad IO where + runCase = id + +-- | any testable monad can make a BDDTest a tasty test +instance + (Typeable t, TestableMonad m) + => IsTest (BDDTest m t ()) + where + run os (BDDTest ts rup w) f = runCase $ do + teardowns <- + sequence_ . reverse <$> mapM (\(TestContext g a) -> a <$> g) rup + resultOfWhen <- w + let loop [] = return Nothing + loop (then' : xs) = do + liftIO $ + f + (Progress + "" + (fromIntegral (length xs) / fromIntegral (length ts))) + (then' resultOfWhen >> loop xs) + `catch` (\(EqualityDoesntHold e) -> return (Just e)) + resultOfThen <- loop ts + case resultOfThen of + Just reason -> do + case lookupOption os of + FailFast False -> teardowns + _ -> return () + return $ testFailed reason + Nothing -> teardowns >> return (testPassed "") + testOptions = Tagged [Option (Proxy :: Proxy FailFast)] + +-- | show a coloured difference of 2 values +prettyDifferences :: (ToExpr a) => a -> a -> String +prettyDifferences a1 a2 = + show $ ansiWlEditExpr $ exprDiff (toExpr a1) (toExpr a2) + +-- internal exception to trigger visual inspection on output +newtype EqualityDoesntHold = EqualityDoesntHold {testFailMessage :: String} + deriving (Show, Typeable) + +instance Exception EqualityDoesntHold + +infixl 4 @?= + +-- | equality test which show pretty differences on fail +(@?=) :: (ToExpr a, Eq a, Typeable a, MonadThrow m) => a -> a -> m () +a1 @?= a2 = + if a1 == a2 + then return () + else + throwM $ + EqualityDoesntHold $ + printf "Expected equality:\n%s" $ + prettyDifferences a1 a2 + +-- | inequality test which show pretty differences on fail +(@?/=) :: (ToExpr a, Eq a, Typeable a, MonadThrow m) => a -> a -> m () +a1 @?/= a2 = + if a1 /= a2 + then return () + else + throwM $ + EqualityDoesntHold $ + printf "Expected inequality:\n%s" $ + prettyDifferences a1 a2 + +-- | shortcut to ignore the input and run another action instead in Then +-- matching equality +(^?=) :: (ToExpr a, Eq a, Typeable a, MonadThrow m) => m a -> a -> b -> m () +f ^?= t = const $ f >>= (@?= t) + +-- | shortcut to ignore the input and run another action instead in Then +-- matching inequality +(^?/=) :: (ToExpr a, Eq a, Typeable a, MonadThrow m) => m a -> a -> b -> m () +f ^?/= t = const $ f >>= (@?/= t) + +-- | interpret 'Bdd' sentence to a single 'TestTree' +testBehavior + :: (MonadIO m, TestableMonad m, Typeable t) + => String -- ^ test name + -> BDDPreparing m t () -- ^ bdd test definition + -> TestTree -- ^ resulting tasty test +testBehavior s = singleTest s . interpret + +-- | specialize withResource to prepend an action +before :: IO () -> TestTree -> TestTree +before f = withResource f return . const + +-- | specialize withResource to append an action +after :: IO () -> TestTree -> TestTree +after f = withResource (return ()) (const f) . const + +-- | recursively prepend an action +beforeEach :: IO () -> TestTree -> TestTree +beforeEach = onEach . before + +-- | recursively modify a 'TestTree' +onEach :: (TestTree -> TestTree) -> TestTree -> TestTree +onEach op t@(SingleTest _ _) = op t +onEach op (TestGroup n ts) = TestGroup n $ (map $ onEach op) ts +onEach op (WithResource spec rf) = WithResource spec $ onEach op . rf +onEach op (AskOptions rf) = AskOptions $ onEach op . rf +onEach op (PlusTestOptions g t) = PlusTestOptions g $ onEach op t + +-- | recursively append an action +afterEach :: IO () -> TestTree -> TestTree +afterEach = onEach . after + +-- | specialize withResource to just acquire a resource +acquire :: MonadIO m => IO a -> (m a -> TestTree) -> TestTree +acquire f g = withResource f (const $ return ()) (g . liftIO) + +acquirePure :: IO a -> (a -> TestTree) -> TestTree +acquirePure f g = acquire f $ g . unsafePerformIO + +testBehaviorIO + :: (Typeable t, MonadIO m, TestableMonad m) + => String -- ^ test name + -> IO (BDDPreparing m t ()) -- ^ bdd test definition + -> TestTree -- ^ resulting tasty test +testBehaviorIO s f = acquirePure f (testBehavior s) + +-- | default test runner fail-fast aware +failFastTester :: TestTree -> IO () +failFastTester = defaultMainWithIngredients failFastIngredients + +-- | basic ingredients fail-fast aware +failFastIngredients :: [Ingredient] +failFastIngredients = [listingTests, failFast consoleTestReporter] diff --git a/tasty-bdd.cabal b/tasty-bdd.cabal new file mode 100644 --- /dev/null +++ b/tasty-bdd.cabal @@ -0,0 +1,82 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.33.0. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 3d09fd3039a4f97cb691e80b9e53f939dca22e70237df9634d3c473be516a0de + +name: tasty-bdd +version: 0.1.0.0 +synopsis: BDD tests language and tasty provider +description: https://gitlab.com/devs.global.de/tasty-bdd/-/blob/master/README.md +category: Test +homepage: https://gitlab.com/devs.global.de/tasty-bdd +author: Paolo Veronelli, Pavlo Kerestey +maintainer: paolo.veronelli@gmail.com +copyright: 2017 Paolo Veronelli +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + +library + exposed-modules: + Test.Tasty.Bdd + Test.BDD.Language + Test.BDD.LanguageFree + System.CaptureStdout + other-modules: + Paths_tasty_bdd + hs-source-dirs: + src + default-extensions: OverloadedStrings + ghc-options: -Wall + build-depends: + HUnit + , base >=4.7 && <5 + , exceptions + , free + , microlens + , microlens-th + , mtl + , pretty + , pretty-show + , tagged + , tasty + , tasty-fail-fast + , tasty-hunit + , temporary + , text + , transformers + , tree-diff + default-language: Haskell2010 + +test-suite test + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: + Paths_tasty_bdd + hs-source-dirs: + tests + default-extensions: OverloadedStrings + ghc-options: -Wall + build-depends: + HUnit + , aeson + , aeson-qq + , base >=4.7 && <5 + , exceptions + , mtl + , qm-interpolated-string + , regex-posix + , tasty + , tasty-bdd + , tasty-expected-failure + , tasty-fail-fast + , tasty-hunit + , temporary + , text + , transformers + default-language: Haskell2010 diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,150 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Main where + +import Control.Concurrent.MVar +import Control.Exception +import Test.BDD.LanguageFree +import qualified Test.HUnit as H +import Test.Tasty +import Test.Tasty.Bdd +import Test.Tasty.HUnit hiding ((@?=)) +import Test.Tasty.ExpectedFailure + +main :: IO () +main = defaultMain $ testGroup + "All" + [ testCase + "givens and givenandafter order is respected, constructors language" + $ do + let + t write = + defaultMain + $ testBehavior "Test sequence" + $ Given (write "First effect") + $ Given (write "Another effect") + $ GivenAndAfter + ( write "Aquiring resource" + >> return "Resource 1" + ) + (write . ("Release " ++)) + $ GivenAndAfter + ( write "Aquiring resource" + >> return "Resource 2" + ) + (write . ("Release " ++)) + $ When (write "Action returning") + $ Then (\_ -> return ()) End + testTest + t + [ "First effect" + , "Another effect" + , "Aquiring resource" + , "Aquiring resource" + , "Action returning" + , "Release Resource 2" + , "Release Resource 1" + ] + , testCase "3 givens and givenandafter order is respected, free language" + $ do + let + t write = defaultMain $ testBehaviorF id "test free" $ do + q <- given $ do + write "First effect" + return (1 :: Int) + given $ write "Another effect" + q' <- + givenAndAfter + ( write "Aquiring resource" + >> return (q + 1, "Resource " <> show q) + ) + $ write + . ("Release " ++) + givenAndAfter_ + ( write "Aquiring resource" + >> return ("Resource " <> show q') + ) + $ write + . ("Release " ++) + when_ (write "Action returning" >> return (q' + q)) $ do + then_ (@?= 7) + then_ (assertBool "less then" . (< 4)) + {-when_ (write "Action returning2" >> return "different type") $ do + then_ (@?= ("different typ" :: String))-} + testTest + t + [ "First effect" + , "Another effect" + , "Aquiring resource" + , "Aquiring resource" + , "Action returning" + -- , "Action returning2" + , "Release Resource 2" + , "Release Resource 1" + ] + , testCase + "3 givens and givenandafter order is respected, free language, with exceptions" + $ do + let + t write = defaultMain $ testBehaviorF id "test free" $ do + q <- given $ do + write "First effect" + return (1 :: Int) + given $ write "Another effect" + q' <- + givenAndAfter + ( write "Aquiring resource" + >> return (q + 1, "Resource " <> show q) + ) + $ write + . ("Release " ++) + givenAndAfter_ + ( write "Aquiring resource" + >> return ("Resource " <> show q') + ) + $ write + . ("Release " ++) + when_ ((1 :: Int) @?= 2 >> return (q' + q)) + $ then_ (@?= 3) + testTest + t + [ "First effect" + , "Another effect" + , "Aquiring resource" + , "Aquiring resource" + , "Release Resource 2" + , "Release Resource 1" + ] + , testCase "recursive before decorations are honored" $ do + let t write = defaultMain $ beforeEach (write 0) $ testGroup + "g1" + [ testCase "t1" $ write 1 + , testCase "t2" $ write 2 + , testGroup "g2" [testCase "t3" $ write 3] + , testCase "t4" $ write 4 + ] + testTest t ([0, 1, 0, 2, 0, 3, 0, 4] :: [Int]) + , testCase "recursive after decorations are honored" $ do + let t write = defaultMain $ afterEach (write 0) $ testGroup + "g1" + [ testCase "t1" $ write 1 + , testCase "t2" $ write 2 + , testGroup "g2" [testCase "t3" $ write 3] + , testCase "t4" $ write 4 + ] + testTest t ([1, 0, 2, 0, 3, 0, 4, 0] :: [Int]) + , expectFail $ testBehaviorF runCase "didn't break tasty" $ do + when_ (pure 42 :: IO Int) $ then_ $ \x -> x @?= 43 + + ] + + +testTest :: (Show a, Eq a) => ((a -> IO ()) -> IO ()) -> [a] -> IO () +testTest t r' = do + l <- newMVar [] + let write x = modifyMVar_ l (return . (x :)) + _ <- handle (\(_ :: SomeException) -> return "") + $ captureStdout "tasty-bdd-test-suite" + $ t write + r <- readMVar l + r H.@?= reverse r'