mirror of
https://github.com/barrucadu/dejafu.git
synced 2024-12-18 02:51:42 +03:00
Add some new async tests
This commit is contained in:
Michael Walker
parent
8636fe9708
commit
6bab3e883d
@ -1,38 +1,56 @@
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
|
||||
module Cases.Async where
|
||||
|
||||
import Control.Applicative ((<|>))
|
||||
import Control.Concurrent.Classy.Async
|
||||
import Control.Exception (AsyncException(..), BlockedIndefinitelyOnMVar(..), Exception, SomeException(..), fromException)
|
||||
import Control.Monad (forever)
|
||||
import Control.Monad.Conc.Class
|
||||
import Data.Typeable (Typeable, cast)
|
||||
import Test.Framework (Test, testGroup)
|
||||
import Test.Framework.Providers.HUnit (hUnitTestToTests)
|
||||
import Test.DejaFu (alwaysTrue, gives')
|
||||
import Test.HUnit (test)
|
||||
import Test.HUnit.DejaFu (testDejafu)
|
||||
import Control.Concurrent.Classy.CRef
|
||||
import Control.Exception (AsyncException(..), Exception, SomeException, fromException)
|
||||
import Control.Monad (forever, when)
|
||||
import Control.Monad.Catch (finally, try)
|
||||
import Control.Monad.Conc.Class hiding (threadDelay)
|
||||
import Data.List (sort)
|
||||
import Data.Maybe (isJust, isNothing)
|
||||
import Data.Typeable (Typeable)
|
||||
import Test.DejaFu (alwaysTrue)
|
||||
import Test.DejaFu.Conc (ConcST)
|
||||
|
||||
import Common
|
||||
|
||||
{-
|
||||
Tests from https://github.com/simonmar/async/blob/master/test/test-async.hs
|
||||
|
||||
The following are omitted:
|
||||
|
||||
* withasync_waitCatch_blocked: because dejafu does not do
|
||||
BlockedIndefinitelyOnMVar
|
||||
|
||||
* concurrently+success, concurrently+failure, race+success,
|
||||
race+failure, cancel, withAsync: because they rely on timing
|
||||
-}
|
||||
|
||||
tests :: [Test]
|
||||
tests =
|
||||
[ testGroup "async" . hUnitTestToTests $ test
|
||||
[ testDejafu async_wait "async_wait" $ alwaysTrue (==Right value)
|
||||
, testDejafu async_waitCatch "async_waitCatch" $ alwaysTrue (\case Right (Right v) -> v == value; _ -> False)
|
||||
, testDejafu async_exwait "async_exwait" $ alwaysTrue (==Right (Just TestException))
|
||||
, testDejafu async_exwaitCatch "async_exwaitCatch" $ alwaysTrue (==Right (Just TestException))
|
||||
, testDejafu async_cancel "async_cancel" $ gives' [Left (Just TestException), Right value]
|
||||
, testDejafu async_poll "async_poll" $ alwaysTrue (\case Right Nothing -> True; _ -> False)
|
||||
, testDejafu async_poll2 "async_poll2" $ alwaysTrue (\case Right (Just (Right v)) -> v == value; _ -> False)
|
||||
[ testGroup "async"
|
||||
[ testCase "async_wait" async_wait
|
||||
, testCase "async_waitCatch" async_waitCatch
|
||||
, testCase "async_exwait" async_exwait
|
||||
, testCase "async_exwaitCatch" async_exwaitCatch
|
||||
, testCase "async_cancel" async_cancel
|
||||
, testCase "async_poll" async_poll
|
||||
, testCase "async_poll2" async_poll2
|
||||
]
|
||||
|
||||
, testGroup "withAsync" . hUnitTestToTests $ test
|
||||
[ testDejafu withasync_waitCatch "withasync_waitCatch" $ alwaysTrue (\case Right (Right v) -> v == value; _ -> False)
|
||||
, testDejafu withasync_wait2 "withasync_wait2" $ alwaysTrue (\case Right (Left (Just ThreadKilled)) -> True; _ -> False)
|
||||
, testGroup "withAsync"
|
||||
[ testCase "withasync_waitCatch" withasync_waitCatch
|
||||
, testCase "withasync_wait2" withasync_wait2
|
||||
]
|
||||
|
||||
-- this fails because dejafu doesn't throw 'BlockedIndefinitelyOnMVar' in testing yet
|
||||
-- , testDejafu withasync_waitCatch_blocked "withasync_waitCatch_blocked" $ alwaysTrue (\case Right (Just BlockedIndefinitelyOnMVar) -> True; _ -> False)
|
||||
, testGroup "concurrently"
|
||||
[ testCase "concurrently_" case_concurrently_
|
||||
, testCase "replicateConcurrently_" case_replicateConcurrently
|
||||
, testCase "replicateConcurrently" case_replicateConcurrently_
|
||||
]
|
||||
]
|
||||
|
||||
@ -42,66 +60,126 @@ value = 42
|
||||
data TestException = TestException deriving (Eq,Show,Typeable)
|
||||
instance Exception TestException
|
||||
|
||||
async_wait :: MonadConc m => m Int
|
||||
async_wait = do
|
||||
a <- async $ return value
|
||||
wait a
|
||||
|
||||
async_waitCatch :: MonadConc m => m (Either SomeException Int)
|
||||
async_waitCatch :: MonadConc m => m ()
|
||||
async_waitCatch = do
|
||||
a <- async $ return value
|
||||
waitCatch a
|
||||
|
||||
async_exwait :: MonadConc m => m (Maybe TestException)
|
||||
async_exwait = do
|
||||
a <- async $ throw TestException
|
||||
(wait a >> return Nothing) `catch` (return . Just)
|
||||
|
||||
async_exwaitCatch :: MonadConc m => m (Maybe TestException)
|
||||
async_exwaitCatch = do
|
||||
a <- async $ throw TestException
|
||||
a <- async (return value)
|
||||
r <- waitCatch a
|
||||
return $ case r of
|
||||
Left e -> fromException e
|
||||
Right _ -> Nothing
|
||||
case r of
|
||||
Left _ -> assertFailure ""
|
||||
Right e -> e @?= value
|
||||
|
||||
async_cancel :: MonadConc m => m (Either (Maybe TestException) Int)
|
||||
async_wait :: MonadConc m => m ()
|
||||
async_wait = do
|
||||
a <- async (return value)
|
||||
r <- wait a
|
||||
assertEqual "async_wait" r value
|
||||
|
||||
async_exwaitCatch :: MonadConc m => m ()
|
||||
async_exwaitCatch = do
|
||||
a <- async (throwIO TestException)
|
||||
r <- waitCatch a
|
||||
case r of
|
||||
Left e -> fromException e @?= Just TestException
|
||||
Right _ -> assertFailure ""
|
||||
|
||||
async_exwait :: MonadConc m => m ()
|
||||
async_exwait = do
|
||||
a <- async (throwIO TestException)
|
||||
(wait a >> assertFailure "") `catch` \e -> e @?= TestException
|
||||
|
||||
withasync_waitCatch :: MonadConc m => m ()
|
||||
withasync_waitCatch = do
|
||||
withAsync (return value) $ \a -> do
|
||||
r <- waitCatch a
|
||||
case r of
|
||||
Left _ -> assertFailure ""
|
||||
Right e -> e @?= value
|
||||
|
||||
withasync_wait2 :: MonadConc m => m ()
|
||||
withasync_wait2 = do
|
||||
a <- withAsync (threadDelay 1000000) $ return
|
||||
r <- waitCatch a
|
||||
case r of
|
||||
Left e -> fromException e @?= Just ThreadKilled
|
||||
Right _ -> assertFailure ""
|
||||
|
||||
async_cancel :: MonadConc m => m ()
|
||||
async_cancel = do
|
||||
a <- async $ return value
|
||||
a <- async (return value)
|
||||
cancelWith a TestException
|
||||
r <- waitCatch a
|
||||
return $ case r of
|
||||
Left e -> Left $ fromException e
|
||||
Right v -> Right v
|
||||
case r of
|
||||
Left e -> fromException e @?= Just TestException
|
||||
Right r -> r @?= value
|
||||
|
||||
async_poll :: MonadConc m => m (Maybe (Either SomeException Int))
|
||||
async_poll :: MonadConc m => m ()
|
||||
async_poll = do
|
||||
a <- async $ forever yield
|
||||
poll a
|
||||
a <- async (threadDelay 1000000)
|
||||
r <- poll a
|
||||
when (isJust r) $ assertFailure ""
|
||||
r <- poll a -- poll twice, just to check we don't deadlock
|
||||
when (isJust r) $ assertFailure ""
|
||||
|
||||
async_poll2 :: MonadConc m => m (Maybe (Either SomeException Int))
|
||||
async_poll2 :: MonadConc m => m ()
|
||||
async_poll2 = do
|
||||
a <- async $ return value
|
||||
a <- async (return value)
|
||||
wait a
|
||||
poll a
|
||||
r <- poll a
|
||||
when (isNothing r) $ assertFailure ""
|
||||
r <- poll a -- poll twice, just to check we don't deadlock
|
||||
when (isNothing r) $ assertFailure ""
|
||||
|
||||
withasync_waitCatch :: MonadConc m => m (Either SomeException Int)
|
||||
withasync_waitCatch = withAsync (return value) waitCatch
|
||||
case_concurrently_ :: MonadConc m => m ()
|
||||
case_concurrently_ = do
|
||||
ref <- newCRef 0
|
||||
() <- concurrently_
|
||||
(atomicModifyCRef ref (\x -> (x + 1, True)))
|
||||
(atomicModifyCRef ref (\x -> (x + 2, 'x')))
|
||||
res <- readCRef ref
|
||||
res @?= 3
|
||||
|
||||
withasync_wait2 :: MonadConc m => m (Either (Maybe AsyncException) ())
|
||||
withasync_wait2 = do
|
||||
a <- withAsync (forever yield) return
|
||||
r <- waitCatch a
|
||||
return $ case r of
|
||||
-- dejafu-0.2 needs the 'cast', whereas dejafu-0.3 needs the
|
||||
-- 'fromException'. This is due to me fixing some bugs with
|
||||
-- exception handling in the test implementations.
|
||||
Left e@(SomeException e') -> Left (fromException e <|> cast e')
|
||||
Right x -> Right x
|
||||
case_replicateConcurrently :: MonadConc m => m ()
|
||||
case_replicateConcurrently = do
|
||||
ref <- newCRef 0
|
||||
let action = atomicModifyCRef ref (\x -> (x + 1, x + 1))
|
||||
resList <- replicateConcurrently 4 action
|
||||
resVal <- readCRef ref
|
||||
resVal @?= 4
|
||||
sort resList @?= [1..4]
|
||||
|
||||
withasync_waitCatch_blocked :: MonadConc m => m (Maybe BlockedIndefinitelyOnMVar)
|
||||
withasync_waitCatch_blocked = do
|
||||
r <- withAsync (newEmptyMVar >>= takeMVar) waitCatch
|
||||
return $ case r of
|
||||
Left e -> fromException e
|
||||
_ -> Nothing
|
||||
case_replicateConcurrently_ :: MonadConc m => m ()
|
||||
case_replicateConcurrently_ = do
|
||||
ref <- newCRef 0
|
||||
let action = atomicModifyCRef ref (\x -> (x + 1, x + 1))
|
||||
() <- replicateConcurrently_ 4 action
|
||||
resVal <- readCRef ref
|
||||
resVal @?= 4
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
|
||||
data TestFailed = TestFailed String deriving (Eq,Show,Typeable)
|
||||
instance Exception TestFailed
|
||||
|
||||
assertFailure :: MonadConc m => String -> m b
|
||||
assertFailure = throw . TestFailed
|
||||
|
||||
throwIO :: (Exception e, MonadConc m) => e -> m a
|
||||
throwIO = throw
|
||||
|
||||
-- the tests use 'threadDelay' with a big delay to represent a blocked thread
|
||||
threadDelay :: MonadConc m => Int -> m ()
|
||||
threadDelay _ = forever yield
|
||||
|
||||
(@?=) :: (Eq a, MonadConc m) => a -> a -> m ()
|
||||
(@?=) = assertEqual "not equal"
|
||||
|
||||
assertEqual :: (Eq a, MonadConc m) => String -> a -> a -> m ()
|
||||
assertEqual err a1 a2
|
||||
| a1 == a2 = pure ()
|
||||
| otherwise = assertFailure err
|
||||
|
||||
testCase :: String -> (forall t. ConcST t ()) -> Test
|
||||
testCase name c = djfu name (alwaysTrue p) (try c) where
|
||||
p (Right (Left (e::SomeException))) = False
|
||||
p (Right _) = True
|
||||
p (Left _) = False
|
||||
|
||||
Loading…
Reference in New Issue
Block a user