{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module EasyTest where

import Control.Applicative
import Control.Concurrent
import qualified Control.Concurrent.Async as A
import Control.Concurrent.STM
import Control.Exception
import Control.Monad
import Control.Monad.Catch (MonadCatch, MonadThrow (throwM))
import qualified Control.Monad.Catch as Catch
import Control.Monad.IO.Class
import Control.Monad.Reader
import Data.List
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Word
import GHC.Stack
import System.Random (Random)
import qualified System.Random as Random

data Status = Failed | Passed !Int | Skipped | Pending

combineStatus :: Status -> Status -> Status
combineStatus :: Status -> Status -> Status
combineStatus Status
Skipped Status
s = Status
s
combineStatus Status
s Status
Skipped = Status
s
combineStatus Status
_ Status
Pending = Status
Pending
combineStatus Status
Pending Status
_ = Status
Pending
combineStatus Status
Failed Status
_ = Status
Failed
combineStatus Status
_ Status
Failed = Status
Failed
combineStatus (Passed Int
n) (Passed Int
m) = Int -> Status
Passed (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
m)

data Env = Env
  { Env -> TVar StdGen
rng :: TVar Random.StdGen,
    Env -> String
messages :: String,
    Env -> TBQueue (Maybe (TMVar (String, Status)))
results :: TBQueue (Maybe (TMVar (String, Status))),
    Env -> String -> IO ()
note_ :: String -> IO (),
    Env -> String
allow :: String
  }

newtype Test a = Test (ReaderT Env IO (Maybe a))

io :: IO a -> Test a
io :: forall a. IO a -> Test a
io = IO a -> Test a
forall a. IO a -> Test a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO

atomicLogger :: IO (String -> IO ())
atomicLogger :: IO (String -> IO ())
atomicLogger = do
  MVar ()
lock <- () -> IO (MVar ())
forall a. a -> IO (MVar a)
newMVar ()
  pure $ \String
msg ->
    -- force msg before acquiring lock
    let dummy :: Bool
dummy = (Bool -> Char -> Bool) -> Bool -> String -> Bool
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Bool
_ Char
ch -> Char
ch Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'a') Bool
True String
msg
     in Bool
dummy Bool -> IO () -> IO ()
forall a b. a -> b -> b
`seq` IO () -> (() -> IO ()) -> (() -> IO ()) -> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
lock) (\()
_ -> MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
lock ()) (\()
_ -> String -> IO ()
putStrLn String
msg)

expect' :: (HasCallStack) => Bool -> Test ()
expect' :: HasCallStack => Bool -> Test ()
expect' Bool
False = String -> Test ()
forall a. HasCallStack => String -> Test a
crash String
"unexpected"
expect' Bool
True = () -> Test ()
forall a. a -> Test a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

expect :: (HasCallStack) => Bool -> Test ()
expect :: HasCallStack => Bool -> Test ()
expect Bool
False = String -> Test ()
forall a. HasCallStack => String -> Test a
crash String
"unexpected"
expect Bool
True = Test ()
ok

expectEqual' :: (HasCallStack, Eq a, Show a) => a -> a -> Test ()
expectEqual' :: forall a. (HasCallStack, Eq a, Show a) => a -> a -> Test ()
expectEqual' a
expected a
actual =
  if a
expected a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
actual
    then () -> Test ()
forall a. a -> Test a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    else String -> Test ()
forall a. HasCallStack => String -> Test a
crash (String -> Test ()) -> String -> Test ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [String
"", a -> String
forall a. Show a => a -> String
show a
actual, String
"** did not equal expected value **", a -> String
forall a. Show a => a -> String
show a
expected]

expectEqual :: (HasCallStack, Eq a, Show a) => a -> a -> Test ()
expectEqual :: forall a. (HasCallStack, Eq a, Show a) => a -> a -> Test ()
expectEqual a
expected a
actual =
  if a
expected a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
actual
    then Test ()
ok
    else String -> Test ()
forall a. HasCallStack => String -> Test a
crash (String -> Test ()) -> String -> Test ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [String
"", a -> String
forall a. Show a => a -> String
show a
actual, String
"** did not equal expected value **", a -> String
forall a. Show a => a -> String
show a
expected]

expectNotEqual :: (HasCallStack, Eq a, Show a) => a -> a -> Test ()
expectNotEqual :: forall a. (HasCallStack, Eq a, Show a) => a -> a -> Test ()
expectNotEqual a
forbidden a
actual =
  if a
forbidden a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
actual
    then Test ()
ok
    else String -> Test ()
forall a. HasCallStack => String -> Test a
crash (String -> Test ()) -> String -> Test ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [String
"", a -> String
forall a. Show a => a -> String
show a
actual, String
"** did equal the forbidden value **", a -> String
forall a. Show a => a -> String
show a
forbidden]

expectJust :: (HasCallStack) => Maybe a -> Test a
expectJust :: forall a. HasCallStack => Maybe a -> Test a
expectJust Maybe a
Nothing = String -> Test a
forall a. HasCallStack => String -> Test a
crash String
"expected Just, got Nothing"
expectJust (Just a
a) = Test ()
ok Test () -> Test a -> Test a
forall a b. Test a -> Test b -> Test b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> Test a
forall a. a -> Test a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a

expectRight :: (HasCallStack) => Either e a -> Test a
expectRight :: forall e a. HasCallStack => Either e a -> Test a
expectRight (Left e
_) = String -> Test a
forall a. HasCallStack => String -> Test a
crash String
"expected Right, got Left"
expectRight (Right a
a) = Test ()
ok Test () -> Test a -> Test a
forall a b. Test a -> Test b -> Test b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> Test a
forall a. a -> Test a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a

expectLeft :: (HasCallStack) => Either e a -> Test e
expectLeft :: forall e a. HasCallStack => Either e a -> Test e
expectLeft (Left e
e) = Test ()
ok Test () -> Test e -> Test e
forall a b. Test a -> Test b -> Test b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> e -> Test e
forall a. a -> Test a
forall (f :: * -> *) a. Applicative f => a -> f a
pure e
e
expectLeft (Right a
_) = String -> Test e
forall a. HasCallStack => String -> Test a
crash String
"expected Left, got Right"

tests :: [Test ()] -> Test ()
tests :: [Test ()] -> Test ()
tests = [Test ()] -> Test ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum

-- | Run all tests whose scope starts with the given prefix
runOnly :: String -> Test a -> IO ()
runOnly :: forall a. String -> Test a -> IO ()
runOnly String
prefix Test a
t = do
  String -> IO ()
logger <- IO (String -> IO ())
atomicLogger
  Int
seed <- Int -> Int
forall a. Num a => a -> a
abs (Int -> Int) -> IO Int -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Int
forall a (m :: * -> *). (Random a, MonadIO m) => m a
Random.randomIO :: IO Int
  Int -> (String -> IO ()) -> String -> Test a -> IO ()
forall a. Int -> (String -> IO ()) -> String -> Test a -> IO ()
run' Int
seed String -> IO ()
logger String
prefix Test a
t

-- | Run all tests with the given seed and whose scope starts with the given prefix
rerunOnly :: Int -> String -> Test a -> IO ()
rerunOnly :: forall a. Int -> String -> Test a -> IO ()
rerunOnly Int
seed String
prefix Test a
t = do
  String -> IO ()
