    {-# 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 ()
    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
            -- The number of steps is not fixed, so we can't
            -- provide the progress percentage.
            -- We also don't provide the timings here, only
            -- at the end.
            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
                  -- 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 a. a -> Tagged TestCaseSteps a
    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