conceit 0.2.2.1 → 0.3.0.0

raw patch · 6 files changed

+284/−275 lines, 6 filessetup-changedPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

CHANGELOG +32/−25
LICENSE +27/−27
README.md +11/−11
Setup.hs +2/−2
conceit.cabal +36/−36
src/Control/Concurrent/Conceit.hs +176/−174

CHANGELOG view

@@ -1,25 +1,32 @@-0.2.2.1
-=======
-    - Qualified Alt to make it compile with GHC 7.10.
-
-0.2.2.0
-=======
-    - Bumped void and exceptions dependencies.
-
-0.2.1.0
-=======
-    - Now >> behaves differently from the concurrent *>, and sequences its
-      arguments. It makes more sense for the monad. This is what Haxl does as
-      well. 
-    
-0.2.0.0
-=======
-    - Internal changes that remove the necessity for (Show e,Typeable e)
-      constraints.
-    - Removed async dependency.
-    - Many new instances for Conceit.
-
-0.1.1.0
-=======
-
-    - Added _Conceit.
+0.3.0.0+=======+    - Incorporate the solution to issue #27 from the async package+      https://github.com/simonmar/async/issues/27 +      This changes the order of cancellation of threads in case+      of an asynchronous exception.++0.2.2.1+=======+    - Qualified Alt to make it compile with GHC 7.10.++0.2.2.0+=======+    - Bumped void and exceptions dependencies.++0.2.1.0+=======+    - Now >> behaves differently from the concurrent *>, and sequences its+      arguments. It makes more sense for the monad. This is what Haxl does as+      well. +    +0.2.0.0+=======+    - Internal changes that remove the necessity for (Show e,Typeable e)+      constraints.+    - Removed async dependency.+    - Many new instances for Conceit.++0.1.1.0+=======++    - Added _Conceit.

LICENSE view

@@ -1,27 +1,27 @@-Copyright (c) 2014, Daniel Díaz Carrete
-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 the {organization} nor the names of its
-  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 HOLDER 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.
+Copyright (c) 2014, Daniel Díaz Carrete+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 the {organization} nor the names of its+  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 HOLDER 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.

README.md view

@@ -1,11 +1,11 @@-conceit
-=======
-
-A version of the Concurrently applicative from Simon Marlow's async package,
-with the difference that the concurrent computation stops if any of the actions
-returns a Left value, not only in the case of exceptions.
-
-The internals have been copied wholesale from Concurrently, with modifications
-to support the new behaviour.
-
-Includes a useful Bifunctor instance.
+conceit+=======++A version of the Concurrently applicative from Simon Marlow's async package,+with the difference that the concurrent computation stops if any of the actions+returns a Left value, not only in the case of exceptions.++The internals have been copied wholesale from Concurrently, with modifications+to support the new behaviour.++Includes a useful Bifunctor instance.

Setup.hs view

@@ -1,2 +1,2 @@-import Distribution.Simple
-main = defaultMain
+import Distribution.Simple+main = defaultMain

conceit.cabal view

@@ -1,36 +1,36 @@-name:          conceit
-version:       0.2.2.1
-license:       BSD3
-license-file:  LICENSE
-data-files:    
-author:        Daniel Díaz Carrete
-maintainer:    diaz_carrete@yahoo.com
-category:      Concurrency
-build-type:    Simple
-cabal-version: >= 1.10
-Synopsis:      Concurrent actions that may fail
-Description:   A version of the async package's 'Control.Concurrent.Async.Concurrently' for which the actions may fail
-
-Extra-Source-Files:
-    README.md
-    CHANGELOG
-
-Library
-    default-language: Haskell2010
-    hs-source-dirs: src
-    exposed-modules: 
-        Control.Concurrent.Conceit
-    other-modules: 
-    build-depends:         
-        base >= 4.4 && < 5,
-        semigroupoids ==4.*,
-        bifunctors >= 4.1 && < 5,
-        void >= 0.6 && < 1.0,
-        exceptions >= 0.6 && < 1.0,
-        mtl >=2.0 && <2.3,
-        transformers >=0.2 && < 0.5
-
-Source-repository head
-    type:     git
-    location: https://github.com/danidiaz/conceit.git
-
+name:          conceit+version:       0.3.0.0+license:       BSD3+license-file:  LICENSE+data-files:    +author:        Daniel Díaz Carrete+maintainer:    diaz_carrete@yahoo.com+category:      Concurrency+build-type:    Simple+cabal-version: >= 1.10+Synopsis:      Concurrent actions that may fail+Description:   A version of the async package's 'Control.Concurrent.Async.Concurrently' for which the actions may fail++Extra-Source-Files:+    README.md+    CHANGELOG++Library+    default-language: Haskell2010+    hs-source-dirs: src+    exposed-modules: +        Control.Concurrent.Conceit+    other-modules: +    build-depends:         +        base >= 4.4 && < 5,+        semigroupoids ==4.*,+        bifunctors >= 4.1 && < 5,+        void >= 0.6 && < 1.0,+        exceptions >= 0.6 && < 1.0,+        mtl >=2.0 && <2.3,+        transformers >=0.2 && < 0.5++Source-repository head+    type:     git+    location: https://github.com/danidiaz/conceit.git+

