1{-# LANGUAGE DeriveDataTypeable, BangPatterns #-}
2module Test.Tasty.HUnit.Steps (testCaseSteps) where
3
4import Control.Applicative
5import Control.Exception
6import Data.IORef
7import Data.List (foldl')
8import Data.Typeable (Typeable)
9import Prelude  -- Silence AMP import warnings
10import Test.Tasty.HUnit.Orig
11import Test.Tasty.Providers
12import Test.Tasty.Runners (getTime)
13import Text.Printf (printf)
14
15newtype TestCaseSteps = TestCaseSteps ((String -> IO ()) -> Assertion)
16  deriving Typeable
17
18instance IsTest TestCaseSteps where
19  run _ (TestCaseSteps assertionFn) _ = do
20    ref <- newIORef []
21
22    let
23      stepFn :: String -> IO ()
24      stepFn msg = do
25        tme <- getTime
26        atomicModifyIORef ref (\l -> ((tme,msg):l, ()))
27
28    hunitResult <- (Right <$> assertionFn stepFn) `catches`
29      [ Handler (\(HUnitFailure mbloc errMsg) -> return $ Left (prependLocation mbloc errMsg))
30      , Handler (\(SomeException ex)          -> return $ Left (show ex))
31      ]
32
33    endTime <- getTime
34
35    maxMsgLength <- foldl' max 0 . map (length . snd) <$> readIORef ref
36
37    let msgFormat = "%-" ++ show (min maxMsgLength 62) ++ "s (%.02fs)"
38
39    msgs <- snd . foldl'
40      (\(lastTime, acc) (curTime, msg) ->
41           let !duration = lastTime - curTime
42               !msg' = if duration >= 0.01 then printf msgFormat msg duration else msg
43            in (curTime, msg':acc))
44      (endTime, [])
45        <$> readIORef ref
46
47    return $
48      case hunitResult of
49
50        Right {} -> testPassed (unlines msgs)
51
52        Left errMsg -> testFailed $
53          if null msgs
54            then
55              errMsg
56            else
57              -- Indent the error msg w.r.t. step messages
58              unlines $
59                msgs ++ map ("  " ++) (lines errMsg)
60
61  testOptions = return []
62
63-- | Create a multi-step unit test.
64--
65-- Example:
66--
67-- >main = defaultMain $ testCaseSteps "Multi-step test" $ \step -> do
68-- >  step "Preparing..."
69-- >  -- do something
70-- >
71-- >  step "Running part 1"
72-- >  -- do something
73-- >
74-- >  step "Running part 2"
75-- >  -- do something
76-- >  assertFailure "BAM!"
77-- >
78-- >  step "Running part 3"
79-- >  -- do something
80--
81-- The @step@ calls are mere annotations. They let you see which steps were
82-- performed successfully, and which step failed.
83--
84-- You can think of @step@
85-- as 'putStrLn', except 'putStrLn' would mess up the output with the
86-- console reporter and get lost with the others.
87--
88-- For the example above, the output will be
89--
90-- >Multi-step test: FAIL
91-- >  Preparing...
92-- >  Running part 1
93-- >  Running part 2
94-- >    BAM!
95-- >
96-- >1 out of 1 tests failed (0.00s)
97--
98-- Note that:
99--
100-- * Tasty still treats this as a single test, even though it consists of
101-- multiple steps.
102--
103-- * The execution stops after the first failure. When we are looking at
104-- a failed test, we know that all /displayed/ steps but the last one were
105-- successful, and the last one failed. The steps /after/ the failed one
106-- are /not displayed/, since they didn't run.
107testCaseSteps :: TestName -> ((String -> IO ()) -> Assertion) -> TestTree
108testCaseSteps name = singleTest name . TestCaseSteps
109