logger <- IO (String -> IO ())
atomicLogger
  Int -> (String -> IO ()) -> String -> Test a -> IO ()
forall a. Int -> (String -> IO ()) -> String -> Test a -> IO ()
run' Int
seed String -> IO ()
logger String
prefix Test a
t

run :: Test a -> IO ()
run :: forall a. Test a -> IO ()
run = String -> Test a -> IO ()
forall a. String -> Test a -> IO ()
runOnly String
""

rerun :: Int -> Test a -> IO ()
rerun :: forall a. Int -> Test a -> IO ()
rerun Int
seed = Int -> String -> Test a -> IO ()
forall a. Int -> String -> Test a -> IO ()
rerunOnly Int
seed []

run' :: Int -> (String -> IO ()) -> String -> Test a -> IO ()
run' :: forall a. Int -> (String -> IO ()) -> String -> Test a -> IO ()
run' Int
seed String -> IO ()
note String
allow (Test ReaderT Env IO (Maybe a)
t) = do
  let !rng :: StdGen
rng = Int -> StdGen
Random.mkStdGen Int
seed
  TBQueue (Maybe (TMVar (String, Status)))
resultsQ <- STM (TBQueue (Maybe (TMVar (String, Status))))
-> IO (TBQueue (Maybe (TMVar (String, Status))))
forall a. STM a -> IO a
atomically (Natural -> STM (TBQueue (Maybe (TMVar (String, Status))))
forall a. Natural -> STM (TBQueue a)
newTBQueue Natural
50)
  TVar StdGen
rngVar <- StdGen -> IO (TVar StdGen)
forall a. a -> IO (TVar a)
newTVarIO StdGen
rng
  String -> IO ()
note (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Randomness seed for this run is " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
seed String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
""
  TVar (Map String Status)
results <- STM (TVar (Map String Status)) -> IO (TVar (Map String Status))
forall a. STM a -> IO a
atomically (STM (TVar (Map String Status)) -> IO (TVar (Map String Status)))
-> STM (TVar (Map String Status)) -> IO (TVar (Map String Status))
forall a b. (a -> b) -> a -> b
$ Map String Status -> STM (TVar (Map String Status))
forall a. a -> STM (TVar a)
newTVar Map String Status
forall k a. Map k a
Map.empty
  Async Any
rs <- IO Any -> IO (Async Any)
forall a. IO a -> IO (Async a)
A.async (IO Any -> IO (Async Any))
-> (IO () -> IO Any) -> IO () -> IO (Async Any)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO Any
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO (Async Any)) -> IO () -> IO (Async Any)
forall a b. (a -> b) -> a -> b
$ do
    -- note, totally fine if this bombs once queue is empty
    Just TMVar (String, Status)
result <- STM (Maybe (TMVar (String, Status)))
-> IO (Maybe (TMVar (String, Status)))
forall a. STM a -> IO a
atomically (STM (Maybe (TMVar (String, Status)))
 -> IO (Maybe (TMVar (String, Status))))
-> STM (Maybe (TMVar (String, Status)))
-> IO (Maybe (TMVar (String, Status)))
forall a b. (a -> b) -> a -> b
$ TBQueue (Maybe (TMVar (String, Status)))
-> STM (Maybe (TMVar (String, Status)))
forall a. TBQueue a -> STM a
readTBQueue TBQueue (Maybe (TMVar (String, Status)))
resultsQ
    (String
msgs, Status
passed) <- STM (String, Status) -> IO (String, Status)
forall a. STM a -> IO a
atomically (STM (String, Status) -> IO (String, Status))
-> STM (String, Status) -> IO (String, Status)
forall a b. (a -> b) -> a -> b
$ TMVar (String, Status) -> STM (String, Status)
forall a. TMVar a -> STM a
takeTMVar TMVar (String, Status)
result
    STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar (Map String Status)
-> (Map String Status -> Map String Status) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (Map String Status)
results ((Status -> Status -> Status)
-> String -> Status -> Map String Status -> Map String Status
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith Status -> Status -> Status
combineStatus String
msgs Status
passed)
    Map String Status
resultsMap <- TVar (Map String Status) -> IO (Map String Status)
forall a. TVar a -> IO a
readTVarIO TVar (Map String Status)
results
    case Status -> String -> Map String Status -> Status
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Status
Skipped String
msgs Map String Status
resultsMap of
      Status
