conceit 0.2.2.1 → 0.5.0.0

raw patch · 4 files changed

Files

CHANGELOG +22/−0
README.md +6/−3
conceit.cabal +12/−15
src/Control/Concurrent/Conceit.hs +32/−73

CHANGELOG view

@@ -1,3 +1,25 @@+0.5.0.0
+=======
+    - Removed all dependencies except base. This is a breaking change because
+	  we lose the Alt, Plus and Apply instances.
+
+0.4.0.0
+=======
+    - Removed Monad, MonadThrow, MonadCatch instances.
+    - Added Semigroup instance.
+    - Removed exception and mtl dependencies.
+
+0.3.1.0
+=======
+    - Made internal function "conceit'" public.
+
+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.

README.md view

@@ -1,9 +1,12 @@ 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.
+A version of the
+[Concurrently](http://hackage.haskell.org/package/async-2.0.2/docs/Control-Concurrent-Async.html#t:Concurrently)
+Applicative from Simon Marlow's
+[async](http://hackage.haskell.org/package/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.

conceit.cabal view

@@ -1,36 +1,33 @@+cabal-version: 2.4
 name:          conceit
-version:       0.2.2.1
-license:       BSD3
+version:       0.5.0.0
+license:       BSD-3-Clause
 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
+synopsis:      Concurrent actions that may fail with a value.  
 
-Extra-Source-Files:
+description:   
+    A version of the async package's 'Control.Concurrent.Async.Concurrently' for
+    which the actions may fail with a value.
+
+extra-source-files:
     README.md
     CHANGELOG
 
-Library
+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
+        base >= 4.8 && < 5
 
-Source-repository head
+source-repository head
     type:     git
     location: https://github.com/danidiaz/conceit.git

src/Control/Concurrent/Conceit.hs view

@@ -1,8 +1,4 @@-{-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE CPP #-}
 
 module Control.Concurrent.Conceit ( 
           Conceit (..)
@@ -10,26 +6,21 @@         , _runConceit
         , conceit
         , mapConceit
+        -- * Internals
+        -- $internals
+        , conceit'
     ) where
 
+import Data.Void
 import Data.Bifunctor
-import Data.Monoid
-import Data.Typeable
+import Data.Semigroup
+import Data.Monoid (Monoid,mempty,mappend)
 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.Monad (forever)
 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@.
@@ -40,81 +31,40 @@    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.  
+   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
+  bimap f g (Conceit x) = Conceit $ liftA (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
 
+-- | `<|>` makes its two arguments race against each other.
 instance Alternative (Conceit e) where
   empty = Conceit $ forever (threadDelay maxBound)
   Conceit as <|> Conceit bs =
     Conceit $ fmap (fmap (either id id)) $ race as bs
 
+instance (Semigroup a) => Semigroup (Conceit e a) where
+  c1 <> c2 = (<>) <$> c1 <*> c2
+
 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)
-
+{-| 
+    Construct a 'Conceit' as if it were a 'Control.Concurrent.Async.Concurrently'.
+-}
 _Conceit :: IO a -> Conceit e a
 _Conceit = Conceit . fmap pure  
 
+{-| 
+    Run a 'Conceit' as if it were a 'Control.Concurrent.Async.Concurrently'.
+-}
 _runConceit :: Conceit Void a -> IO a
 _runConceit c = either absurd id <$> runConceit c 
 
@@ -129,6 +79,7 @@ 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
@@ -142,6 +93,7 @@             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 [])
@@ -156,8 +108,13 @@             Left ex -> throwIO ex
             Right r -> collect (r:xs) m
 
--- Verbatim copy of the internal concurrently' function from async
-conceit' :: IO a -> IO b
+
+{-| 
+    Verbatim copy of the internal @concurrently'@ function from the @async@
+    package.
+-}
+conceit' :: IO a 
+         -> IO b
          -> (MVar (Either SomeException (Either a b)) -> IO r)
          -> IO r
 conceit' left right collect = do
@@ -167,7 +124,9 @@                              `catchAll` (putMVar done . Left)
         rid <- forkIO $ restore (right >>= putMVar done . Right . Right)
                              `catchAll` (putMVar done . Left)
-        let stop = killThread lid >> killThread rid
+        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