{-# 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
(Int -> Item -> ShowS)
-> (Item -> String) -> ([Item] -> ShowS) -> Show Item
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Item -> ShowS
showsPrec :: Int -> Item -> ShowS
$cshow :: Item -> String
show :: Item -> String
$cshowList :: [Item] -> ShowS
showList :: [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
$cshowsPrec :: Int -> Result -> ShowS
showsPrec :: Int -> Result -> ShowS
$cshow :: Result -> String
show :: Result -> String
$cshowList :: [Result] -> ShowS
showList :: [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
$cshowsPrec :: Int -> Event -> ShowS
showsPrec :: Int -> Event -> ShowS
$cshow :: Event -> String
show :: Event -> String
$cshowList :: [Event] -> ShowS
showList :: [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 = Maybe Int
forall a. Maybe a
Nothing
, formatConfigExternalDiff :: Maybe (String -> String -> IO ())
formatConfigExternalDiff = Maybe (String -> String -> IO ())
forall a. Maybe a
Nothing
, formatConfigPrettyPrint :: Bool
formatConfigPrettyPrint = Bool
False
, formatConfigPrettyPrintFunction :: Maybe (String -> String -> (String, String))
formatConfigPrettyPrintFunction = Maybe (String -> String -> (String, String))
forall a. Maybe a
Nothing
, formatConfigFormatException :: SomeException -> String
formatConfigFormatException = (SomeException -> String) -> SomeException -> String
formatExceptionWith SomeException -> String
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 <- 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 :: forall (m :: * -> *). MonadIO m => m Event
takeEvent = IO Event -> m Event
forall a. IO a -> m a
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 :: forall (m :: * -> *). MonadIO m => Signal -> m ()
signal = IO () -> m ()
forall a. IO a -> m a
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 :: * -> *). Applicative m => m ()
pass
        Event
_ -> do
          Signal -> m ()
forall (m :: * -> *). MonadIO m => Signal -> m ()
signal Signal
Ok
          m ()
go

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

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