sandwich-0.3.0.5: test/Around.hs

{-# LANGUAGE DataKinds #-}

module Around where

import Control.Concurrent
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Writer
import Data.String.Interpolate
import GHC.Stack
import Test.Sandwich
import TestUtil
import UnliftIO.Exception


tests :: MonadIO m => WriterT [SomeException] m ()
tests = do
  run aroundDoesNotFailOnChildFailure
  run aroundReceivesSubtreeResult

main :: IO ()
main = mainWith tests

-- * Tests

aroundDoesNotFailOnChildFailure :: (HasCallStack) => IO ()
aroundDoesNotFailOnChildFailure = do
  results <- runAndGetResults $ around "around label" void $ do
    it "does thing 1" $ 2 `shouldBe` (3 :: Int)
    it "does thing 1" $ 2 `shouldBe` (2 :: Int)

  case results of
    [Success, Failure {}, Success] -> return ()
    xs -> error [i|Unexpected result: '#{xs}'|]

aroundReceivesSubtreeResult :: (HasCallStack) => IO ()
aroundReceivesSubtreeResult = do
  mvar <- newEmptyMVar

  _ <- runAndGetResults $ around "around label" (>>= (liftIO . putMVar mvar)) $ do
    it "does thing 1" $ 2 `shouldBe` (3 :: Int)
    it "does thing 1" $ 2 `shouldBe` (2 :: Int)

  takeMVar mvar >>= \case
    [Failure {}, Success] -> return ()
    xs -> error [i|Expected a failure and a success, but got '#{xs}'|]