tasty-bdd (empty) → 0.1.0.0
raw patch · 9 files changed
+816/−0 lines, 9 filesdep +HUnitdep +aesondep +aeson-qqsetup-changed
Dependencies added: HUnit, aeson, aeson-qq, base, exceptions, free, microlens, microlens-th, mtl, pretty, pretty-show, qm-interpolated-string, regex-posix, tagged, tasty, tasty-bdd, tasty-expected-failure, tasty-fail-fast, tasty-hunit, temporary, text, transformers, tree-diff
Files
- LICENSE +30/−0
- README.md +39/−0
- Setup.hs +2/−0
- src/System/CaptureStdout.hs +27/−0
- src/Test/BDD/Language.hs +116/−0
- src/Test/BDD/LanguageFree.hs +142/−0
- src/Test/Tasty/Bdd.hs +228/−0
- tasty-bdd.cabal +82/−0
- tests/Main.hs +150/−0
+ LICENSE view
@@ -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.
+ README.md view
@@ -0,0 +1,39 @@+[](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+```
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/System/CaptureStdout.hs view
@@ -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
+ src/Test/BDD/Language.hs view
@@ -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"
+ src/Test/BDD/LanguageFree.hs view
@@ -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
+ src/Test/Tasty/Bdd.hs view
@@ -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]
+ tasty-bdd.cabal view
@@ -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
+ tests/Main.hs view
@@ -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'