conceit 0.1.1.0 → 0.2.0.0

raw patch · 3 files changed

+137/−35 lines, 3 filesdep +exceptionsdep +mtldep +semigroupoidsdep −asyncPVP ok

version bump matches the API change (PVP)

Dependencies added: exceptions, mtl, semigroupoids, void

Dependencies removed: async

API changes (from Hackage documentation)

Files

• CHANGELOG +7/−0
• conceit.cabal +5/−2
• src/Control/Concurrent/Conceit.hs +125/−33

@@ -1,3 +1,10 @@+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 ======= 

@@ -1,5 +1,5 @@ name:          conceit-version:       0.1.1.0+version:       0.2.0.0 license:       BSD3 license-file:  LICENSE data-files:    @@ -23,8 +23,11 @@     other-modules:      build-depends:                  base >= 4.4 && < 5,+        semigroupoids ==4.*,         bifunctors >= 4.1 && < 5,-        async >= 2.0.1 && < 2.1+        void >= 0.6 && < 0.7,+        exceptions >= 0.6 && < 0.7,+        mtl >=2.0 && <2.3   Source-repository head     type:     git

@@ -1,9 +1,13 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE CPP #-}  module Control.Concurrent.Conceit (            Conceit (..)         , _Conceit+        , _runConceit         , conceit         , mapConceit     ) where@@ -12,71 +16,159 @@ import Data.Monoid import Data.Typeable import Data.Traversable-import Control.Applicative+import Data.Void+import Control.Applicative  import Control.Monad-import Control.Exception+import qualified Control.Monad.Catch as Ex+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+import Data.Functor.Bind+import Data.Functor.Plus -revealError :: (Show e, Typeable e) => IO a -> IO (Either e a)  -revealError action = catch (action >>= return . Right)-                           (\(WrappedError e) -> return . Left $ e)   +#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 is used to run actions concurrently, wait until-they finish, and combine their results. +   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 actions are-immediately cancelled and the whole computation fails with @e@. +   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 -instance (Show e, Typeable e) => Applicative (Conceit e) where+instance Applicative (Conceit e) where   pure = Conceit . pure . pure   Conceit fs <*> Conceit as =-    Conceit . revealError $ -        uncurry ($) <$> concurrently (elideError fs) (elideError as)+         Conceit $ fmap (fmap (\(f, a) -> f a)) $ conceit fs as -instance (Show e, Typeable e) => Alternative (Conceit e) where+instance Alternative (Conceit e) where   empty = Conceit $ forever (threadDelay maxBound)   Conceit as <|> Conceit bs =-    Conceit $ either id id <$> race as bs+    Conceit $ fmap (fmap (either id id)) $ race as bs -instance (Show e, Typeable e, Monoid a) => Monoid (Conceit e a) where+instance (Monoid a) => Monoid (Conceit e a) where    mempty = Conceit . pure . pure $ mempty    mappend c1 c2 = (<>) <$> c1 <*> c2 +-- | `>>` is concurrent.+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+   f >> k = f *> k++instance MonadPlus (Conceit e) where+   mzero = empty+   mplus = (<|>)++instance MonadIO (Conceit e) where+   liftIO = _Conceit++-- | `<!>` makes its two arguments race against each other.+instance 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   -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+_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 :: (Show e, Typeable e, Traversable t) => (a -> IO (Either e b)) -> t a -> IO (Either e (t b))-mapConceit f = revealError .  mapConcurrently (elideError . f)+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