lifted-async 0.1.0.1 → 0.1.1
raw patch · 8 files changed
+84/−44 lines, 8 filesdep +tastydep +tasty-hunitdep +tasty-thdep −test-frameworkdep −test-framework-hunitdep −test-framework-thdep ~asyncdep ~base
Dependencies added: tasty, tasty-hunit, tasty-th
Dependencies removed: test-framework, test-framework-hunit, test-framework-th
Dependency ranges changed: async, base
Files
- benchmarks/Benchmarks.hs +2/−6
- lifted-async.cabal +19/−6
- src/Control/Concurrent/Async/Lifted.hs +9/−2
- tests/RegressionTests.hs +31/−0
- tests/Test/Async/Common.hs +3/−5
- tests/Test/Async/IO.hs +8/−11
- tests/Test/Async/State.hs +9/−12
- tests/TestSuite.hs +3/−2
benchmarks/Benchmarks.hs view
@@ -2,7 +2,6 @@ module Main where import Control.Exception (SomeException(..)) -import Control.DeepSeq (NFData(..)) import Criterion.Main import qualified Control.Concurrent.Async as A import qualified Control.Concurrent.Async.Lifted as L@@ -14,8 +13,8 @@ , bench "lifted-async" $ whnfIO asyncWait_liftedAsync ] , bgroup "async-cancel-waitCatch"- [ bench "async" $ nfIO asyncCancelWaitCatch_async- , bench "lifted-async" $ nfIO asyncCancelWaitCatch_liftedAsync+ [ bench "async" $ whnfIO asyncCancelWaitCatch_async+ , bench "lifted-async" $ whnfIO asyncCancelWaitCatch_liftedAsync ] , bgroup "waitAny" [ bench "async" $ whnfIO waitAny_async@@ -120,6 +119,3 @@ mapConcurrently_liftedAsync :: IO [Int] mapConcurrently_liftedAsync = L.mapConcurrently return [1..10]--instance NFData SomeException where- rnf (SomeException !e) = ()
lifted-async.cabal view
@@ -1,5 +1,5 @@ name: lifted-async-version: 0.1.0.1+version: 0.1.1 synopsis: Run lifted IO operations asynchronously and wait for their results homepage: https://github.com/maoe/lifted-async bug-reports: https://github.com/maoe/lifted-async/issues@@ -43,15 +43,28 @@ , lifted-base , monad-control , mtl- , test-framework- , test-framework-hunit- , test-framework-th+ , tasty+ , tasty-hunit+ , tasty-th +test-suite regression-tests+ type: exitcode-stdio-1.0+ hs-source-dirs: tests+ main-is: RegressionTests.hs+ ghc-options: -Wall -O -threaded+ build-depends:+ base+ , async+ , lifted-async+ , mtl+ , tasty-hunit+ , tasty-th+ benchmark benchmark-lifted-async type: exitcode-stdio-1.0 hs-source-dirs: benchmarks main-is: Benchmarks.hs- ghc-options: -O+ ghc-options: -Wall -O build-depends: base , async@@ -63,7 +76,7 @@ type: exitcode-stdio-1.0 hs-source-dirs: benchmarks main-is: Benchmarks.hs- ghc-options: -O -threaded+ ghc-options: -Wall -O -threaded build-depends: base , async
src/Control/Concurrent/Async/Lifted.hs view
@@ -49,10 +49,11 @@ import Prelude hiding (mapM) import Control.Concurrent.Async (Async)-import Control.Exception.Lifted (SomeException, Exception, bracket)+import Control.Exception.Lifted (SomeException, Exception) import Control.Monad.Base (MonadBase(..)) import Control.Monad.Trans.Control import qualified Control.Concurrent.Async as A+import qualified Control.Exception.Lifted as E -- | Generalized version of 'A.async'. async :: MonadBaseControl IO m => m a -> m (Async (StM m a))@@ -146,7 +147,13 @@ -> m a -> (Async (StM m a) -> m b) -> m b-withAsyncUsing fork action = bracket (fork action) cancel+withAsyncUsing fork action inner = E.mask $ \restore -> do+ a <- fork $ restore action+ r <- restore (inner a) `E.catch` \e -> do+ cancel a+ E.throwIO (e :: SomeException)+ cancel a+ return r -- | Generalized version of 'A.wait'. wait :: MonadBaseControl IO m => Async (StM m a) -> m a
+ tests/RegressionTests.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE TemplateHaskell #-}+import Control.Monad (when, void)+import Data.Function (fix)+import Data.IORef+import Foreign.C.Types (CUInt(..))++import Control.Concurrent.Async.Lifted++import Test.Tasty.TH+import Test.Tasty.HUnit++main :: IO ()+main = $defaultMainGenerator++-- https://github.com/maoe/lifted-async/issues/1+case_issue1 :: Assertion+case_issue1 = do+ ref <- newIORef (5 :: Int)+ withAsync (zombie ref) $ \_ -> return ()+ n <- readIORef ref+ n @?= 5+ where+ zombie ref = fix $ \loop -> do+ n <- readIORef ref+ when (n > 0) $ do+ void $ c_sleep 1+ writeIORef ref $! n - 1+ loop++foreign import ccall safe "sleep" c_sleep :: CUInt -> IO CUInt
tests/Test/Async/Common.hs view
@@ -8,12 +8,10 @@ import Data.Typeable -import Control.Concurrent.Lifted (threadDelay) import Control.Exception.Lifted-import Control.Monad.Trans.Control-import Test.Framework as X-import Test.Framework.Providers.HUnit as X-import Test.Framework.TH as X+import Test.Tasty as X+import Test.Tasty.HUnit as X+import Test.Tasty.TH as X import Test.HUnit as X hiding (Test) import Control.Concurrent.Async.Lifted as X
tests/Test/Async/IO.hs view
@@ -4,16 +4,13 @@ ) where import Control.Monad (when) import Data.Maybe (isJust, isNothing)-import Prelude hiding (catch) import Control.Concurrent.Lifted-import Control.Exception.Lifted--import Test.Framework+import Control.Exception.Lifted as E import Test.Async.Common -ioTestGroup :: Test+ioTestGroup :: TestTree ioTestGroup = $(testGroupGenerator) case_async_waitCatch :: Assertion@@ -41,7 +38,7 @@ case_async_exwait :: Assertion case_async_exwait = do a <- async (throwIO TestException)- (wait a >> assertFailure "") `catch` \e -> e @?= TestException+ (wait a >> assertFailure "") `E.catch` \e -> e @?= TestException case_withAsync_waitCatch :: Assertion case_withAsync_waitCatch = do@@ -68,15 +65,15 @@ r <- waitCatch a case r of Left e -> fromException e @?= Just TestException- Right r -> r @?= value+ Right r' -> r' @?= value case_async_poll :: Assertion case_async_poll = do 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 ""+ r' <- poll a -- poll twice, just to check we don't deadlock+ when (isJust r') $ assertFailure "" case_async_poll2 :: Assertion case_async_poll2 = do@@ -84,5 +81,5 @@ wait a r <- poll a when (isNothing r) $ assertFailure ""- r <- poll a -- poll twice, just to check we don't deadlock- when (isNothing r) $ assertFailure ""+ r' <- poll a -- poll twice, just to check we don't deadlock+ when (isNothing r') $ assertFailure ""
tests/Test/Async/State.hs view
@@ -2,18 +2,15 @@ module Test.Async.State ( stateTestGroup ) where-import Control.Monad (when) import Control.Monad.State-import Control.Monad.Writer import Data.Maybe (isJust, isNothing)-import Prelude hiding (catch) import Control.Concurrent.Lifted-import Control.Exception.Lifted+import Control.Exception.Lifted as E import Test.Async.Common -stateTestGroup :: Test+stateTestGroup :: TestTree stateTestGroup = $(testGroupGenerator) case_async_waitCatch :: Assertion@@ -51,7 +48,7 @@ void $ flip runStateT value $ do a <- async $ modify (+1) >> throwIO TestException (wait a >> liftIO (assertFailure "An exception must be raised"))- `catch` \e -> do+ `E.catch` \e -> do liftIO $ e @?= TestException s <- get liftIO $ s @?= value@@ -91,8 +88,8 @@ Left e -> do fromException e @?= Just TestException s @?= value- Right r -> do- r @?= value+ Right r' -> do+ r' @?= value s @?= value + 1 case_async_poll :: Assertion@@ -102,8 +99,8 @@ r <- poll a when (isJust r) $ liftIO $ assertFailure "The result must be nothing."- r <- poll a -- poll twice, just to check we don't deadlock- when (isJust r) $+ r' <- poll a -- poll twice, just to check we don't deadlock+ when (isJust r') $ liftIO $ assertFailure "The result must be Nothing." case_async_poll2 :: Assertion@@ -114,8 +111,8 @@ r <- poll a when (isNothing r) $ liftIO $ assertFailure "The result must not be Nothing."- r <- poll a -- poll twice, just to check we don't deadlock- when (isNothing r) $+ r' <- poll a -- poll twice, just to check we don't deadlock+ when (isNothing r') $ liftIO $ assertFailure "The result must not be Nothing." case_withAsync_waitEither_ :: Assertion
tests/TestSuite.hs view
@@ -1,11 +1,12 @@ {-# LANGUAGE ScopedTypeVariables,DeriveDataTypeable #-} module Main where-import Test.Framework (defaultMain)+import Test.Tasty (defaultMain, testGroup) import Test.Async.IO import Test.Async.State -main = defaultMain+main :: IO ()+main = defaultMain $ testGroup "lifted-async test suite" [ ioTestGroup , stateTestGroup ]