{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ExistentialQuantification #-}
-- |
-- Stability: unstable
--
-- This is an unstable API.  Use
-- [Test.Hspec.Api.Format.V2](https://hackage.haskell.org/package/hspec-api/docs/Test-Hspec-Api-Format-V2.html)
-- instead.
module Test.Hspec.Core.Format
-- {-# WARNING "Use [Test.Hspec.Api.Format.V2](https://hackage.haskell.org/package/hspec-api/docs/Test-Hspec-Api-Format-V2.html) instead." #-}
(
  Format
, FormatConfig(..)
, defaultFormatConfig
, Event(..)
, Progress
, Path
, Location(..)
, Seconds(..)
, Item(..)
, Result(..)
, FailureReason(..)
, monadic
) where

import           Prelude ()
import           Test.Hspec.Core.Compat

import           Control.Concurrent
import           Control.Concurrent.Async (Async, async)
import qualified Control.Concurrent.Async as Async
import           Control.Monad.IO.Class

import           Test.Hspec.Core.Example (Progress, Location(..), FailureReason(..))
import           Test.Hspec.Core.Util (Path, formatExceptionWith)
import           Test.Hspec.Core.Clock (Seconds(..))

type Format = Event -> IO ()

data Item = Item {
  Item -> Maybe Location
itemLocation :: Maybe Location
, Item -> Seconds
itemDuration :: Seconds
, Item -> String
itemInfo :: String
, Item -> Result
itemResult :: Result
} deriving Int -> Item -> ShowS
[Item] -> ShowS
Item -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Item] -> ShowS
$cshowList :: [Item] -> ShowS
show :: Item -> String
$cshow :: Item -> String
showsPrec :: Int -> Item -> ShowS
$cshowsPrec :: Int -> Item -> ShowS
Show

data Result =
    Success
  | Pending (Maybe Location) (Maybe String)
  | Failure (Maybe Location) FailureReason
  deriving Int -> Result -> ShowS
[Result] -> ShowS
Result -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Result] -> ShowS
$cshowList :: [Result] -> ShowS
show :: Result -> String
$cshow :: Result -> String
showsPrec :: Int -> Result -> ShowS
$cshowsPrec :: Int -> Result -> ShowS
Show

data Event =
    Started
  | GroupStarted Path
  | GroupDone Path
  | Progress Path Progress
  | ItemStarted Path
  | ItemDone Path Item
  | Done [(Path, Item)]
  deriving Int -> Event -> ShowS
[Event] -> ShowS
Event -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Event] -> ShowS
$cshowList :: [Event] -> ShowS
show :: Event -> String
$cshow :: Event -> String
showsPrec :: Int -> Event -> ShowS
$cshowsPrec :: Int -> Event -> ShowS
Show

data FormatConfig = FormatConfig {
  FormatConfig -> Bool
formatConfigUseColor :: Bool
, FormatConfig -> Bool
formatConfigReportProgress :: Bool
, FormatConfig -> Bool
formatConfigOutputUnicode :: Bool
, FormatConfig -> Bool
formatConfigUseDiff :: Bool
, FormatConfig -> Maybe Int
formatConfigDiffContext :: Maybe Int
, FormatConfig -> Maybe (String -> String -> IO ())
formatConfigExternalDiff :: Maybe (String -> String -> IO ())
, FormatConfig -> Bool
formatConfigPrettyPrint :: Bool
, FormatConfig -> Maybe (String -> String -> (String, String))
formatConfigPrettyPrintFunction :: Maybe (String -> String -> (String, String))
, FormatConfig -> SomeException -> String
formatConfigFormatException :: SomeException -> String -- ^ @since 2.11.5
, FormatConfig -> Bool
formatConfigPrintTimes :: Bool
, FormatConfig -> Bool
formatConfigHtmlOutput :: Bool
, FormatConfig -> Bool
formatConfigPrintCpuTime :: Bool
, FormatConfig -> Integer
formatConfigUsedSeed :: Integer
, FormatConfig -> Int
formatConfigExpectedTotalCount :: Int
, FormatConfig -> Bool
formatConfigExpertMode :: Bool
}

