{-# 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  -- Silence AMP import warnings
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 ()
_ = do
    IORef [(Time, String)]
ref <- [(Time, String)] -> IO (IORef [(Time, String)])
forall a. a -> IO (IORef a)
newIORef []

    let
      stepFn :: String -> IO ()
      stepFn :: String -> IO ()
stepFn String
msg = do
        Time
tme <- IO Time
getTime
        IORef [(Time, String)]
-> ([(Time, String)] -> ([(Time, String)], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef [(Time, String)]
ref (\[(Time, String)]
l -> ((Time
tme,String
msg)(Time, String) -> [(Time, String)] -> [(Time, String)]
forall a. a -> [a] -> [a]
:[(Time, String)]
l, ()))

    Either String ()
hunitResult <- (() -> Either String ()
forall a b. b -> Either a b
Right (() -> Either String ()) -> IO () -> IO (Either String ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> IO ()) -> IO ()
assertionFn String -> IO ()
stepFn) IO (Either String ())
-> [Handler (Either String ())] -> IO (Either String ())
forall a. IO a -> [Handler a] -> IO a
`catches`
      [ (HUnitFailure -> IO (Either String ()))
-> Handler (Either String ())
forall a e. Exception e => (e -> IO a) -> Handler a
Handler (\(HUnitFailure Maybe SrcLoc
mbloc String
errMsg) -> Either String () -> IO (Either String ())
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 (Maybe SrcLoc -> String -> String
prependLocation Maybe SrcLoc
mbloc String
errMsg))
      , (SomeException -> IO (Either String ()))
-> Handler (Either String ())
forall a e. Exception e => (e -> IO a) -> Handler a
Handler (\(SomeException e
ex)          -> Either String () -> IO (Either String ())
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 a. Show a => a -> String
show e
ex))
      ]

    Time
endTime <- IO Time
getTime

    Int
maxMsgLength <- (Int -> Int -> Int) -> Int -> [Int] -> Int
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 ([Int] -> Int)
-> ([(Time, String)] -> [Int]) -> [(Time, String)] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Time, String) -> Int) -> [(Time, String)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (String -> Int)
-> ((Time, String) -> String) -> (Time, String) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Time, String) -> String
forall a b. (a, b) -> b
snd) ([(Time, String)] -> Int) -> IO [(Time, String)] -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef [(Time, String)] -> IO [(Time, String)]
forall a. IORef a -> IO a
readIORef IORef [(Time, String)]
ref

    let msgFormat :: String
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)"

    [String]
msgs <- (Time, [String]) -> [String]
forall a b. (a, b) -> b
snd ((Time, [String]) -> [String])
-> ([(Time, String)] -> (Time, [String]))
-> [(Time, String)]
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Time, [String]) -> (Time, String) -> (Time, [String]))
-> (Time, [String]) -> [(Time, String)] -> (Time, [String])
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
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))
      (Time
endTime, [])
        ([(Time, String)] -> [String])
-> IO [(Time, String)] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef [(Time, String)] -> IO [(Time, String)]
forall a. IORef a -> IO a
readIORef IORef [(Time, 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 String ()
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 (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
msgs
            then
              String
errMsg
            else
              -- Indent the error msg w.r.t. step messages
              [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 (m :: * -> *) a. Monad m => a -> m a
return []

-- | Create a multi-step unit test.
--
-- Example:
--
-- >main = defaultMain $ testCaseSteps "Multi-step test" $ \step -> do
-- >  step "Preparing..."
-- >  -- do something
-- >
-- >  step "Running part 1"
-- >  -- do something
-- >
-- >  step "Running part 2"
-- >  -- do something
-- >  assertFailure "BAM!"
-- >
-- >  step "Running part 3"
-- >  -- do something
--
-- The @step@ calls are mere annotations. They let you see which steps were
-- performed successfully, and which step failed.
--
-- You can think of @step@
-- as 'putStrLn', except 'putStrLn' would mess up the output with the
-- console reporter and get lost with the others.
--
-- For the example above, the output will be
--
-- >Multi-step test: FAIL
-- >  Preparing...
-- >  Running part 1
-- >  Running part 2
-- >    BAM!
-- >
-- >1 out of 1 tests failed (0.00s)
--
-- Note that:
--
-- * Tasty still treats this as a single test, even though it consists of
-- multiple steps.
--
-- * The execution stops after the first failure. When we are looking at
-- a failed test, we know that all /displayed/ steps but the last one were
-- successful, and the last one failed. The steps /after/ the failed one
-- are /not displayed/, since they didn't run.
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