{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ExistentialQuantification #-}
module Test.Hspec.Core.Format
(
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
, 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" #-}
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