{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ExistentialQuantification #-}
-- |
-- Stability: experimental
module Test.Hspec.Core.Format (
  Format
, FormatConfig(..)
, 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)
import           Control.Monad.IO.Class

import           Test.Hspec.Core.Spec (Progress, Location(..))
import           Test.Hspec.Core.Example (FailureReason(..))
import           Test.Hspec.Core.Util (Path)
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
(Int -> Item -> ShowS)
-> (Item -> String) -> ([Item] -> ShowS) -> Show Item
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
(Int -> Result -> ShowS)
-> (Result -> String) -> ([Result] -> ShowS) -> Show Result
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
(Int -> Event -> ShowS)
-> (Event -> String) -> ([Event] -> ShowS) -> Show Event
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
formatConfigUseDiff :: Bool
, FormatConfig -> Bool
formatConfigPrintTimes :: Bool
, FormatConfig -> Bool
formatConfigHtmlOutput :: Bool
, FormatConfig -> Bool
formatConfigPrintCpuTime :: Bool
, FormatConfig -> Integer
formatConfigUsedSeed :: Integer
, FormatConfig -> Int
formatConfigItemCount :: Int
} deriving (FormatConfig -> FormatConfig -> Bool
(FormatConfig -> FormatConfig -> Bool)
-> (FormatConfig -> FormatConfig -> Bool) -> Eq FormatConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FormatConfig -> FormatConfig -> Bool
$c/= :: FormatConfig -> FormatConfig -> Bool
== :: FormatConfig -> FormatConfig -> Bool
$c== :: FormatConfig -> FormatConfig -> Bool
Eq, Int -> FormatConfig -> ShowS
[FormatConfig] -> ShowS
FormatConfig -> String
(Int -> FormatConfig -> ShowS)
-> (FormatConfig -> String)
-> ([FormatConfig] -> ShowS)
-> Show FormatConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FormatConfig] -> ShowS
$cshowList :: [FormatConfig] -> ShowS
show :: FormatConfig -> String
$cshow :: FormatConfig -> String
showsPrec :: Int -> FormatConfig -> ShowS
$cshowsPrec :: Int -> FormatConfig -> ShowS
Show)

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

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

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

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

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

    go :: m ()
go = do
      Event
event <- m Event
forall (m :: * -> *). MonadIO m => m Event
takeEvent
      Event -> m ()
format Event
event
      case Event
event of
        Done {} -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Event
_ -> do
          m ()
forall (m :: * -> *). MonadIO m => m ()
signal
          m ()
go

  Async ()
_ <- IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ do
    m () -> IO ()
run m ()
go
    IO ()
forall (m :: * -> *). MonadIO m => m ()
signal

  Format -> IO Format
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> IO Format) -> Format -> IO Format
forall a b. (a -> b) -> a -> b
$ \ Event
event -> do
    Format
putEvent Event
event
    IO ()
wait