lifted-async 0.0.0.1 → 0.1.0
raw patch · 6 files changed
+228/−51 lines, 6 filesdep +criteriondep +deepseqdep ~asyncdep ~basePVP ok
version bump matches the API change (PVP)
Dependencies added: criterion, deepseq
Dependency ranges changed: async, base
API changes (from Hackage documentation)
Files
- benchmarks/Benchmarks.hs +125/−0
- lifted-async.cabal +14/−2
- src/Control/Concurrent/Async/Lifted.hs +11/−2
- tests/Test/Async/IO.hs +10/−14
- tests/Test/Async/State.hs +68/−31
- tests/TestSuite.hs +0/−2
+ benchmarks/Benchmarks.hs view
@@ -0,0 +1,125 @@+{-# LANGUAGE BangPatterns #-}+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++main :: IO ()+main = defaultMain+ [ bgroup "async-wait"+ [ bench "async" $ whnfIO asyncWait_async+ , bench "lifted-async" $ whnfIO asyncWait_liftedAsync+ ]+ , bgroup "async-cancel-waitCatch"+ [ bench "async" $ nfIO asyncCancelWaitCatch_async+ , bench "lifted-async" $ nfIO asyncCancelWaitCatch_liftedAsync+ ]+ , bgroup "waitAny"+ [ bench "async" $ whnfIO waitAny_async+ , bench "lifted-async" $ whnfIO waitAny_liftedAsync+ ]+ , bgroup "race"+ [ bench "async" $ nfIO race_async+ , bench "lifted-async" $ nfIO race_liftedAsync+ , bench "async (inlined)" $ nfIO race_async_inlined+ , bench "lifted-async (inlined)" $ nfIO race_liftedAsync_inlined+ ]+ , bgroup "concurrently"+ [ bench "async" $ nfIO concurrently_async+ , bench "lifted-async" $ nfIO concurrently_liftedAsync+ , bench "async (inlined)" $ nfIO concurrently_async_inlined+ , bench "lifted-async (inlined)" $ nfIO concurrently_liftedAsync_inlined+ ]+ , bgroup "mapConcurrently"+ [ bench "async" $ nfIO mapConcurrently_async+ , bench "lifted-async" $ nfIO mapConcurrently_liftedAsync+ ]+ ]++asyncWait_async :: IO Int+asyncWait_async = do+ a <- A.async (return 1)+ A.wait a++asyncWait_liftedAsync :: IO Int+asyncWait_liftedAsync = do+ a <- L.async (return 1)+ L.wait a++asyncCancelWaitCatch_async :: IO (Either SomeException Int)+asyncCancelWaitCatch_async = do+ a <- A.async (return 1)+ A.cancel a+ A.waitCatch a++asyncCancelWaitCatch_liftedAsync :: IO (Either SomeException Int)+asyncCancelWaitCatch_liftedAsync = do+ a <- L.async (return 1)+ L.cancel a+ L.waitCatch a++waitAny_async :: IO Int+waitAny_async = do+ as <- mapM (A.async . return) [1..10]+ (_, n) <- A.waitAny as+ return n++waitAny_liftedAsync :: IO Int+waitAny_liftedAsync = do+ as <- mapM (L.async . return) [1..10]+ (_, n) <- L.waitAny as+ return n++race_async :: IO (Either Int Int)+race_async =+ A.race (return 1) (return 2)++race_liftedAsync :: IO (Either Int Int)+race_liftedAsync =+ L.race (return 1) (return 2)++race_async_inlined :: IO (Either Int Int)+race_async_inlined =+ A.withAsync (return 1) $ \a ->+ A.withAsync (return 2) $ \b ->+ A.waitEither a b++race_liftedAsync_inlined :: IO (Either Int Int)+race_liftedAsync_inlined =+ L.withAsync (return 1) $ \a ->+ L.withAsync (return 2) $ \b ->+ L.waitEither a b++concurrently_async :: IO (Int, Int)+concurrently_async =+ A.concurrently (return 1) (return 2)++concurrently_liftedAsync :: IO (Int, Int)+concurrently_liftedAsync =+ L.concurrently (return 1) (return 2)++concurrently_async_inlined :: IO (Int, Int)+concurrently_async_inlined =+ A.withAsync (return 1) $ \a ->+ A.withAsync (return 2) $ \b ->+ A.waitBoth a b++concurrently_liftedAsync_inlined :: IO (Int, Int)+concurrently_liftedAsync_inlined =+ L.withAsync (return 1) $ \a ->+ L.withAsync (return 2) $ \b ->+ L.waitBoth a b++mapConcurrently_async :: IO [Int]+mapConcurrently_async =+ A.mapConcurrently return [1..10]++mapConcurrently_liftedAsync :: IO [Int]+mapConcurrently_liftedAsync =+ L.mapConcurrently return [1..10]++instance NFData SomeException where+ rnf (SomeException !e) = ()
lifted-async.cabal view
@@ -1,12 +1,13 @@ name: lifted-async-version: 0.0.0.1+version: 0.1.0 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 license: BSD3 license-file: LICENSE author: Mitsutoshi Aoe maintainer: Mitsutoshi Aoe <maoe@foldr.in>-copyright: (C) Mitsutoshi Aoe 2012+copyright: (C) 2012 Mitsutoshi Aoe category: Concurrency build-type: Simple cabal-version: >= 1.8@@ -45,6 +46,17 @@ , test-framework , test-framework-hunit , test-framework-th++benchmark benchmark-lifted-async+ type: exitcode-stdio-1.0+ hs-source-dirs: benchmarks+ main-is: Benchmarks.hs+ build-depends:+ base+ , async+ , criterion+ , deepseq+ , lifted-async source-repository head type: git
src/Control/Concurrent/Async/Lifted.hs view
@@ -43,7 +43,7 @@ , A.Concurrently, A.runConcurrently ) where -import Control.Monad ((>=>), liftM)+import Control.Monad ((>=>), liftM, void) import Data.Traversable (Traversable(..)) import GHC.IO (unsafeUnmask) import Prelude hiding (mapM)@@ -98,6 +98,7 @@ -> (Async (StM m a) -> m b) -> m b withAsync = withAsyncUsing async+{-# INLINABLE withAsync #-} -- | Generalized version of 'A.withAsyncBound'. withAsyncBound@@ -106,6 +107,7 @@ -> (Async (StM m a) -> m b) -> m b withAsyncBound = withAsyncUsing asyncBound+{-# INLINABLE withAsyncBound #-} -- | Generalized version of 'A.withAsyncOn'. withAsyncOn@@ -115,6 +117,7 @@ -> (Async (StM m a) -> m b) -> m b withAsyncOn = withAsyncUsing . asyncOn+{-# INLINABLE withAsyncOn #-} -- | Generalized version of 'A.withAsyncWithUnmask'. withAsyncWithUnmask@@ -124,6 +127,7 @@ -> m b withAsyncWithUnmask actionWith = withAsyncUsing async (actionWith (liftBaseOp_ unsafeUnmask))+{-# INLINABLE withAsyncWithUnmask #-} -- | Generalized version of 'A.withAsyncOnWithUnmask'. withAsyncOnWithUnmask@@ -134,6 +138,7 @@ -> m b withAsyncOnWithUnmask cpu actionWith = withAsyncUsing (asyncOn cpu) (actionWith (liftBaseOp_ unsafeUnmask))+{-# INLINABLE withAsyncOnWithUnmask #-} withAsyncUsing :: MonadBaseControl IO m@@ -248,7 +253,7 @@ => Async (StM m a) -> Async (StM m b) -> m ()-waitEither_ = (liftBase .) . A.waitEither_+waitEither_ = (void .) . waitEither -- | Generalized version of 'A.waitBoth'. waitBoth@@ -261,6 +266,7 @@ ra <- restoreM sa rb <- restoreM sb return (ra, rb)+{-# INLINABLE waitBoth #-} -- | Generalized version of 'A.link'. link :: MonadBase IO m => Async (StM m a) -> m ()@@ -276,6 +282,7 @@ withAsync left $ \a -> withAsync right $ \b -> waitEither a b+{-# INLINABLE race #-} -- | Generalized version of 'A.race_'. race_ :: MonadBaseControl IO m => m a -> m b -> m ()@@ -283,6 +290,7 @@ withAsync left $ \a -> withAsync right $ \b -> waitEither_ a b+{-# INLINABLE race_ #-} -- | Generalized version of 'A.concurrently'. concurrently :: MonadBaseControl IO m => m a -> m b -> m (a, b)@@ -290,6 +298,7 @@ withAsync left $ \a -> withAsync right $ \b -> waitBoth a b+{-# INLINABLE concurrently #-} -- | Generalized version of 'A.mapConcurrently'. mapConcurrently
tests/Test/Async/IO.hs view
@@ -1,7 +1,6 @@ {-# LANGUAGE TemplateHaskell #-} module Test.Async.IO ( ioTestGroup- , ioTestGroupExtra ) where import Control.Monad (when) import Data.Maybe (isJust, isNothing)@@ -17,11 +16,6 @@ ioTestGroup :: Test ioTestGroup = $(testGroupGenerator) -ioTestGroupExtra :: Test-ioTestGroupExtra =- testGroup "async cancel rep" $- replicate 1000 $ testCase "async cancel" async_cancel- case_async_waitCatch :: Assertion case_async_waitCatch = do a <- async (return value)@@ -65,14 +59,16 @@ Left e -> fromException e @?= Just ThreadKilled Right _ -> assertFailure "" -async_cancel :: Assertion-async_cancel = do- a <- async (return value)- cancelWith a TestException- r <- waitCatch a- case r of- Left e -> fromException e @?= Just TestException- Right r -> r @?= value+case_async_cancel :: Assertion+case_async_cancel = sequence_ $ replicate 1000 run+ where+ run = do+ a <- async (return value)+ cancelWith a TestException+ r <- waitCatch a+ case r of+ Left e -> fromException e @?= Just TestException+ Right r -> r @?= value case_async_poll :: Assertion case_async_poll = do
tests/Test/Async/State.hs view
@@ -1,10 +1,10 @@ {-# LANGUAGE TemplateHaskell #-} module Test.Async.State ( stateTestGroup- , stateTestGroupExtra ) where import Control.Monad (when) import Control.Monad.State+import Control.Monad.Writer import Data.Maybe (isJust, isNothing) import Prelude hiding (catch) @@ -16,18 +16,13 @@ stateTestGroup :: Test stateTestGroup = $(testGroupGenerator) -stateTestGroupExtra :: Test-stateTestGroupExtra =- testGroup "async cancel rep" $- replicate 1000 $ testCase "async cancel" async_cancel- case_async_waitCatch :: Assertion case_async_waitCatch = do (r, s) <- flip runStateT value $ do a <- async $ modify (+1) >> return value waitCatch a case r of- Left _ -> assertFailure ""+ Left _ -> assertFailure "An exception must not be raised." Right e -> do e @?= value s @?= value + 1@@ -49,16 +44,17 @@ Left e -> do fromException e @?= Just TestException s @?= value- Right _ -> assertFailure ""+ Right _ -> assertFailure "An exception must be raised." case_async_exwait :: Assertion case_async_exwait = void $ flip runStateT value $ do a <- async $ modify (+1) >> throwIO TestException- (wait a >> liftIO (assertFailure "")) `catch` \e -> do- liftIO $ e @?= TestException- s <- get- liftIO $ s @?= value+ (wait a >> liftIO (assertFailure "An exception must be raised"))+ `catch` \e -> do+ liftIO $ e @?= TestException+ s <- get+ liftIO $ s @?= value case_withAsync_waitCatch :: Assertion case_withAsync_waitCatch =@@ -66,7 +62,7 @@ withAsync (modify (+1) >> return value) $ \a -> do r <- waitCatch a case r of- Left _ -> liftIO $ assertFailure ""+ Left _ -> liftIO $ assertFailure "An exception must not be raised." Right e -> do liftIO $ e @?= value s <- get@@ -81,30 +77,34 @@ Left e -> do fromException e @?= Just ThreadKilled s @?= value- Right _ -> assertFailure ""+ Right _ -> assertFailure "An exception must be raised." -async_cancel :: Assertion-async_cancel = do- (r, s) <- flip runStateT value $ do- a <- async $ modify (+1) >> return value- cancelWith a TestException- waitCatch a- case r of- Left e -> do- fromException e @?= Just TestException- s @?= value- Right r -> do- r @?= value- s @?= value + 1+case_async_cancel :: Assertion+case_async_cancel = sequence_ $ replicate 1000 run+ where+ run = do+ (r, s) <- flip runStateT value $ do+ a <- async $ modify (+1) >> return value+ cancelWith a TestException+ waitCatch a+ case r of+ Left e -> do+ fromException e @?= Just TestException+ s @?= value+ Right r -> do+ r @?= value+ s @?= value + 1 case_async_poll :: Assertion case_async_poll = void $ flip runStateT value $ do a <- async (threadDelay 1000000) r <- poll a- when (isJust r) $ liftIO $ assertFailure ""+ 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) $ liftIO $ assertFailure ""+ when (isJust r) $+ liftIO $ assertFailure "The result must be Nothing." case_async_poll2 :: Assertion case_async_poll2 =@@ -112,6 +112,43 @@ a <- async (return value) wait a r <- poll a- when (isNothing r) $ liftIO $ assertFailure ""+ 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) $ liftIO $ assertFailure ""+ when (isNothing r) $+ liftIO $ assertFailure "The result must not be Nothing."++case_withAsync_waitEither_ :: Assertion+case_withAsync_waitEither_ = do+ ((), s) <- flip runStateT value $ do+ withAsync (modify (+1)) $ \a ->+ waitEither_ a a+ liftIO $ s @?= value + 1++case_withAsync_waitBoth1 :: Assertion+case_withAsync_waitBoth1 = do+ (_, s) <- flip runStateT value $ do+ withAsync (return value) $ \a ->+ withAsync (modify (+1)) $ \b ->+ waitBoth a b+ liftIO $ s @?= value + 1++case_withAsync_waitBoth2 :: Assertion+case_withAsync_waitBoth2 = do+ (_, s) <- flip runStateT value $ do+ withAsync (modify (+1)) $ \a ->+ withAsync (return value) $ \b ->+ waitBoth a b+ liftIO $ s @?= value++case_link :: Assertion+case_link = do+ r <- try $ flip runStateT value $ do+ a <- async $ threadDelay 1000000 >> return value+ link a+ cancelWith a TestException+ wait a+ case r of+ Left e -> do+ fromException e @?= Just TestException+ Right _ -> assertFailure "An exception must be raised."
tests/TestSuite.hs view
@@ -7,7 +7,5 @@ main = defaultMain [ ioTestGroup- , ioTestGroupExtra , stateTestGroup- , stateTestGroupExtra ]