{-# LANGUAGE DeriveDataTypeable, BangPatterns #-}
module Test.Tasty.HUnit.Steps (testCaseSteps) where
import Control.Applicative
import Control.Exception
import Data.IORef
import Data.List (foldl')
import Data.Typeable (Typeable)
import Prelude
import Test.Tasty.HUnit.Orig
import Test.Tasty.Providers
import Test.Tasty.Runners (getTime)
import Text.Printf (printf)
newtype TestCaseSteps = TestCaseSteps ((String -> IO ()) -> Assertion)
deriving Typeable
instance IsTest TestCaseSteps where
run :: OptionSet -> TestCaseSteps -> (Progress -> IO ()) -> IO Result
run OptionSet
_ (TestCaseSteps (String -> IO ()) -> IO ()
assertionFn) Progress -> IO ()
yieldProgress = do
ref <- [(Time, String)] -> IO (IORef [(Time, String)])
forall a. a -> IO (IORef a)
newIORef []
let
stepFn :: String -> IO ()
stepFn String
msg = do
tme <- IO Time
getTime
yieldProgress (Progress msg 0)
atomicModifyIORef ref (\[(Time, String)]
l -> ((Time
tme,String
msg)(Time, String) -> [(Time, String)] -> [(Time, String)]
forall a. a -> [a] -> [a]
:[(Time, String)]
l, ()))
hunitResult <- (Right <$> assertionFn stepFn) `catch`
\(SomeException e
ex) -> Either String () -> IO (Either String ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String () -> IO (Either String ()))
-> Either String () -> IO (Either String ())
forall a b. (a -> b) -> a -> b
$ String -> Either String ()
forall a b. a -> Either a b
Left (e -> String
forall e. Exception e => e -> String
displayException e
ex)
endTime <- getTime
maxMsgLength <- foldl' max 0 . map (length . snd) <$> readIORef ref
let msgFormat = String
"%-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
maxMsgLength Int
62) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"s (%.02fs)"
msgs <- snd . foldl'
(\(Time
lastTime, [String]
acc) (Time
curTime, String
msg) ->
let !duration :: Time
duration = Time
lastTime Time -> Time -> Time
forall a. Num a => a -> a -> a
- Time
curTime
!msg' :: String
msg' = if Time
duration Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
>= Time
0.01 then String -> String -> Time -> String
forall r. PrintfType r => String -> r
printf String
msgFormat String
msg Time
duration else String
msg
in (Time
curTime, String
msg'String -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
acc))
(endTime, [])
<$> readIORef ref
return $
case hunitResult of
Right {} -> String -> Result
testPassed ([String] -> String
unlines [String]
msgs)
Left String
errMsg -> String -> Result
testFailed (String -> Result) -> String -> Result
forall a b. (a -> b) -> a -> b
$
if [String] -> Bool
forall a. [a] -> 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 -> String
forall a. [a] -> [a] -> [a]
++) (String -> [String]
lines String
errMsg)
testOptions :: Tagged TestCaseSteps [OptionDescription]
testOptions = [OptionDescription] -> Tagged TestCaseSteps [OptionDescription]
forall a. a -> Tagged TestCaseSteps a
forall (m :: * -> *) a. Monad m => a -> m a
return []
testCaseSteps :: TestName -> ((String -> IO ()) -> Assertion) -> TestTree
testCaseSteps :: String -> ((String -> IO ()) -> IO ()) -> TestTree
testCaseSteps 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