conceit (empty) → 0.1.0.0

raw patch · 6 files changed

+146/−0 lines, 6 filesdep +asyncdep +basedep +bifunctorssetup-changed

Dependencies added: async, base, bifunctors

Files

CHANGELOG +0/−0
LICENSE +27/−0
README.md +7/−0
Setup.hs +2/−0
conceit.cabal +32/−0
src/Control/Concurrent/Conceit.hs +78/−0

+ CHANGELOG view

+ LICENSE view

@@ -0,0 +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.

+ README.md view

@@ -0,0 +1,7 @@+conceit
+=======
+
+A version of the async package's Concurrently for which the computations can
+be interrupted by returning a Left value.
+
+Includes a useful Bifunctor instance.

+ Setup.hs view

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

+ conceit.cabal view

@@ -0,0 +1,32 @@+name:          conceit
+version:       0.1.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,
+        bifunctors >= 4.1 && < 5,
+        async >= 2.0.1 && < 2.1
+
+Source-repository head
+    type:     git
+    location: https://github.com/danidiaz/conceit.git
+

+ src/Control/Concurrent/Conceit.hs view

@@ -0,0 +1,78 @@+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveFunctor #-}
+
+module Control.Concurrent.Conceit ( 
+          Conceit (..)
+        , conceit
+        , mapConceit
+    ) where
+
+import Data.Bifunctor
+import Data.Monoid
+import Data.Typeable
+import Data.Traversable
+import Control.Applicative
+import Control.Monad
+import Control.Exception
+import Control.Concurrent
+import Control.Concurrent.Async
+
+data WrappedError e = WrappedError e
+    deriving (Show, Typeable)
+
+instance (Show e, Typeable e) => Exception (WrappedError e)
+
+elideError :: (Show e, Typeable e) => IO (Either e a) -> IO a
+elideError action = action >>= either (throwIO . WrappedError) return
+
+revealError :: (Show e, Typeable e) => IO a -> IO (Either e a)  
+revealError action = catch (action >>= return . Right)
+                           (\(WrappedError e) -> return . Left $ e)   
+
+{-| 
+    'Conceit' is very similar to 'Control.Concurrent.Async.Concurrently' from the
+@async@ package, but it has an explicit error type @e@.
+
+   The 'Applicative' instance is used to run actions concurrently, wait until
+they finish, and combine their results. 
+
+   However, if any of the actions fails with @e@ the other actions are
+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 (Show e, Typeable e) => Applicative (Conceit e) where
+  pure = Conceit . pure . pure
+  Conceit fs <*> Conceit as =
+    Conceit . revealError $ 
+        uncurry ($) <$> concurrently (elideError fs) (elideError as)
+
+instance (Show e, Typeable e) => Alternative (Conceit e) where
+  empty = Conceit $ forever (threadDelay maxBound)
+  Conceit as <|> Conceit bs =
+    Conceit $ either id id <$> race as bs
+
+instance (Show e, Typeable e, Monoid a) => Monoid (Conceit e a) where
+   mempty = Conceit . pure . pure $ mempty
+   mappend c1 c2 = (<>) <$> c1 <*> c2
+
+conceit :: (Show e, Typeable e) 
+        => IO (Either e a)
+        -> IO (Either e b)
+        -> IO (Either e (a,b))
+conceit c1 c2 = runConceit $ (,) <$> Conceit c1 <*> Conceit c2
+
+{-| 
+      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 :: (Show e, Typeable e, Traversable t) => (a -> IO (Either e b)) -> t a -> IO (Either e (t b))
+mapConceit f = revealError .  mapConcurrently (elideError . f)
+