Bdd.hs

{-# 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-2020
License   :  BSD-3-Clause
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 (foldM)
import Control.Monad.Catch
    ( Exception (..)
    , MonadCatch (..)
    , MonadThrow (..)
    , catchAll
    )
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Maybe (fromMaybe, isNothing)
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))

-- | Adapt a free-monad scenario to Tasty using a runner for its monad.
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 `catchAll` const (return ())
            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, acquisitionFailure) <- acquireAll rup
        outcome <- case acquisitionFailure of
            Just rethrow -> return $ Left rethrow
            Nothing -> (Right <$> (w >>= loop)) `catchAll` (return . Left . throwM)
        let stepsPassed = either (const False) isNothing outcome
        teardownFailure <- case lookupOption os of
            FailFast True | not stepsPassed -> return Nothing
            _ -> releaseAll teardowns
        case (outcome, teardownFailure) of
            (Left rethrow, _) -> rethrow
            (Right (Just reason), _) -> return $ testFailed reason
            (Right Nothing, Just rethrow) -> rethrow
            (Right Nothing, Nothing) -> return $ testPassed ""
      where
        loop resultOfWhen = go ts
          where
            go [] = return Nothing
            go (then' : xs) = do
                liftIO $
                    f
                        ( Progress
                            ""
                            (fromIntegral (length xs) / fromIntegral (length ts))
                        )
                (then' resultOfWhen >> go xs)
                    `catch` (\(EqualityDoesntHold e) -> return (Just e))
    testOptions = Tagged [Option (Proxy :: Proxy FailFast)]

{- | Run the acquisitions in order, stopping at the first that throws.
Returns the teardowns of the acquired resources, most recent first, and,
if an acquisition threw, the action rethrowing its exception.
-}
acquireAll
    :: (MonadCatch m)
    => [TestContext m]
    -> m ([m ()], Maybe (m Result))
acquireAll = go []
  where
    go held [] = return (held, Nothing)
    go held (TestContext g a : cs) = do
        acquired <- (Right <$> g) `catchAll` (return . Left . throwM)
        case acquired of
            Left rethrow -> return (held, Just rethrow)
            Right r -> go (a r : held) cs

{- | Run every teardown in order, even when one throws. Returns the action
rethrowing the exception of the first teardown that threw, if any.
-}
releaseAll :: (MonadCatch m) => [m ()] -> m (Maybe (m Result))
releaseAll = foldM release Nothing
  where
    release first td =
        (td >> return first)
            `catchAll` \e -> return $ Just $ fromMaybe (throwM e) first

-- | 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)

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 a 'Language' scenario 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
onEach op (After x y t) = After x y $ 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)

-- | Acquire a resource and expose its value through the resource callback.
acquirePure :: IO a -> (a -> TestTree) -> TestTree
acquirePure f g = acquire f $ g . unsafePerformIO

-- | Acquire a constructor-based scenario in IO and adapt it to Tasty.
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]