Skipped -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Status
Pending -> String -> IO ()
note (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"🚧  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msgs
      Passed Int
n -> String -> IO ()
note (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"\129412  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1 then String
msgs else String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msgs)
      Status
Failed -> String -> IO ()
note (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"💥  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msgs
  let line :: String
line = String
"------------------------------------------------------------"
  String -> IO ()
note String
"Raw test output to follow ... "
  String -> IO ()
note String
line
  Either SomeException ()
e <- IO () -> IO (Either SomeException ())
forall e a. Exception e => IO a -> IO (Either e a)
try (ReaderT Env IO () -> Env -> IO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (ReaderT Env IO (Maybe a) -> ReaderT Env IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ReaderT Env IO (Maybe a)
t) (TVar StdGen
-> String
-> TBQueue (Maybe (TMVar (String, Status)))
-> (String -> IO ())
-> String
-> Env
Env TVar StdGen
rngVar [] TBQueue (Maybe (TMVar (String, Status)))
resultsQ String -> IO ()
note String
allow)) :: IO (Either SomeException ())
  case Either SomeException ()
e of
    Left SomeException
e -> String -> IO ()
note (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Exception while running tests: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SomeException -> String
forall a. Show a => a -> String
show SomeException
e
    Right () -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TBQueue (Maybe (TMVar (String, Status)))
-> Maybe (TMVar (String, Status)) -> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue TBQueue (Maybe (TMVar (String, Status)))
resultsQ Maybe (TMVar (String, Status))
forall a. Maybe a
Nothing
  Either SomeException Any
_ <- Async Any -> IO (Either SomeException Any)
forall a. Async a -> IO (Either SomeException a)
A.waitCatch Async Any
rs
  Map String Status
resultsMap <- TVar (Map String Status) -> IO (Map String Status)
forall a. TVar a -> IO a
readTVarIO TVar (Map String Status)
results
  let resultsList :: [(String, Status)]
resultsList = Map String Status -> [(String, Status)]
forall k a. Map k a -> [(k, a)]
Map.toList Map String Status
resultsMap
      succeededList :: [Int]
succeededList = [Int
n | (String
_, Passed Int
n) <- [(String, Status)]
resultsList]
      succeeded :: Int
succeeded = [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
succeededList
      -- totalTestCases = foldl' (+) 0 succeededList
      failures :: [String]
failures = [String
a | (String
a, Status
Failed) <- [(String, Status)]
resultsList]
      failed :: Int
failed = [String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
failures
      pendings :: [String]
pendings = [String
a | (String
a, Status
Pending) <- [(String, Status)]
resultsList]
      pending :: Int
pending = [String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
pendings
      pendingSuffix :: String
pendingSuffix = if Int
pending Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then String
"👍 🎉" else String
""
      testsPlural :: a -> String
testsPlural a
n = a -> String
forall a. Show a => a -> String
show a
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ if a
n a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
1 then String
"test" else String
"tests"
  String -> IO ()
note String
line
  String -> IO ()
note String
"\n"
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
pending Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    String -> IO ()
note (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"🚧  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall {a}. (Show a, Eq a, Num a) => a -> String
testsPlural Int
pending String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" still pending (pending scopes below):"
    String -> IO ()
note (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"    " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n    " ((String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String
forall a. Show a => a -> String
show (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n')) [String]
pendings)
  case [String]
failures of
    [] ->
      case Int
succeeded of
        Int
0 -> do
          String -> IO ()
note String
"😶  hmm ... no test results recorded"
          String -> IO ()
note String
"Tip: use `ok`, `expect`, or `crash` to record results"
          String -> IO ()
note String
"Tip: if running via `runOnly` or `rerunOnly`, check for typos"
        Int
n -> String -> IO ()
note (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"✅  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
testsPlural Int
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" passed, no failures! " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pendingSuffix
    (String
hd : [String]
_) -> do
      String -> IO ()
note (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
succeeded String -> String -> String
forall a. [a] -> [a] -> [a]
++ (if Int
failed Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then String
" PASSED" else String
" passed")
      String -> IO ()
note (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
failures) String -> String -> String
forall a. [a] -> [a] -> [a]
++ (if Int
failed Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then String
" failed" else String
" FAILED (failed scopes below)")
      String -> IO ()
note (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"    " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n    " ((String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String
forall a. Show a => a -> String
show (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n')) [String]
failures)
      String -> IO ()
note String
""
      String -> IO ()
note String
"  To rerun with same random seed:\n"
      String -> IO ()
note (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"    EasyTest.rerun " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
seed
      String -> IO ()
note (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"    EasyTest.rerunOnly " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
seed String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
hd String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\""
      String -> IO ()
note String
"\n"
      String -> IO ()
note String
line
      String -> IO ()
note String
"❌"
      String -> IO ()
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"test failures"

-- | Label a test. Can be nested. A `'.'` is placed between nested
-- scopes, so `scope "foo" . scope "bar"` is equivalent to `scope "foo.bar"`
scope :: String -> Test a -> Test a
scope :: forall a. String -> Test a -> Test a
scope String
msg (Test ReaderT Env IO (Maybe a)
t) = Test a -> Test a
forall a. Test a -> Test a
wrap (Test a -> Test a)
-> (ReaderT Env IO (Maybe a) -> Test a)
-> ReaderT Env IO (Maybe a)
-> Test a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT Env IO (Maybe a) -> Test a
forall a. ReaderT Env IO (Maybe a) -> Test a
Test (ReaderT Env IO (Maybe a) -> Test a)
-> ReaderT Env IO (Maybe a) -> Test a
forall a b. (a -> b) -> a -> b
$ do
  Env
env <- ReaderT Env IO Env
forall r (m :: * -> *). MonadReader r m => m r
ask
  let messages' :: String
messages' = case Env -> String
messages Env
env of [] -> String
msg; String
ms -> String
ms String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Char
'.' Char -> String -> String
forall a. a -> [a] -> [a]
: String
msg)
  let env' :: Env
env' = Env
env {messages = messages', allow = drop (length msg + 1) (allow env)}
  if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Env -> String
allow Env
env) Bool -> Bool -> Bool
|| Int -> String -> String
forall a. Int -> [a] -> [a]
take (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Env -> String
allow Env
env)) String
msg String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` Env -> String
allow Env
env
    then IO (Maybe a) -> ReaderT Env IO (Maybe a)
forall a. IO a -> ReaderT Env IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Env -> ReaderT Env IO (Maybe a) -> IO (Maybe a)
forall a. Env -> ReaderT Env IO (Maybe a) -> IO (Maybe a)
runWrap Env
env' ReaderT Env IO (Maybe a)
t)
    else Status -> ReaderT Env IO ()
putResult Status
Skipped ReaderT Env IO ()
-> ReaderT Env IO (Maybe a) -> ReaderT Env IO (Maybe a)
forall a b.
ReaderT Env IO a -> ReaderT Env IO b -> ReaderT Env IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe a -> ReaderT Env IO (Maybe a)
forall a. a -> ReaderT Env IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing

-- | Log a message
note :: String -> Test ()
note :: String -> Test ()
note String
msg = do
  String -> IO ()
note_ <- (Env -> String -> IO ()) -> Test (String -> IO ())
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> String -> IO ()
note_
  IO () -> Test ()
forall a. IO a -> Test a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Test ()) -> IO () -> Test ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
note_ String
msg
  pure ()

-- | Log a showable value
note' :: (Show s) => s -> Test ()
note' :: forall s. Show s => s -> Test ()
note' = String -> Test ()
note (String -> Test ()) -> (s -> String) -> s -> Test ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> String
forall a. Show a => a -> String
show

-- | Generate a random value
random :: (Random a) => Test a
random :: forall a. Random a => Test a
random = do
  TVar StdGen
rng <- (Env -> TVar StdGen) -> Test (TVar StdGen)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> TVar StdGen
rng
  IO a -> Test a
forall a. IO a -> Test a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> Test a) -> (STM a -> IO a) -> STM a -> Test a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM a -> IO a
forall a. STM a -> IO a
atomically (STM a -> Test a) -> STM a -> Test a
forall a b. (a -> b) -> a -> b
$ do
    StdGen
rng0 <- TVar StdGen -> STM StdGen
forall a. TVar a -> STM a
readTVar TVar StdGen
rng
    let (a
a, StdGen
rng1) = StdGen -> (a, StdGen)
forall g. RandomGen g => g -> (a, g)
forall a g. (Random a, RandomGen g) => g -> (a, g)
Random.random StdGen
rng0
    TVar StdGen -> StdGen -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar StdGen
rng StdGen
rng1
    pure a
a

-- | Generate a bounded random value. Inclusive on both sides.
random' :: (Random a) => a -> a -> Test a
random' :: forall a. Random a => a -> a -> Test a
random' a
lower a
upper = do
  TVar StdGen
rng <- (Env -> TVar StdGen) -> Test (TVar StdGen)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> TVar StdGen
rng
  IO a -> Test a
forall a. IO a -> Test a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> Test a) -> (STM a -> IO a) -> STM a -> Test a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM a -> IO a
forall a. STM a -> IO a
atomically (STM a -> Test a) -> STM a -> Test a
forall a b. (a -> b) -> a -> b
$ do
    StdGen
rng0 <- TVar StdGen -> STM StdGen
forall a. TVar a -> STM a
readTVar TVar StdGen
rng
    let (a
a, StdGen
rng1) = (a, a) -> StdGen -> (a, StdGen)
forall g. RandomGen g => (a, a) -> g -> (a, g)
forall a g. (Random a, RandomGen g) => (a, a) -> g -> (a, g)
Random.randomR (a
lower, a
upper) StdGen
rng0
    TVar StdGen -> StdGen -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar StdGen
rng StdGen
rng1
    pure a
a

bool :: Test Bool
bool :: Test Bool
bool = Test Bool
forall a. Random a => Test a
random

word8 :: Test Word8
word8 :: Test Word8
word8 = Test Word8
forall a. Random a => Test a
random

-- | Generate a random `Char`
char :: Test Char
char :: Test Char
char = Test Char
forall a. Random a => Test a
random

-- | Generate a random `Int`
int :: Test Int
int :: Test Int
int = Test Int
forall a. Random a => Test a
random

-- | Generate a random `Double`
double :: Test Double
double :: Test Double
double = Test Double
forall a. Random a => Test a
random

-- | Generate a random `Word`
word :: Test Word
word :: Test Word
word = Test Word
forall a. Random a => Test a
random

-- | Generate a random `Int` in the given range
-- Note: `int' 0 5` includes both `0` and `5`
int' :: Int -> Int -> Test Int
int' :: Int -> Int -> Test Int
int' = Int -> Int -> Test Int
forall a. Random a => a -> a -> Test a
random'

-- | Generate a random `Char` in the given range
-- Note: `char' 'a' 'z'` includes both `'a'` and `'z'`.
char' :: Char -> Char -> Test Char
char' :: Char -> Char -> Test Char
char' = Char -> Char -> Test Char
forall a. Random a => a -> a -> Test a
random'

-- | Generate a random `Double` in the given range
-- Note: `double' 0 1` includes both `0` and `1`.
double' :: Double -> Double -> Test Double
double' :: Double -> Double -> Test Double
double' = Double -> Double -> Test Double
forall a. Random a => a -> a -> Test a
random'

-- | Generate a random `Double` in the given range
-- Note: `word' 0 10` includes both `0` and `10`.
word' :: Word -> Word -> Test Word
word' :: Word -> Word -> Test Word
word' = Word -> Word -> Test Word
forall a. Random a => a -> a -> Test a
random'

-- | Generate a random `Double` in the given range
-- Note: `word8' 0 10` includes both `0` and `10`.
word8' :: Word8 -> Word8 -> Test Word8
word8' :: Word8 -> Word8 -> Test Word8
word8' = Word8 -> Word8 -> Test Word8
forall a. Random a => a -> a -> Test a
random'

-- | Sample uniformly from the given list of possibilities
pick :: [a] -> Test a
pick :: forall a. [a] -> Test a
pick [a]
as =
  let n :: Int
n = [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
as; ind :: Int -> Maybe a
ind = Int -> [a] -> Int -> Maybe a
forall a. Int -> [a] -> Int -> Maybe a
picker Int
n [a]
as
   in do
        ()
_ <- if (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) then () -> Test ()
forall a. a -> Test a
forall (f :: * -> *) a. Applicative f => a -> f a
pure () else String -> Test ()
forall a. HasCallStack => String -> Test a
crash String
"pick called with empty list"
        Int
i <- Int -> Int -> Test Int
int' Int
0 (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
        Just a
a <- Maybe a -> Test (Maybe a)
forall a. a -> Test a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Maybe a
ind Int
i)
        pure a
a

picker :: Int -> [a] -> (Int -> Maybe a)
picker :: forall a. Int -> [a] -> Int -> Maybe a
picker Int
_ [] = Maybe a -> Int -> Maybe a
forall a b. a -> b -> a
const Maybe a
forall a. Maybe a
Nothing
picker Int
_ [a
a] = \Int
i -> if Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then a -> Maybe a
forall a. a -> Maybe a
Just a
a else Maybe a
forall a. Maybe a
Nothing
picker Int
size [a]
as = Int -> Maybe a
go
  where
    lsize :: Int
lsize = Int
size Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2
    rsize :: Int
rsize = Int
size Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
lsize
    ([a]
l, [a]
r) = Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
lsize [a]
as
    lpicker :: Int -> Maybe a
lpicker = Int -> [a] -> Int -> Maybe a
forall a. Int -> [a] -> Int -> Maybe a
picker Int
lsize [a]
l
    rpicker :: Int -> Maybe a
rpicker = Int -> [a] -> Int -> Maybe a
forall a. Int -> [a] -> Int -> Maybe a
picker Int
rsize [a]
r
    go :: Int -> Maybe a
go Int
i = if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
lsize then Int -> Maybe a
lpicker Int
i else Int -> Maybe a
rpicker (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
lsize)

-- | Alias for `replicateM`
listOf :: Int -> Test a -> Test [a]
listOf :: forall a. Int -> Test a -> Test [a]
listOf = Int -> Test a -> Test [a]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM

-- | Generate a list of lists of the given sizes,
-- an alias for `sizes `forM` \n -> listOf n gen`
listsOf :: [Int] -> Test a -> Test [[a]]
listsOf :: forall a. [Int] -> Test a -> Test [[a]]
listsOf [Int]
sizes Test a
gen = [Int]
sizes [Int] -> (Int -> Test [a]) -> Test [[a]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
`forM` \Int
n -> Int -> Test a -> Test [a]
forall a. Int -> Test a -> Test [a]
listOf Int
n Test a
gen

-- | Alias for `liftA2 (,)`.
pair :: Test a -> Test b -> Test (a, b)
pair :: forall a b. Test a -> Test b -> Test (a, b)
pair = (a -> b -> (a, b)) -> Test a -> Test b -> Test (a, b)
forall a b c. (a -> b -> c) -> Test a -> Test b -> Test c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,)

-- | Alias for 'pair'.
tuple2 :: (Random a, Random b) => Test (a, b)
tuple2 :: forall a b. (Random a, Random b) => Test (a, b)
tuple2 =
  (,) (a -> b -> (a, b)) -> Test a -> Test (b -> (a, b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Test a
forall a. Random a => Test a
random Test (b -> (a, b)) -> Test b -> Test (a, b)
forall a b. Test (a -> b) -> Test a -> Test b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Test b
forall a. Random a => Test a
random

-- | Generate a random 3-tuple.
tuple3 :: (Random a, Random b, Random c) => Test (a, b, c)
tuple3 :: forall a b c. (Random a, Random b, Random c) => Test (a, b, c)
tuple3 =
  (,,) (a -> b -> c -> (a, b, c)) -> Test a -> Test (b -> c -> (a, b, c))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Test a
forall a. Random a => Test a
random Test (b -> c -> (a, b, c)) -> Test b -> Test (c -> (a, b, c))
forall a b. Test (a -> b) -> Test a -> Test b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Test b
forall a. Random a => Test a
random Test (c -> (a, b, c)) -> Test c -> Test (a, b, c)
forall a b. Test (a -> b) -> Test a -> Test b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Test c
forall a. Random a => Test a
random

-- | Generate a random 4-tuple.
tuple4 :: (Random a, Random b, Random c, Random d) => Test (a, b, c, d)
tuple4 :: forall a b c d.
(Random a, Random b, Random c, Random d) =>
Test (a, b, c, d)
tuple4 =
  (,,,) (a -> b -> c -> d -> (a, b, c, d))
-> Test a -> Test (b -> c -> d -> (a, b, c, d))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Test a
forall a. Random a => Test a
random Test (b -> c -> d -> (a, b, c, d))
-> Test b -> Test (c -> d -> (a, b, c, d))
forall a b. Test (a -> b) -> Test a -> Test b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Test b
forall a. Random a => Test a
random Test (c -> d -> (a, b, c, d)) -> Test c -> Test (d -> (a, b, c, d))
forall a b. Test (a -> b) -> Test a -> Test b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Test c
forall a. Random a => Test a
random Test (d -> (a, b, c, d)) -> Test d -> Test (a, b, c, d)
forall a b. Test (a -> b) -> Test a -> Test b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Test d
forall a. Random a => Test a
random

-- | Generate a `Data.Map k v` of the given size.
mapOf :: (Ord k) => Int -> Test k -> Test v -> Test (Map k v)
mapOf :: forall k v. Ord k => Int -> Test k -> Test v -> Test (Map k v)
mapOf Int
n Test k
k Test v
v = [(k, v)] -> Map k v
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(k, v)] -> Map k v) -> Test [(k, v)] -> Test (Map k v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Test (k, v) -> Test [(k, v)]
forall a. Int -> Test a -> Test [a]
listOf Int
n (Test k -> Test v -> Test (k, v)
forall a b. Test a -> Test b -> Test (a, b)
pair Test k
k Test v
v)

-- | Generate a `[Data.Map k v]` of the given sizes.
mapsOf :: (Ord k) => [Int] -> Test k -> Test v -> Test [Map k v]
mapsOf :: forall k v. Ord k => [Int] -> Test k -> Test v -> Test [Map k v]
mapsOf [Int]
sizes Test k
k Test v
v = [Int]
sizes [Int] -> (Int -> Test (Map k v)) -> Test [Map k v]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
`forM` \Int
n -> Int -> Test k -> Test v -> Test (Map k v)
forall k v. Ord k => Int -> Test k -> Test v -> Test (Map k v)
mapOf Int
n Test k
k Test v
v

-- | Catch all exceptions that could occur in the given `Test`
wrap :: Test a -> Test a
wrap :: forall a. Test a -> Test a
wrap (Test ReaderT Env IO (Maybe a)
t) = ReaderT Env IO (Maybe a) -> Test a
forall a. ReaderT Env IO (Maybe a) -> Test a
Test (ReaderT Env IO (Maybe a) -> Test a)
-> ReaderT Env IO (Maybe a) -> Test a
forall a b. (a -> b) -> a -> b
$ do
  Env
env <- ReaderT Env IO Env
forall r (m :: * -> *). MonadReader r m => m r
ask
  IO (Maybe a) -> ReaderT Env IO (Maybe a)
forall (m :: * -> *) a. Monad m => m a -> ReaderT Env m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (Maybe a) -> ReaderT Env IO (Maybe a))
-> IO (Maybe a) -> ReaderT Env IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ Env -> ReaderT Env IO (Maybe a) -> IO (Maybe a)
forall a. Env -> ReaderT Env IO (Maybe a) -> IO (Maybe a)
runWrap Env
env ReaderT Env IO (Maybe a)
t

runWrap :: Env -> ReaderT Env IO (Maybe a) -> IO (Maybe a)
runWrap :: forall a. Env -> ReaderT Env IO (Maybe a) -> IO (Maybe a)
runWrap Env
env ReaderT Env IO (Maybe a)
t = do
  Either SomeException (Maybe a)
e <- IO (Maybe a) -> IO (Either SomeException (Maybe a))
forall e a. Exception e => IO a -> IO (Either e a)
try (IO (Maybe a) -> IO (Either SomeException (Maybe a)))
-> IO (Maybe a) -> IO (Either SomeException (Maybe a))
forall a b. (a -> b) -> a -> b
$ ReaderT Env IO (Maybe a) -> Env -> IO (Maybe a)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT Env IO (Maybe a)
t Env
env
  case Either SomeException (Maybe a)
e of
    Left SomeException
e -> do
      Env -> String -> IO ()
note_ Env
env (Env -> String
messages Env
env String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" EXCEPTION!!!: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SomeException -> String
forall a. Show a => a -> String
show (SomeException
e :: SomeException))
      ReaderT Env IO () -> Env -> IO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Status -> ReaderT Env IO ()
putResult Status
Failed) Env
env
      pure Maybe a
forall a. Maybe a
Nothing
    Right Maybe a
a -> Maybe a -> IO (Maybe a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
a

-- | A test with a setup and teardown
using :: IO r -> (r -> IO ()) -> (r -> Test a) -> Test a
using :: forall r a. IO r -> (r -> IO ()) -> (r -> Test a) -> Test a
using IO r
r r -> IO ()
cleanup r -> Test a
use = ReaderT Env IO (Maybe a) -> Test a
forall a. ReaderT Env IO (Maybe a) -> Test a
Test (ReaderT Env IO (Maybe a) -> Test a)
-> ReaderT Env IO (Maybe a) -> Test a
forall a b. (a -> b) -> a -> b
$ do
  r
r <- IO r -> ReaderT Env IO r
forall a. IO a -> ReaderT Env IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO r
r
  Env
env <- ReaderT Env IO Env
forall r (m :: * -> *). MonadReader r m => m r
ask
  let Test ReaderT Env IO (Maybe a)
t = r -> Test a
use r
r
  Maybe a
a <- IO (Maybe a) -> ReaderT Env IO (Maybe a)
forall a. IO a -> ReaderT Env IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Env -> ReaderT Env IO (Maybe a) -> IO (Maybe a)
forall a. Env -> ReaderT Env IO (Maybe a) -> IO (Maybe a)
runWrap Env
env ReaderT Env IO (Maybe a)
t)
  IO () -> ReaderT Env IO ()
forall a. IO a -> ReaderT Env IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (r -> IO ()
cleanup r
r)
  pure Maybe a
a

-- | The current scope
currentScope :: Test String
currentScope :: Test String
currentScope = (Env -> String) -> Test String
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> String
messages

-- | Prepend the current scope to a logging message
noteScoped :: String -> Test ()
noteScoped :: String -> Test ()
noteScoped String
msg = do
  String
s <- Test String
currentScope
  String -> Test ()
note (String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ (if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
s then String
"" else String
" ") String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg)

-- | Record a successful test at the current scope
ok :: Test ()
ok :: Test ()
ok = ReaderT Env IO (Maybe ()) -> Test ()
forall a. ReaderT Env IO (Maybe a) -> Test a
Test (() -> Maybe ()
forall a. a -> Maybe a
Just (() -> Maybe ()) -> ReaderT Env IO () -> ReaderT Env IO (Maybe ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Status -> ReaderT Env IO ()
putResult (Int -> Status
Passed Int
1))

-- | Skip any tests depending on the return value.
done :: Test a
done :: forall a. Test a
done = ReaderT Env IO (Maybe a) -> Test a
forall a. ReaderT Env IO (Maybe a) -> Test a
Test (Maybe a -> ReaderT Env IO (Maybe a)
forall a. a -> ReaderT Env IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing)

-- | Explicitly skip this test
skip :: Test ()
skip :: Test ()
skip = ReaderT Env IO (Maybe ()) -> Test ()
forall a. ReaderT Env IO (Maybe a) -> Test a
Test (Maybe ()
forall a. Maybe a
Nothing Maybe () -> ReaderT Env IO () -> ReaderT Env IO (Maybe ())
forall a b. a -> ReaderT Env IO b -> ReaderT Env IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Status -> ReaderT Env IO ()
putResult Status
Skipped)

-- | Record a failure at the current scope
crash :: (HasCallStack) => String -> Test a
crash :: forall a. HasCallStack => String -> Test a
crash String
msg = do
  let trace :: CallStack
trace = CallStack
HasCallStack => CallStack
callStack
      msg' :: String
msg' = String
msg String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ CallStack -> String
prettyCallStack CallStack
trace
  ReaderT Env IO (Maybe ()) -> Test ()
forall a. ReaderT Env IO (Maybe a) -> Test a
Test (() -> Maybe ()
forall a. a -> Maybe a
Just (() -> Maybe ()) -> ReaderT Env IO () -> ReaderT Env IO (Maybe ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Status -> ReaderT Env IO ()
putResult Status
Failed) Test () -> Test () -> Test ()
forall a b. Test a -> Test b -> Test b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Test ()
noteScoped (String
"FAILURE " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg') Test () -> Test a -> Test a
forall a b. Test a -> Test b -> Test b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ReaderT Env IO (Maybe a) -> Test a
forall a. ReaderT Env IO (Maybe a) -> Test a
Test (Maybe a -> ReaderT Env IO (Maybe a)
forall a. a -> ReaderT Env IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing)

-- | Overwrites the env so that note_ (the logger) is a no op
nologging :: (HasCallStack) => Test a -> Test a
nologging :: forall a. HasCallStack => Test a -> Test a
nologging (Test ReaderT Env IO (Maybe a)
t) = ReaderT Env IO (Maybe a) -> Test a
forall a. ReaderT Env IO (Maybe a) -> Test a
Test (ReaderT Env IO (Maybe a) -> Test a)
-> ReaderT Env IO (Maybe a) -> Test a
forall a b. (a -> b) -> a -> b
$ do
  Env
env <- ReaderT Env IO Env
forall r (m :: * -> *). MonadReader r m => m r
ask
  IO (Maybe a) -> ReaderT Env IO (Maybe a)
forall a. IO a -> ReaderT Env IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe a) -> ReaderT Env IO (Maybe a))
-> IO (Maybe a) -> ReaderT Env IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ Env -> ReaderT Env IO (Maybe a) -> IO (Maybe a)
forall a. Env -> ReaderT Env IO (Maybe a) -> IO (Maybe a)
runWrap (Env
env {note_ = \String
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()}) ReaderT Env IO (Maybe a)
t

-- | Run a test under a new scope, without logs and suppressing all output
attempt :: Test a -> Test (Maybe a)
attempt :: forall a. Test a -> Test (Maybe a)
attempt (Test ReaderT Env IO (Maybe a)
t) = Test (Maybe a) -> Test (Maybe a)
forall a. HasCallStack => Test a -> Test a
nologging (Test (Maybe a) -> Test (Maybe a))
-> Test (Maybe a) -> Test (Maybe a)
forall a b. (a -> b) -> a -> b
$ do
  Env
env <- Test Env
forall r (m :: * -> *). MonadReader r m => m r
ask
  let msg :: String
msg = String
"internal attempt"
  let messages' :: String
messages' = case Env -> String
messages Env
env of [] -> String
msg; String
ms -> String
ms String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Char
'.' Char -> String -> String
forall a. a -> [a] -> [a]
: String
msg)
  IO (Maybe a) -> Test (Maybe a)
forall a. IO a -> Test a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe a) -> Test (Maybe a)) -> IO (Maybe a) -> Test (Maybe a)
forall a b. (a -> b) -> a -> b
$ Env -> ReaderT Env IO (Maybe a) -> IO (Maybe a)
forall a. Env -> ReaderT Env IO (Maybe a) -> IO (Maybe a)
runWrap Env
env {messages = messages', allow = "not visible"} ReaderT Env IO (Maybe a)
t

-- | Placeholder wrapper for a failing test. The test being wrapped is expected/known to fail.
-- Will produce a failure if the test being wrapped suddenly becomes a success.
pending :: (HasCallStack) => Test a -> Test a
pending :: forall a. HasCallStack => Test a -> Test a
pending Test a
test = do
  Maybe a
m <- Test a -> Test (Maybe a)
forall a. Test a -> Test (Maybe a)
attempt Test a
test
  case Maybe a
m of
    Just a
_ ->
      String -> Test a
forall a. HasCallStack => String -> Test a
crash String
"This pending test should not pass!"
    Maybe a
Nothing ->
      Test ()
ok Test () -> Test a -> Test a
forall a b. Test a -> Test b -> Test b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ReaderT Env IO (Maybe a) -> Test a
forall a. ReaderT Env IO (Maybe a) -> Test a
Test (Maybe a -> ReaderT Env IO (Maybe a)
forall a. a -> ReaderT Env IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing)

putResult :: Status -> ReaderT Env IO ()
putResult :: Status -> ReaderT Env IO ()
putResult Status
passed = do
  String
msgs <- (Env -> String) -> ReaderT Env IO String
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> String
messages
  Bool
allow <- (Env -> Bool) -> ReaderT Env IO Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (String -> Bool) -> (Env -> String) -> Env -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> String
allow)
  TMVar (String, Status)
r <- IO (TMVar (String, Status))
-> ReaderT Env IO (TMVar (String, Status))
forall a. IO a -> ReaderT Env IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (TMVar (String, Status))
 -> ReaderT Env IO (TMVar (String, Status)))
-> (STM (TMVar (String, Status)) -> IO (TMVar (String, Status)))
-> STM (TMVar (String, Status))
-> ReaderT Env IO (TMVar (String, Status))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM (TMVar (String, Status)) -> IO (TMVar (String, Status))
forall a. STM a -> IO a
atomically (STM (TMVar (String, Status))
 -> ReaderT Env IO (TMVar (String, Status)))
-> STM (TMVar (String, Status))
-> ReaderT Env IO (TMVar (String, Status))
forall a b. (a -> b) -> a -> b
$ (String, Status) -> STM (TMVar (String, Status))
forall a. a -> STM (TMVar a)
newTMVar (String
msgs, if Bool
allow then Status
passed else Status
Skipped)
  TBQueue (Maybe (TMVar (String, Status)))
q <- (Env -> TBQueue (Maybe (TMVar (String, Status))))
-> ReaderT Env IO (TBQueue (Maybe (TMVar (String, Status))))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> TBQueue (Maybe (TMVar (String, Status)))
results
  IO () -> ReaderT Env IO ()
forall (m :: * -> *) a. Monad m => m a -> ReaderT Env m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> ReaderT Env IO ())
-> (STM () -> IO ()) -> STM () -> ReaderT Env IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> ReaderT Env IO ()) -> STM () -> ReaderT Env IO ()
forall a b. (a -> b) -> a -> b
$ TBQueue (Maybe (TMVar (String, Status)))
-> Maybe (TMVar (String, Status)) -> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue TBQueue (Maybe (TMVar (String, Status)))
q (TMVar (String, Status) -> Maybe (TMVar (String, Status))
forall a. a -> Maybe a
Just TMVar (String, Status)
r)

instance MonadReader Env Test where
  ask :: Test Env
ask = ReaderT Env IO (Maybe Env) -> Test Env
forall a. ReaderT Env IO (Maybe a) -> Test a
Test (ReaderT Env IO (Maybe Env) -> Test Env)
-> ReaderT Env IO (Maybe Env) -> Test Env
forall a b. (a -> b) -> a -> b
$ do
    Bool
allow <- (Env -> Bool) -> ReaderT Env IO Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (String -> Bool) -> (Env -> String) -> Env -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> String
allow)
    if Bool
allow then Env -> Maybe Env
forall a. a -> Maybe a
Just (Env -> Maybe Env)
-> ReaderT Env IO Env -> ReaderT Env IO (Maybe Env)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT Env IO Env
forall r (m :: * -> *). MonadReader r m => m r
ask else Maybe Env -> ReaderT Env IO (Maybe Env)
forall a. a -> ReaderT Env IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Env
forall a. Maybe a
Nothing
  local :: forall a. (Env -> Env) -> Test a -> Test a
local Env -> Env
f (Test ReaderT Env IO (Maybe a)
t) = ReaderT Env IO (Maybe a) -> Test a
forall a. ReaderT Env IO (Maybe a) -> Test a
Test ((Env -> Env)
-> ReaderT Env IO (Maybe a) -> ReaderT Env IO (Maybe a)
forall a. (Env -> Env) -> ReaderT Env IO a -> ReaderT Env IO a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local Env -> Env
f ReaderT Env IO (Maybe a)
t)
  reader :: forall a. (Env -> a) -> Test a
reader Env -> a
f = ReaderT Env IO (Maybe a) -> Test a
forall a. ReaderT Env IO (Maybe a) -> Test a
Test (a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> ReaderT Env IO a -> ReaderT Env IO (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Env -> a) -> ReaderT Env IO a
forall a. (Env -> a) -> ReaderT Env IO a
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
reader Env -> a
f)

instance Monad Test where
  return :: forall a. a -> Test a
return = a -> Test a
forall a. a -> Test a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  Test ReaderT Env IO (Maybe a)
a >>= :: forall a b. Test a -> (a -> Test b) -> Test b
>>= a -> Test b
f = ReaderT Env IO (Maybe b) -> Test b
forall a. ReaderT Env IO (Maybe a) -> Test a
Test (ReaderT Env IO (Maybe b) -> Test b)
-> ReaderT Env IO (Maybe b) -> Test b
forall a b. (a -> b) -> a -> b
$ do
    Maybe a
a <- ReaderT Env IO (Maybe a)
a
    case Maybe a
a of
      Maybe a
Nothing -> Maybe b -> ReaderT Env IO (Maybe b)
forall a. a -> ReaderT Env IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe b
forall a. Maybe a
Nothing
      Just a
a -> let Test ReaderT Env IO (Maybe b)
t = a -> Test b
f a
a in ReaderT Env IO (Maybe b)
t

instance MonadFail Test where
  fail :: forall a. String -> Test a
fail = String -> Test a
forall a. HasCallStack => String -> Test a
crash

instance MonadThrow Test where
  throwM :: forall e a. (HasCallStack, Exception e) => e -> Test a
throwM = ReaderT Env IO (Maybe a) -> Test a
forall a. ReaderT Env IO (Maybe a) -> Test a
Test (ReaderT Env IO (Maybe a) -> Test a)
-> (e -> ReaderT Env IO (Maybe a)) -> e -> Test a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> ReaderT Env IO (Maybe a)
forall e a. (HasCallStack, Exception e) => e -> ReaderT Env IO a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM

instance MonadCatch Test where
  catch :: forall e a.
(HasCallStack, Exception e) =>
Test a -> (e -> Test a) -> Test a
catch (Test ReaderT Env IO (Maybe a)
m) e -> Test a
f =
    ReaderT Env IO (Maybe a) -> Test a
forall a. ReaderT Env IO (Maybe a) -> Test a
Test (ReaderT Env IO (Maybe a) -> Test a)
-> ReaderT Env IO (Maybe a) -> Test a
forall a b. (a -> b) -> a -> b
$ ReaderT Env IO (Maybe a)
-> (e -> ReaderT Env IO (Maybe a)) -> ReaderT Env IO (Maybe a)
forall e a.
(HasCallStack, Exception e) =>
ReaderT Env IO a -> (e -> ReaderT Env IO a) -> ReaderT Env IO a
forall (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
m a -> (e -> m a) -> m a
Catch.catch ReaderT Env IO (Maybe a)
m (\e
e -> case e -> Test a
f e
e of Test ReaderT Env IO (Maybe a)
m' -> ReaderT Env IO (Maybe a)
m')

instance Functor Test where
  fmap :: forall a b. (a -> b) -> Test a -> Test b
fmap = (a -> b) -> Test a -> Test b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM

instance Applicative Test where
  pure :: forall a. a -> Test a
pure a
a = ReaderT Env IO (Maybe a) -> Test a
forall a. ReaderT Env IO (Maybe a) -> Test a
Test (ReaderT Env IO (Maybe a) -> Test a)
-> ReaderT Env IO (Maybe a) -> Test a
forall a b. (a -> b) -> a -> b
$ do
    Bool
allow <- (Env -> Bool) -> ReaderT Env IO Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (String -> Bool) -> (Env -> String) -> Env -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> String
allow)
    pure $ if Bool
allow then a -> Maybe a
forall a. a -> Maybe a
Just a
a else Maybe a
forall a. Maybe a
Nothing
  <*> :: forall a b. Test (a -> b) -> Test a -> Test b
(<*>) = Test (a -> b) -> Test a -> Test b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance MonadIO Test where
  liftIO :: forall a. IO a -> Test a
liftIO IO a
io = do
    Bool
s <- (Env -> Bool) -> Test Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (String -> Bool) -> (Env -> String) -> Env -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> String
allow)
    if Bool
s
      then Test a -> Test a
forall a. Test a -> Test a
wrap (Test a -> Test a) -> Test a -> Test a
forall a b. (a -> b) -> a -> b
$ ReaderT Env IO (Maybe a) -> Test a
forall a. ReaderT Env IO (Maybe a) -> Test a
Test (a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> ReaderT Env IO a -> ReaderT Env IO (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO a -> ReaderT Env IO a
forall a. IO a -> ReaderT Env IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO a
io)
      else ReaderT Env IO (Maybe a) -> Test a
forall a. ReaderT Env IO (Maybe a) -> Test a
Test (Maybe a -> ReaderT Env IO (Maybe a)
forall a. a -> ReaderT Env IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing)

instance Alternative Test where
  empty :: forall a. Test a
empty = ReaderT Env IO (Maybe a) -> Test a
forall a. ReaderT Env IO (Maybe a) -> Test a
Test (Maybe a -> ReaderT Env IO (Maybe a)
forall a. a -> ReaderT Env IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing)
  Test ReaderT Env IO (Maybe a)
t1 <|> :: forall a. Test a -> Test a -> Test a
<|> Test ReaderT Env IO (Maybe a)
t2 = ReaderT Env IO (Maybe a) -> Test a
forall a. ReaderT Env IO (Maybe a) -> Test a
Test (ReaderT Env IO (Maybe a) -> Test a)
-> ReaderT Env IO (Maybe a) -> Test a
forall a b. (a -> b) -> a -> b
$ do
    Env
env <- ReaderT Env IO Env
forall r (m :: * -> *). MonadReader r m => m r
ask
    (TVar StdGen
rng1, TVar StdGen
rng2) <- IO (TVar StdGen, TVar StdGen)
-> ReaderT Env IO (TVar StdGen, TVar StdGen)
forall a. IO a -> ReaderT Env IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (TVar StdGen, TVar StdGen)
 -> ReaderT Env IO (TVar StdGen, TVar StdGen))
-> (STM (TVar StdGen, TVar StdGen)
    -> IO (TVar StdGen, TVar StdGen))
-> STM (TVar StdGen, TVar StdGen)
-> ReaderT Env IO (TVar StdGen, TVar StdGen)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM (TVar StdGen, TVar StdGen) -> IO (TVar StdGen, TVar StdGen)
forall a. STM a -> IO a
atomically (STM (TVar StdGen, TVar StdGen)
 -> ReaderT Env IO (TVar StdGen, TVar StdGen))
-> STM (TVar StdGen, TVar StdGen)
-> ReaderT Env IO (TVar StdGen, TVar StdGen)
forall a b. (a -> b) -> a -> b
$ do
      StdGen
currentRng <- TVar StdGen -> STM StdGen
forall a. TVar a -> STM a
readTVar (Env -> TVar StdGen
rng Env
env)
      let (StdGen
rng1, StdGen
rng2) = StdGen -> (StdGen, StdGen)
forall g. RandomGen g => g -> (g, g)
Random.split StdGen
currentRng
      (,) (TVar StdGen -> TVar StdGen -> (TVar StdGen, TVar StdGen))
-> STM (TVar StdGen)
-> STM (TVar StdGen -> (TVar StdGen, TVar StdGen))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StdGen -> STM (TVar StdGen)
forall a. a -> STM (TVar a)
newTVar StdGen
rng1 STM (TVar StdGen -> (TVar StdGen, TVar StdGen))
-> STM (TVar StdGen) -> STM (TVar StdGen, TVar StdGen)
forall a b. STM (a -> b) -> STM a -> STM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> StdGen -> STM (TVar StdGen)
forall a. a -> STM (TVar a)
newTVar StdGen
rng2
    IO (Maybe a) -> ReaderT Env IO (Maybe a)
forall (m :: * -> *) a. Monad m => m a -> ReaderT Env m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (Maybe a) -> ReaderT Env IO (Maybe a))
-> IO (Maybe a) -> ReaderT Env IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ do
      Maybe a
r1 <- Env -> ReaderT Env IO (Maybe a) -> IO (Maybe a)
forall a. Env -> ReaderT Env IO (Maybe a) -> IO (Maybe a)
runWrap (Env
env {rng = rng1}) ReaderT Env IO (Maybe a)
t1
      (Maybe a -> Maybe a -> Maybe a
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe a
r1) (Maybe a -> Maybe a) -> IO (Maybe a) -> IO (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Env -> ReaderT Env IO (Maybe a) -> IO (Maybe a)
forall a. Env -> ReaderT Env IO (Maybe a) -> IO (Maybe a)
runWrap (Env
env {rng = rng2}) ReaderT Env IO (Maybe a)
t2

instance MonadPlus Test where
  mzero :: forall a. Test a
mzero = Test a
forall a. Test a
forall (f :: * -> *) a. Alternative f => f a
empty
  mplus :: forall a. Test a -> Test a -> Test a
mplus = Test a -> Test a -> Test a
forall a. Test a -> Test a -> Test a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>)

-- | Run a test in a separate thread, not blocking for its result.
fork :: Test a -> Test ()
fork :: forall a. Test a -> Test ()
fork Test a
t = Test (Test a) -> Test ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Test a -> Test (Test a)
forall a. Test a -> Test (Test a)
fork' Test a
t)

-- | Run a test in a separate thread, return a future which can be used
-- to block on its result.
fork' :: Test a -> Test (Test a)
fork' :: forall a. Test a -> Test (Test a)
fork' (Test ReaderT Env IO (Maybe a)
t) = do
  Env
env <- Test Env
forall r (m :: * -> *). MonadReader r m => m r
ask
  TMVar (String, Status)
tmvar <- IO (TMVar (String, Status)) -> Test (TMVar (String, Status))
forall a. IO a -> Test a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (TMVar (String, Status))
forall a. IO (TMVar a)
newEmptyTMVarIO
  IO () -> Test ()
forall a. IO a -> Test a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Test ()) -> (STM () -> IO ()) -> STM () -> Test ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> Test ()) -> STM () -> Test ()
forall a b. (a -> b) -> a -> b
$ TBQueue (Maybe (TMVar (String, Status)))
-> Maybe (TMVar (String, Status)) -> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue (Env -> TBQueue (Maybe (TMVar (String, Status)))
results Env
env) (TMVar (String, Status) -> Maybe (TMVar (String, Status))
forall a. a -> Maybe a
Just TMVar (String, Status)
tmvar)
  Async (Maybe a)