{-# DEPRECATED formatConfigPrettyPrint "Use `formatConfigPrettyPrintFunction` instead" #-}

-- ^ @since 2.11.5
defaultFormatConfig :: FormatConfig
defaultFormatConfig :: FormatConfig
defaultFormatConfig = FormatConfig {
  formatConfigUseColor :: Bool
formatConfigUseColor = Bool
False
, formatConfigReportProgress :: Bool
formatConfigReportProgress = Bool
False
, formatConfigOutputUnicode :: Bool
formatConfigOutputUnicode = Bool
False
, formatConfigUseDiff :: Bool
formatConfigUseDiff = Bool
False
, formatConfigDiffContext :: Maybe Int
formatConfigDiffContext = forall a. Maybe a
Nothing
, formatConfigExternalDiff :: Maybe (String -> String -> IO ())
formatConfigExternalDiff = forall a. Maybe a
Nothing
, formatConfigPrettyPrint :: Bool
formatConfigPrettyPrint = Bool
False
, formatConfigPrettyPrintFunction :: Maybe (String -> String -> (String, String))
formatConfigPrettyPrintFunction = forall a. Maybe a
Nothing
, formatConfigFormatException :: SomeException -> String
formatConfigFormatException = (SomeException -> String) -> SomeException -> String
formatExceptionWith forall a. Show a => a -> String
show
, formatConfigPrintTimes :: Bool
formatConfigPrintTimes = Bool
False
, formatConfigHtmlOutput :: Bool
formatConfigHtmlOutput = Bool
False
, formatConfigPrintCpuTime :: Bool
formatConfigPrintCpuTime = Bool
False
, formatConfigUsedSeed :: Integer
formatConfigUsedSeed = Integer
0
, formatConfigExpectedTotalCount :: Int
formatConfigExpectedTotalCount = Int
0
, formatConfigExpertMode :: Bool
formatConfigExpertMode = Bool
False
}

data Signal = Ok | NotOk SomeException

monadic :: MonadIO m => (m () -> IO ()) -> (Event -> m ()) -> IO Format
monadic :: forall (m :: * -> *).
MonadIO m =>
(m () -> IO ()) -> (Event -> m ()) -> IO Format
monadic m () -> IO ()
run Event -> m ()
format = do
  MVar Event
mvar <- forall a. IO (MVar a)
newEmptyMVar
  MVar Signal
done <- forall a. IO (MVar a)
newEmptyMVar

  let
    putEvent :: Event -> IO ()
    putEvent :: Format
putEvent = forall a. MVar a -> a -> IO ()
putMVar MVar Event
mvar

    takeEvent :: MonadIO m => m Event
    takeEvent :: forall (m :: * -> *). MonadIO m => m Event
takeEvent = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> IO a
takeMVar MVar Event
mvar

    signal :: MonadIO m => Signal -> m ()
    signal :: forall (m :: * -> *). MonadIO m => Signal -> m ()
signal = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. MVar a -> a -> IO ()
putMVar MVar Signal
done

    wait :: IO Signal
    wait :: IO Signal
wait = forall a. MVar a -> IO a
takeMVar MVar Signal
done

    go :: m ()
go = do
      Event
event <- forall (m :: * -> *). MonadIO m => m Event
takeEvent
      Event -> m ()
format Event
event
      case Event
event of
        Done {} -> forall (m :: * -> *). Applicative m => m ()
pass
        Event
_ -> do
          forall (m :: * -> *). MonadIO m => Signal -> m ()
signal Signal
Ok
          m ()
go

  Async ()
worker <- forall a. IO a -> IO (Async a)
async forall a b. (a -> b) -> a -> b
$ do
    (m () -> IO ()
run m ()
go forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *). MonadIO m => Signal -> m ()
signal Signal
Ok) forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (forall (m :: * -> *). MonadIO m => Signal -> m ()
signal forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> Signal
NotOk)

  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ \ Event
event -> do
    Bool
running <- Async () -> IO Bool
asyncRunning Async ()
worker
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
running forall a b. (a -> b) -> a -> b
$ do
      Format
putEvent Event
event
      Signal
r <- IO Signal
wait
      case Signal
r of
        Signal
Ok -> forall (m :: * -> *). Applicative m => m ()
pass
        NotOk SomeException
err -> do
          forall a. Async a -> IO a
Async.wait Async ()
worker
          forall e a. Exception e => e -> IO a
throwIO SomeException
err

asyncRunning :: Async () -> IO Bool
asyncRunning :: Async () -> IO Bool
asyncRunning Async ()
worker = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (forall a b. a -> b -> a
const Bool
False) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Async a -> IO (Maybe (Either SomeException a))
Async.poll Async ()
worker