{-# 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.Exception
import           Control.Concurrent
import           Control.Concurrent.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)
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
formatConfigOutputUnicode :: Bool
, FormatConfig -> Bool
formatConfigUseDiff :: Bool
, FormatConfig -> Bool
formatConfigPrettyPrint :: Bool
, FormatConfig -> Bool
formatConfigPrintTimes :: Bool
, FormatConfig -> Bool
formatConfigHtmlOutput :: Bool
, FormatConfig -> Bool
formatConfigPrintCpuTime :: Bool
, FormatConfig -> Integer
formatConfigUsedSeed :: Integer
, FormatConfig -> Int
formatConfigExpectedTotalCount :: 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)

data Signal = Ok | NotOk SomeException

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 Signal
done <- IO (MVar Signal)
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 => Signal -> m ()
    signal :: Signal -> m ()
signal = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (Signal -> IO ()) -> Signal -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar Signal -> Signal -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar Signal
done

    wait :: IO Signal
    wait :: IO Signal
wait = MVar Signal -> IO Signal
forall a. MVar a -> IO a
takeMVar MVar Signal
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
          Signal -> m ()
forall (m :: * -> *). MonadIO m => Signal -> m ()
signal Signal
Ok
          m ()
go

  Async ()
t <- 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 () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Signal -> IO ()
forall (m :: * -> *). MonadIO m => Signal -> m ()
signal Signal
Ok) IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (Signal -> IO ()
forall (m :: * -> *). MonadIO m => Signal -> m ()
signal (Signal -> IO ())
-> (SomeException -> Signal) -> SomeException -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> Signal
NotOk)

  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
    Maybe (Either SomeException ())
running <- Async () -> IO (Maybe (Either SomeException ()))
forall a. Async a -> IO (Maybe (Either SomeException a))
Async.poll Async ()
t
    case Maybe (Either SomeException ())
running of
      Just Either SomeException ()
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Maybe (Either SomeException ())
Nothing -> do
        Format
putEvent Event
event
        Signal
r <- IO Signal
wait
        case Signal
r of
          Signal
Ok -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          NotOk SomeException
err -> do
            Async () -> IO ()
forall a. Async a -> IO a
Async.wait Async ()
t
            SomeException -> IO ()
forall e a. Exception e => e -> IO a
throwIO SomeException
err