src/Control/Concurrent/Conceit.hs view

@@ -1,174 +1,176 @@-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE CPP #-}
-
-module Control.Concurrent.Conceit ( 
-          Conceit (..)
-        , _Conceit
-        , _runConceit
-        , conceit
-        , mapConceit
-    ) where
-
-import Data.Bifunctor
-import Data.Monoid
-import Data.Typeable
-import Data.Traversable
-import Data.Void
-import Control.Applicative 
-import Control.Monad
-import Control.Monad.IO.Class
-import qualified Control.Monad.Catch as Ex
-import Control.Exception 
-import Control.Concurrent
-import Data.Functor.Bind
-import Data.Functor.Plus
-
-#if MIN_VERSION_mtl(2, 2, 1)
-import Control.Monad.Except
-#endif
-
-{-| 
-    'Conceit' is very similar to 'Control.Concurrent.Async.Concurrently' from the
-@async@ package, but it has an explicit error type @e@.
-
-   The 'Applicative' instance runs two actions concurrently, waits until
-they finish, and combines their results. 
-
-   However, if any of the actions fails with @e@ the other action is
-   immediately cancelled and the whole computation fails with @e@. 
-
-    To put it another way: 'Conceit' behaves like 'Concurrently' for
-    successes and like 'race' for errors.  
--}
-newtype Conceit e a = Conceit { runConceit :: IO (Either e a) } deriving Functor
-
-instance Bifunctor Conceit where
-  bimap f g (Conceit x) = Conceit $ liftM (bimap f g) x
-
-instance Applicative (Conceit e) where
-  pure = Conceit . pure . pure
-  Conceit fs <*> Conceit as =
-         Conceit $ fmap (fmap (\(f, a) -> f a)) $ conceit fs as
-
-instance Alternative (Conceit e) where
-  empty = Conceit $ forever (threadDelay maxBound)
-  Conceit as <|> Conceit bs =
-    Conceit $ fmap (fmap (either id id)) $ race as bs
-
-instance (Monoid a) => Monoid (Conceit e a) where
-   mempty = Conceit . pure . pure $ mempty
-   mappend c1 c2 = (<>) <$> c1 <*> c2
-
--- | `>>` sequences its arguments.
-instance Monad (Conceit e) where
-   return = pure
-   f >>= k = Conceit $ do
-      x <- runConceit f
-      case x of 
-         Left e -> return $ Left e                      
-         Right r -> runConceit $ k r
-
-instance MonadPlus (Conceit e) where
-   mzero = empty
-   mplus = (<|>)
-
-instance MonadIO (Conceit e) where
-   liftIO = _Conceit
-
--- | `<!>` makes its two arguments race against each other.
-instance Data.Functor.Plus.Alt (Conceit e) where
-    (<!>) = (<|>)
-
--- | `zero` is a computation that never finishes.
-instance Plus (Conceit e) where
-    zero = empty
-
--- | `>>-` is sequential.
-instance Bind (Conceit s) where
-    (>>-) = (>>=)
-
--- | `<.>` is concurrent.
-instance Apply (Conceit s) where
-    (<.>) = (<*>) 
-    (<.) = (<*) 
-    (.>) = (*>) 
-
-
-#if MIN_VERSION_mtl(2, 2, 1)
-instance MonadError e (Conceit e) where
-     throwError = Conceit . pure . Left
-     Conceit c `catchError`  h = 
-        Conceit $ runExceptT $ ExceptT c `catchError` (ExceptT . runConceit . h)
-#endif
-
--- | Throws exceptions into IO.
-instance Ex.MonadThrow (Conceit e) where
-    throwM = Conceit . Ex.throwM
-
--- | Catches exceptions from IO.
-instance Ex.MonadCatch (Conceit e) where
-      catch (Conceit m) f = Conceit $ Ex.catch m (runConceit . f)
-
-_Conceit :: IO a -> Conceit e a
-_Conceit = Conceit . fmap pure  
-
-_runConceit :: Conceit Void a -> IO a
-_runConceit c = either absurd id <$> runConceit c 
-
-{-| 
-      Works similarly to 'Control.Concurrent.Async.mapConcurrently' from the
-@async@ package, but if any of the computations fails with @e@, the others are
-immediately cancelled and the whole computation fails with @e@. 
- -}
-mapConceit :: (Traversable t) => (a -> IO (Either e b)) -> t a -> IO (Either e (t b))
-mapConceit f = runConceit . sequenceA . fmap (Conceit . f)
-
-catchAll :: IO a -> (SomeException -> IO a) -> IO a
-catchAll = catch
-
--- Adapted from the race function from async
-race :: IO (Either e a) -> IO (Either e b) -> IO (Either e (Either a b)) 
-race left right = conceit' left right collect
-  where
-    collect m = do
-        e <- takeMVar m
-        case e of
-            Left ex -> throwIO ex
-            Right (Right (Right r1)) -> return $ Right $ Right r1
-            Right (Right (Left e1)) -> return $ Left e1 
-            Right (Left (Right r2)) -> return $ Right $ Left r2 
-            Right (Left (Left e2)) -> return $ Left e2
-
--- Adapted from the concurrently function from async
-conceit :: IO (Either e a) -> IO (Either e b) -> IO (Either e (a, b))
-conceit left right = conceit' left right (collect [])
-  where
-    collect [Left (Right a), Right (Right b)] _ = return $ Right (a,b)
-    collect [Right (Right b), Left (Right a)] _ = return $ Right (a,b)
-    collect (Left (Left ea):_) _ = return $ Left ea
-    collect (Right (Left eb):_) _ = return $ Left eb
-    collect xs m = do
-        e <- takeMVar m
-        case e of
-            Left ex -> throwIO ex
-            Right r -> collect (r:xs) m
-
--- Verbatim copy of the internal concurrently' function from async
-conceit' :: IO a -> IO b
-         -> (MVar (Either SomeException (Either a b)) -> IO r)
-         -> IO r
-conceit' left right collect = do
-    done <- newEmptyMVar
-    mask $ \restore -> do
-        lid <- forkIO $ restore (left >>= putMVar done . Right . Left)
-                             `catchAll` (putMVar done . Left)
-        rid <- forkIO $ restore (right >>= putMVar done . Right . Right)
-                             `catchAll` (putMVar done . Left)
-        let stop = killThread lid >> killThread rid
-        r <- restore (collect done) `onException` stop
-        stop
-        return r
-
+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE CPP #-}++module Control.Concurrent.Conceit ( +          Conceit (..)+        , _Conceit+        , _runConceit+        , conceit+        , mapConceit+    ) where++import Data.Bifunctor+import Data.Monoid+import Data.Typeable+import Data.Traversable+import Data.Void+import Control.Applicative +import Control.Monad+import Control.Monad.IO.Class+import qualified Control.Monad.Catch as Ex+import Control.Exception +import Control.Concurrent+import Data.Functor.Bind+import Data.Functor.Plus++#if MIN_VERSION_mtl(2, 2, 1)+import Control.Monad.Except+#endif++{-| +    'Conceit' is very similar to 'Control.Concurrent.Async.Concurrently' from the+@async@ package, but it has an explicit error type @e@.++   The 'Applicative' instance runs two actions concurrently, waits until+they finish, and combines their results. ++   However, if any of the actions fails with @e@ the other action is+   immediately cancelled and the whole computation fails with @e@. ++    To put it another way: 'Conceit' behaves like 'Concurrently' for+    successes and like 'race' for errors.  +-}+newtype Conceit e a = Conceit { runConceit :: IO (Either e a) } deriving Functor++instance Bifunctor Conceit where+  bimap f g (Conceit x) = Conceit $ liftM (bimap f g) x++instance Applicative (Conceit e) where+  pure = Conceit . pure . pure+  Conceit fs <*> Conceit as =+         Conceit $ fmap (fmap (\(f, a) -> f a)) $ conceit fs as++instance Alternative (Conceit e) where+  empty = Conceit $ forever (threadDelay maxBound)+  Conceit as <|> Conceit bs =+    Conceit $ fmap (fmap (either id id)) $ race as bs++instance (Monoid a) => Monoid (Conceit e a) where+   mempty = Conceit . pure . pure $ mempty+   mappend c1 c2 = (<>) <$> c1 <*> c2++-- | `>>` sequences its arguments.+instance Monad (Conceit e) where+   return = pure+   f >>= k = Conceit $ do+      x <- runConceit f+      case x of +         Left e -> return $ Left e                      +         Right r -> runConceit $ k r++instance MonadPlus (Conceit e) where+   mzero = empty+   mplus = (<|>)++instance MonadIO (Conceit e) where+   liftIO = _Conceit++-- | `<!>` makes its two arguments race against each other.+instance Data.Functor.Plus.Alt (Conceit e) where+    (<!>) = (<|>)++-- | `zero` is a computation that never finishes.+instance Plus (Conceit e) where+    zero = empty++-- | `>>-` is sequential.+instance Bind (Conceit s) where+    (>>-) = (>>=)++-- | `<.>` is concurrent.+instance Apply (Conceit s) where+    (<.>) = (<*>) +    (<.) = (<*) +    (.>) = (*>) +++#if MIN_VERSION_mtl(2, 2, 1)+instance MonadError e (Conceit e) where+     throwError = Conceit . pure . Left+     Conceit c `catchError`  h = +        Conceit $ runExceptT $ ExceptT c `catchError` (ExceptT . runConceit . h)+#endif++-- | Throws exceptions into IO.+instance Ex.MonadThrow (Conceit e) where+    throwM = Conceit . Ex.throwM++-- | Catches exceptions from IO.+instance Ex.MonadCatch (Conceit e) where+      catch (Conceit m) f = Conceit $ Ex.catch m (runConceit . f)++_Conceit :: IO a -> Conceit e a+_Conceit = Conceit . fmap pure  ++_runConceit :: Conceit Void a -> IO a+_runConceit c = either absurd id <$> runConceit c ++{-| +      Works similarly to 'Control.Concurrent.Async.mapConcurrently' from the+@async@ package, but if any of the computations fails with @e@, the others are+immediately cancelled and the whole computation fails with @e@. + -}+mapConceit :: (Traversable t) => (a -> IO (Either e b)) -> t a -> IO (Either e (t b))+mapConceit f = runConceit . sequenceA . fmap (Conceit . f)++catchAll :: IO a -> (SomeException -> IO a) -> IO a+catchAll = catch++-- Adapted from the race function from async+race :: IO (Either e a) -> IO (Either e b) -> IO (Either e (Either a b)) +race left right = conceit' left right collect+  where+    collect m = do+        e <- takeMVar m+        case e of+            Left ex -> throwIO ex+            Right (Right (Right r1)) -> return $ Right $ Right r1+            Right (Right (Left e1)) -> return $ Left e1 +            Right (Left (Right r2)) -> return $ Right $ Left r2 +            Right (Left (Left e2)) -> return $ Left e2++-- Adapted from the concurrently function from async+conceit :: IO (Either e a) -> IO (Either e b) -> IO (Either e (a, b))+conceit left right = conceit' left right (collect [])+  where+    collect [Left (Right a), Right (Right b)] _ = return $ Right (a,b)+    collect [Right (Right b), Left (Right a)] _ = return $ Right (a,b)+    collect (Left (Left ea):_) _ = return $ Left ea+    collect (Right (Left eb):_) _ = return $ Left eb+    collect xs m = do+        e <- takeMVar m+        case e of+            Left ex -> throwIO ex+            Right r -> collect (r:xs) m++-- Verbatim copy of the internal concurrently' function from async+conceit' :: IO a -> IO b+         -> (MVar (Either SomeException (Either a b)) -> IO r)+         -> IO r+conceit' left right collect = do+    done <- newEmptyMVar+    mask $ \restore -> do+        lid <- forkIO $ restore (left >>= putMVar done . Right . Left)+                             `catchAll` (putMVar done . Left)+        rid <- forkIO $ restore (right >>= putMVar done . Right . Right)+                             `catchAll` (putMVar done . Left)+        let stop = killThread rid >> killThread lid+            -- kill right before left, to match the semantics of+            -- the version using withAsync.+        r <- restore (collect done) `onException` stop+        stop+        return r+