r <- IO (Async (Maybe a)) -> Test (Async (Maybe a))
forall a. IO a -> Test a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Async (Maybe a)) -> Test (Async (Maybe a)))
-> (IO (Maybe a) -> IO (Async (Maybe a)))
-> IO (Maybe a)
-> Test (Async (Maybe a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Maybe a) -> IO (Async (Maybe a))
forall a. IO a -> IO (Async a)
A.async (IO (Maybe a) -> Test (Async (Maybe a)))
-> IO (Maybe a) -> Test (Async (Maybe a))
forall a b. (a -> b) -> a -> b
$ Env -> ReaderT Env IO (Maybe a) -> IO (Maybe a)
forall a. Env -> ReaderT Env IO (Maybe a) -> IO (Maybe a)
runWrap Env
env ReaderT Env IO (Maybe a)
t
  Async (Maybe a)
waiter <- IO (Async (Maybe a)) -> Test (Async (Maybe a))
forall a. IO a -> Test a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Async (Maybe a)) -> Test (Async (Maybe a)))
-> (IO (Maybe a) -> IO (Async (Maybe a)))
-> IO (Maybe a)
-> Test (Async (Maybe a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Maybe a) -> IO (Async (Maybe a))
forall a. IO a -> IO (Async a)
A.async (IO (Maybe a) -> Test (Async (Maybe a)))
-> IO (Maybe a) -> Test (Async (Maybe a))
forall a b. (a -> b) -> a -> b
$ do
    Either SomeException (Maybe a)
e <- Async (Maybe a) -> IO (Either SomeException (Maybe a))
forall a. Async a -> IO (Either SomeException a)
A.waitCatch Async (Maybe a)
r
    Bool
_ <- STM Bool -> IO Bool
forall a. STM a -> IO a
atomically (STM Bool -> IO Bool) -> STM Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ TMVar (String, Status) -> (String, Status) -> STM Bool
forall a. TMVar a -> a -> STM Bool
tryPutTMVar TMVar (String, Status)
tmvar (Env -> String
messages Env
env, Status
Skipped)
    case Either SomeException (Maybe a)
e of
      Left SomeException
_ -> Maybe a -> IO (Maybe a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
      Right Maybe a
a -> Maybe a -> IO (Maybe a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
a
  pure $ do
    Maybe a
a <- IO (Maybe a) -> Test (Maybe a)
forall a. IO a -> Test a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Async (Maybe a) -> IO (Maybe a)
forall a. Async a -> IO a
A.wait Async (Maybe a)
waiter)
    case Maybe a
a of
      Maybe a
Nothing -> Test a
forall a. Test a
forall (f :: * -> *) a. Alternative f => f a
empty
      Just a
a -> a -> Test a
forall a. a -> Test a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a