{-# LANGUAGE DeriveDataTypeable #-}
module Test.Tasty.HUnit.Steps (testCaseSteps) where
import Control.Applicative
import Control.Exception
import Data.IORef
import Data.Typeable (Typeable)
import Prelude
import Test.Tasty.HUnit.Orig
import Test.Tasty.Providers
newtype TestCaseSteps = TestCaseSteps ((String -> IO ()) -> Assertion)
deriving Typeable
instance IsTest TestCaseSteps where
run :: OptionSet -> TestCaseSteps -> (Progress -> IO ()) -> IO Result
run _ (TestCaseSteps assertionFn :: (String -> IO ()) -> IO ()
assertionFn) _ = do
IORef [String]
ref <- [String] -> IO (IORef [String])
forall a. a -> IO (IORef a)
newIORef []
let
stepFn :: String -> IO ()
stepFn :: String -> IO ()
stepFn msg :: String
msg = IORef [String] -> ([String] -> ([String], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef [String]
ref (\l :: [String]
l -> (String
msgString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
l, ()))
Either HUnitFailure ()
hunitResult <- IO () -> IO (Either HUnitFailure ())
forall e a. Exception e => IO a -> IO (Either e a)
try ((String -> IO ()) -> IO ()
assertionFn String -> IO ()
stepFn)
[String]
msgs <- [String] -> [String]
forall a. [a] -> [a]
reverse ([String] -> [String]) -> IO [String] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef [String] -> IO [String]
forall a. IORef a -> IO a
readIORef IORef [String]
ref
Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return (Result -> IO Result) -> Result -> IO Result
forall a b. (a -> b) -> a -> b
$
case Either HUnitFailure ()
hunitResult of
Right {} -> String -> Result
testPassed ([String] -> String
unlines [String]
msgs)
Left (HUnitFailure mbloc :: Maybe SrcLoc
mbloc errMsg :: String
errMsg) -> String -> Result
testFailed (String -> Result) -> String -> Result
forall a b. (a -> b) -> a -> b
$
if [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
msgs
then
String
errMsg
else
[String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
[String]
msgs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (" " String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> [String]
lines (String -> [String]) -> (String -> String) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe SrcLoc -> String -> String
prependLocation Maybe SrcLoc
mbloc (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ String
errMsg)
testOptions :: Tagged TestCaseSteps [OptionDescription]
testOptions = [OptionDescription] -> Tagged TestCaseSteps [OptionDescription]
forall (m :: * -> *) a. Monad m => a -> m a
return []
testCaseSteps :: TestName -> ((String -> IO ()) -> Assertion) -> TestTree
testCaseSteps :: String -> ((String -> IO ()) -> IO ()) -> TestTree
testCaseSteps name :: String
name = String -> TestCaseSteps -> TestTree
forall t. IsTest t => String -> t -> TestTree
singleTest String
name (TestCaseSteps -> TestTree)
-> (((String -> IO ()) -> IO ()) -> TestCaseSteps)
-> ((String -> IO ()) -> IO ())
-> TestTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String -> IO ()) -> IO ()) -> TestCaseSteps
TestCaseSteps