packages feed

lifted-async (empty) → 0.0.0.1

raw patch · 8 files changed

+638/−0 lines, 8 filesdep +HUnitdep +asyncdep +basesetup-changed

Dependencies added: HUnit, async, base, lifted-async, lifted-base, monad-control, mtl, test-framework, test-framework-hunit, test-framework-th, transformers-base

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2012, Mitsutoshi Aoe++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Mitsutoshi Aoe nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ lifted-async.cabal view
@@ -0,0 +1,51 @@+name:                lifted-async+version:             0.0.0.1+synopsis:            Run lifted IO operations asynchronously and wait for their results+homepage:            https://github.com/maoe/lifted-async+license:             BSD3+license-file:        LICENSE+author:              Mitsutoshi Aoe+maintainer:          Mitsutoshi Aoe <maoe@foldr.in>+copyright:           (C) Mitsutoshi Aoe 2012+category:            Concurrency+build-type:          Simple+cabal-version:       >= 1.8++description:+  This package provides IO operations from @async@ package lifted to any+  instance of 'MonadBase' or 'MonadBaseControl'.++library+  exposed-modules:+    Control.Concurrent.Async.Lifted+  build-depends:+      base >= 4.3 && < 4.7+    , async >= 2.0.1+    , lifted-base >= 0.2+    , monad-control >= 0.3.1+    , transformers-base >= 0.4+  ghc-options: -Wall+  hs-source-dirs: src++test-suite test-lifted-async+  type: exitcode-stdio-1.0+  hs-source-dirs: tests+  main-is: TestSuite.hs+  other-modules:+    Test.Async.Common+    Test.Async.IO+    Test.Async.State+  build-depends:+      base+    , HUnit+    , lifted-async+    , lifted-base+    , monad-control+    , mtl+    , test-framework+    , test-framework-hunit+    , test-framework-th++source-repository head+  type: git+  location: https://github.com/maoe/lifted-async.git
+ src/Control/Concurrent/Async/Lifted.hs view
@@ -0,0 +1,306 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}++{- |+Module      : Control.Concurrent.Async.Lifted+Copyright   : (C) 2012 Mitsutoshi Aoe+License     : BSD-style (see the file LICENSE)+Maintainer  : Mitsutoshi Aoe <maoe@foldr.in>+Stability   : experimental++This is a wrapped version of "Control.Concurrent.Async" with types generalized+from 'IO' to all monads in either 'MonadBase' or 'MonadBaseControl'.+-}++module Control.Concurrent.Async.Lifted+  ( -- * Asynchronous actions+    A.Async+    -- ** Spawning+  , async, asyncBound, asyncOn, asyncWithUnmask, asyncOnWithUnmask++    -- ** Spawning with automatic 'cancel'ation+  , withAsync, withAsyncBound, withAsyncOn+  , withAsyncWithUnmask, withAsyncOnWithUnmask++    -- ** Quering 'Async's+  , wait, poll, waitCatch, cancel, cancelWith+  , A.asyncThreadId++    -- ** STM operations+  , A.waitSTM, A.pollSTM, A.waitCatchSTM++    -- ** Waiting for multiple 'Async's+  , waitAny, waitAnyCatch, waitAnyCancel, waitAnyCatchCancel+  , waitEither, waitEitherCatch, waitEitherCancel, waitEitherCatchCancel+  , waitEither_+  , waitBoth++    -- ** Linking+  , link, link2++    -- ** Convenient utilities+  , race, race_, concurrently, mapConcurrently+  , A.Concurrently, A.runConcurrently+  ) where++import Control.Monad ((>=>), liftM)+import Data.Traversable (Traversable(..))+import GHC.IO (unsafeUnmask)+import Prelude hiding (mapM)++import Control.Concurrent.Async (Async)+import Control.Exception.Lifted (SomeException, Exception, bracket)+import Control.Monad.Base (MonadBase(..))+import Control.Monad.Trans.Control+import qualified Control.Concurrent.Async as A++-- | Generalized version of 'A.async'.+async :: MonadBaseControl IO m => m a -> m (Async (StM m a))+async = asyncUsing A.async++-- | Generalized version of 'A.asyncBound'.+asyncBound :: MonadBaseControl IO m => m a -> m (Async (StM m a))+asyncBound = asyncUsing A.asyncBound++-- | Generalized version of 'A.asyncOn'.+asyncOn :: MonadBaseControl IO m => Int -> m a -> m (Async (StM m a))+asyncOn cpu = asyncUsing (A.asyncOn cpu)++-- | Generalized version of 'A.asyncWithUnmask'.+asyncWithUnmask+  :: MonadBaseControl IO m+  => ((forall b. m b -> m b) -> m a)+  -> m (Async (StM m a))+asyncWithUnmask actionWith =+  asyncUsing A.async (actionWith (liftBaseOp_ unsafeUnmask))++-- | Generalized version of 'A.asyncOnWithUnmask'.+asyncOnWithUnmask+  :: MonadBaseControl IO m+  => Int+  -> ((forall b. m b -> m b) -> m a)+  -> m (Async (StM m a))+asyncOnWithUnmask cpu actionWith =+  asyncUsing (A.asyncOn cpu) (actionWith (liftBaseOp_ unsafeUnmask))++asyncUsing+  :: MonadBaseControl IO m+  => (IO (StM m a) -> IO (Async (StM m a)))+  -> m a+  -> m (Async (StM m a))+asyncUsing fork m =+  liftBaseWith $ \runInIO -> fork (runInIO m)++-- | Generalized version of 'A.withAsync'.+withAsync+  :: MonadBaseControl IO m+  => m a+  -> (Async (StM m a) -> m b)+  -> m b+withAsync = withAsyncUsing async++-- | Generalized version of 'A.withAsyncBound'.+withAsyncBound+  :: MonadBaseControl IO m+  => m a+  -> (Async (StM m a) -> m b)+  -> m b+withAsyncBound = withAsyncUsing asyncBound++-- | Generalized version of 'A.withAsyncOn'.+withAsyncOn+  :: MonadBaseControl IO m+  => Int+  -> m a+  -> (Async (StM m a) -> m b)+  -> m b+withAsyncOn = withAsyncUsing . asyncOn++-- | Generalized version of 'A.withAsyncWithUnmask'.+withAsyncWithUnmask+  :: MonadBaseControl IO m+  => ((forall c. m c -> m c) -> m a)+  -> (Async (StM m a) -> m b)+  -> m b+withAsyncWithUnmask actionWith =+  withAsyncUsing async (actionWith (liftBaseOp_ unsafeUnmask))++-- | Generalized version of 'A.withAsyncOnWithUnmask'.+withAsyncOnWithUnmask+  :: MonadBaseControl IO m+  => Int+  -> ((forall c. m c -> m c) -> m a)+  -> (Async (StM m a) -> m b)+  -> m b+withAsyncOnWithUnmask cpu actionWith =+  withAsyncUsing (asyncOn cpu) (actionWith (liftBaseOp_ unsafeUnmask))++withAsyncUsing+  :: MonadBaseControl IO m+  => (m a -> m (Async (StM m a)))+  -> m a+  -> (Async (StM m a) -> m b)+  -> m b+withAsyncUsing fork action = bracket (fork action) cancel++-- | Generalized version of 'A.wait'.+wait :: MonadBaseControl IO m => Async (StM m a) -> m a+wait = liftBase . A.wait >=> restoreM++-- | Generalized version of 'A.poll'.+poll+  :: MonadBaseControl IO m+  => Async (StM m a)+  -> m (Maybe (Either SomeException a))+poll a =+  liftBase (A.poll a) >>=+  maybe (return Nothing) (liftM Just . sequenceEither)++-- | Generalized version of 'A.waitCatch'.+waitCatch+  :: MonadBaseControl IO m+  => Async (StM m a)+  -> m (Either SomeException a)+waitCatch a = liftBase (A.waitCatch a) >>= sequenceEither++-- | Generalized version of 'A.catch'.+cancel :: MonadBase IO m => Async (StM m a) -> m ()+cancel = liftBase . A.cancel++-- | Generalized version of 'A.cancelWith'.+cancelWith :: (MonadBase IO m, Exception e) => Async (StM m a) -> e -> m ()+cancelWith = (liftBase .) . A.cancelWith++-- | Generalized version of 'A.waitAny'.+waitAny :: MonadBaseControl IO m => [Async (StM m a)] -> m (Async (StM m a), a)+waitAny as = do+  (a, s) <- liftBase $ A.waitAny as+  r <- restoreM s+  return (a, r)++-- | Generalized version of 'A.waitAnyCatch'.+waitAnyCatch+  :: MonadBaseControl IO m+  => [Async (StM m a)]+  -> m (Async (StM m a), Either SomeException a)+waitAnyCatch as = do+  (a, s) <- liftBase $ A.waitAnyCatch as+  r <- sequenceEither s+  return (a, r)++-- | Generalized version of 'A.waitAnyCancel'.+waitAnyCancel :: MonadBase IO m => [Async a] -> m (Async a, a)+waitAnyCancel = liftBase . A.waitAnyCancel++-- | Generalized version of 'A.waitAnyCatchCancel'.+waitAnyCatchCancel+  :: MonadBaseControl IO m+  => [Async (StM m a)]+  -> m (Async (StM m a), Either SomeException a)+waitAnyCatchCancel as = do+  (a, s) <- liftBase $ A.waitAnyCatchCancel as+  r <- sequenceEither s+  return (a, r)++-- | Generalized version of 'A.waitEither'.+waitEither+  :: MonadBaseControl IO m+  => Async (StM m a)+  -> Async (StM m b)+  -> m (Either a b)+waitEither a b =+  liftBase (A.waitEither a b) >>=+  either (liftM Left . restoreM) (liftM Right . restoreM)++-- | Generalized version of 'A.waitEitherCatch'.+waitEitherCatch+  :: MonadBaseControl IO m+  => Async (StM m a)+  -> Async (StM m b)+  -> m (Either (Either SomeException a) (Either SomeException b))+waitEitherCatch a b =+  liftBase (A.waitEitherCatch a b) >>=+  either (liftM Left . sequenceEither) (liftM Right . sequenceEither)++-- | Generalized version of 'A.waitEitherCancel'.+waitEitherCancel+  :: MonadBaseControl IO m+  => Async (StM m a)+  -> Async (StM m b)+  -> m (Either a b)+waitEitherCancel a b =+  liftBase (A.waitEitherCancel a b) >>=+  either (liftM Left . restoreM) (liftM Right . restoreM)++-- | Generalized version of 'A.waitEitherCatchCancel'.+waitEitherCatchCancel+  :: MonadBaseControl IO m+  => Async (StM m a)+  -> Async (StM m b)+  -> m (Either (Either SomeException a) (Either SomeException b))+waitEitherCatchCancel a b =+  liftBase (A.waitEitherCatch a b) >>=+  either (liftM Left . sequenceEither) (liftM Right . sequenceEither)++-- | Generalized version of 'A.waitEither_'.+waitEither_+  :: MonadBaseControl IO m+  => Async (StM m a)+  -> Async (StM m b)+  -> m ()+waitEither_ = (liftBase .) . A.waitEither_++-- | Generalized version of 'A.waitBoth'.+waitBoth+  :: MonadBaseControl IO m+  => Async (StM m a)+  -> Async (StM m b)+  -> m (a, b)+waitBoth a b = do+  (sa, sb) <- liftBase (A.waitBoth a b)+  ra <- restoreM sa+  rb <- restoreM sb+  return (ra, rb)++-- | Generalized version of 'A.link'.+link :: MonadBase IO m => Async (StM m a) -> m ()+link = liftBase . A.link++-- | Generalized version of 'A.link2'.+link2 :: MonadBase IO m => Async (StM m a) -> Async (StM m b) -> m ()+link2 = (liftBase .) . A.link2++-- | Generalized version of 'A.race'.+race :: MonadBaseControl IO m => m a -> m b -> m (Either a b)+race left right =+  withAsync left $ \a ->+  withAsync right $ \b ->+  waitEither a b++-- | Generalized version of 'A.race_'.+race_ :: MonadBaseControl IO m => m a -> m b -> m ()+race_ left right =+  withAsync left $ \a ->+  withAsync right $ \b ->+  waitEither_ a b++-- | Generalized version of 'A.concurrently'.+concurrently :: MonadBaseControl IO m => m a -> m b -> m (a, b)+concurrently left right =+  withAsync left $ \a ->+  withAsync right $ \b ->+  waitBoth a b++-- | Generalized version of 'A.mapConcurrently'.+mapConcurrently+  :: (Traversable t, MonadBaseControl IO m)+  => (a -> m b)+  -> t a+  -> m (t b)+mapConcurrently f t =+  liftBaseWith (\runInIO ->+    A.runConcurrently $ traverse (A.Concurrently . runInIO . f) t) >>=+  mapM restoreM++sequenceEither :: MonadBaseControl IO m => Either e (StM m a) -> m (Either e a)+sequenceEither = either (return . Left) (liftM Right . restoreM)
+ tests/Test/Async/Common.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+module Test.Async.Common+  ( value+  , TestException(..)+  , module X+  ) where++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.HUnit as X hiding (Test)++import Control.Concurrent.Async.Lifted as X++value :: Int+value = 42++data TestException = TestException+  deriving (Eq, Show, Typeable)++instance Exception TestException
+ tests/Test/Async/IO.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE TemplateHaskell #-}+module Test.Async.IO+  ( ioTestGroup+  , ioTestGroupExtra+  ) 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 Test.Async.Common++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)+  r <- waitCatch a+  case r of+    Left _  -> assertFailure ""+    Right e -> e @?= value++case_async_wait :: Assertion+case_async_wait = do+  a <- async (return value)+  r <- wait a+  assertEqual "async_wait" r value++case_async_exwaitCatch :: Assertion+case_async_exwaitCatch = do+  a <- async (throwIO TestException)+  r <- waitCatch a+  case r of+    Left e  -> fromException e @?= Just TestException+    Right _ -> assertFailure ""++case_async_exwait :: Assertion+case_async_exwait = do+  a <- async (throwIO TestException)+  (wait a >> assertFailure "") `catch` \e -> e @?= TestException++case_withAsync_waitCatch :: Assertion+case_withAsync_waitCatch = do+  withAsync (return value) $ \a -> do+    r <- waitCatch a+    case r of+      Left _  -> assertFailure ""+      Right e -> e @?= value++case_withAsync_wait2 :: Assertion+case_withAsync_wait2 = do+  a <- withAsync (threadDelay 1000000) $ return+  r <- waitCatch a+  case r of+    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_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 ""++case_async_poll2 :: Assertion+case_async_poll2 = do+  a <- async (return value)+  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 ""
+ tests/Test/Async/State.hs view
@@ -0,0 +1,117 @@+{-# LANGUAGE TemplateHaskell #-}+module Test.Async.State+  ( stateTestGroup+  , stateTestGroupExtra+  ) where+import Control.Monad (when)+import Control.Monad.State+import Data.Maybe (isJust, isNothing)+import Prelude hiding (catch)++import Control.Concurrent.Lifted+import Control.Exception.Lifted++import Test.Async.Common++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 ""+    Right e -> do+      e @?= value+      s @?= value + 1++case_async_wait :: Assertion+case_async_wait = do+  (r, s) <- flip runStateT value $ do+    a <- async $ modify (+1) >> return value+    wait a+  r @?= value+  s @?= value + 1++case_async_exwaitCatch :: Assertion+case_async_exwaitCatch = do+  (r, s) <- flip runStateT value $ do+    a <- async $ modify (+1) >> throwIO TestException+    waitCatch a+  case r of+    Left e  -> do+      fromException e @?= Just TestException+      s @?= value+    Right _ -> assertFailure ""++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++case_withAsync_waitCatch :: Assertion+case_withAsync_waitCatch =+  void $ flip runStateT value $ do+    withAsync (modify (+1) >> return value) $ \a -> do+      r <- waitCatch a+      case r of+        Left _  -> liftIO $ assertFailure ""+        Right e -> do+          liftIO $ e @?= value+          s <- get+          liftIO $ s @?= value + 1++case_withAsync_wait2 :: Assertion+case_withAsync_wait2 = do+  (r, s) <- flip runStateT value $ do+    a <- withAsync (modify (+1) >> threadDelay 1000000) $ return+    waitCatch a+  case r of+    Left e  -> do+      fromException e @?= Just ThreadKilled+      s @?= value+    Right _ -> assertFailure ""++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_poll :: Assertion+case_async_poll =+  void $ flip runStateT value $ do+    a <- async (threadDelay 1000000)+    r <- poll a+    when (isJust r) $ liftIO $ assertFailure ""+    r <- poll a   -- poll twice, just to check we don't deadlock+    when (isJust r) $ liftIO $ assertFailure ""++case_async_poll2 :: Assertion+case_async_poll2 =+  void $ flip runStateT value $ do+    a <- async (return value)+    wait a+    r <- poll a+    when (isNothing r) $ liftIO $ assertFailure ""+    r <- poll a   -- poll twice, just to check we don't deadlock+    when (isNothing r) $ liftIO $ assertFailure ""
+ tests/TestSuite.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE ScopedTypeVariables,DeriveDataTypeable #-}+module Main where+import Test.Framework (defaultMain)++import Test.Async.IO+import Test.Async.State++main = defaultMain+  [ ioTestGroup+  , ioTestGroupExtra+  , stateTestGroup+  , stateTestGroupExtra+  ]