packages feed

concurrent-state 0.5.1.4 → 0.6.0.0

raw patch · 10 files changed

+505/−28 lines, 10 files

Files

changelog view
@@ -1,3 +1,8 @@+0.6.0.0+-------+* WriterC+* Run multiple RWSC operations concurrently (runRWSCs, etc.)+ 0.5.1.4 ------- * GHC 7.7 and 7.2 compatibility
concurrent-state.cabal view
@@ -1,7 +1,7 @@ name:                concurrent-state-version:             0.5.1.4+version:             0.6.0.0 synopsis:            MTL-like library using TVars-description:         State, RWS backed by TVar.+description:         Writer, State, RWS backed by TVar homepage:            https://github.com/joelteon/concurrent-state license:             MIT license-file:        LICENSE@@ -25,6 +25,9 @@                        Control.Monad.RWS.Concurrent                        Control.Monad.RWS.Concurrent.Lazy                        Control.Monad.RWS.Concurrent.Strict+                       Control.Monad.Writer.Concurrent+                       Control.Monad.Writer.Concurrent.Lazy+                       Control.Monad.Writer.Concurrent.Strict   build-depends:       base         >= 4.2 && < 4.8                      , exceptions   >= 0.3                      , mtl          >= 2.1
src/Control/Concurrent/Lifted/Fork.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE ImpredicativeTypes #-}  -----------------------------------------------------------------------------@@ -28,7 +29,11 @@  instance MonadFork IO where     fork = C.forkIO+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 700+    forkOn _ = C.forkIO+#else     forkOn = C.forkOn+#endif     forkOS = C.forkOS  instance MonadFork m => MonadFork (IdentityT m) where
src/Control/Monad/RWS/Concurrent/Lazy.hs view
@@ -21,12 +21,16 @@     -- *** Running RWSC actions     runRWSC, evalRWSC, execRWSC, mapRWSC, withRWSC, +    -- *** Running concurrent operations on a single input+    runRWSCs, evalRWSCs, execRWSCs,+     -- *** Lifting other operations-    liftCallCCC, liftCatch+    liftCallCC, liftCatch ) where  import Control.Applicative import Control.Concurrent.Lifted.Fork+import Control.Concurrent.MVar import Control.Concurrent.STM import Control.Exception (throwIO) import Control.Monad.Catch@@ -187,8 +191,8 @@     uncurry3 q (a,b,c) = q a b c  -- | Uniform lifting of a @callCC@ operation to the new monad.-liftCallCCC :: ((((a, TVar s, TVar w) -> m (b, TVar s, TVar w)) -> m (a, TVar s, TVar w)) -> m (a, TVar s, TVar w)) -> ((a -> RWSC r w s m b) -> RWSC r w s m a) -> RWSC r w s m a-liftCallCCC callCC f = RWSC $ \r s w ->+liftCallCC :: ((((a, TVar s, TVar w) -> m (b, TVar s, TVar w)) -> m (a, TVar s, TVar w)) -> m (a, TVar s, TVar w)) -> ((a -> RWSC r w s m b) -> RWSC r w s m a) -> RWSC r w s m a+liftCallCC callCC f = RWSC $ \r s w ->     callCC $ \c ->         _runRWSC (f (\a -> RWSC $ \_ _ _ -> c (a, s, w))) r s w @@ -196,3 +200,40 @@ liftCatch :: (m (a, TVar s, TVar w) -> (e -> m (a, TVar s, TVar w)) -> m (a, TVar s, TVar w)) -> RWSC l w s m a -> (e -> RWSC l w s m a) -> RWSC l w s m a liftCatch catchError m h =     RWSC $ \r s w -> _runRWSC m r s w `catchError` \e -> _runRWSC (h e) r s w++-- | Run multiple RWS operations on the same value, returning the resultant+-- state, output, and the value produced by each operation.+runRWSCs :: (MonadFork m, Monoid w)+         => [RWSC r w s m a] -- ^ RWS computations to execute+         -> r -- ^ environment+         -> s -- ^ initial state+         -> m ([a], s, w) -- ^ return values, final state, and output+runRWSCs ms r s = do+    output <- liftIO $ newTVarIO mempty+    st <- liftIO $ newTVarIO s+    mvs <- mapM (const (liftIO newEmptyMVar)) ms+    forM_ (zip mvs ms) $ \(mv, operation) -> fork $ do+        ~(res, _, _) <- runRWSC operation r st output+        liftIO $ putMVar mv res+    items <- forM mvs (liftIO . takeMVar)+    end <- liftIO $ readTVarIO st+    out <- liftIO $ readTVarIO output+    return (items, end, out)++-- | Run multiple RWS operations on the same value, returning the final+-- output and the return values of each operation.+evalRWSCs :: (MonadFork m, Monoid w)+          => [RWSC r w s m a] -- ^ RWS computations to execute+          -> r -- ^ environment+          -> s -- ^ initial state+          -> m ([a], w) -- ^ return values and output+evalRWSCs ms r s = liftM (\ ~(a,_,w) -> (a,w)) $ runRWSCs ms r s++-- | Run multiple RWS operations on the same value, returning the final+-- state and the return values of each operation.+execRWSCs :: (MonadFork m, Monoid w)+          => [RWSC r w s m a] -- ^ RWS computations to execute+          -> r -- ^ environment+          -> s -- ^ initial state+          -> m (s, w) -- ^ final state and output+execRWSCs ms r s = liftM (\ ~(_,s',w) -> (s',w)) $ runRWSCs ms r s
src/Control/Monad/RWS/Concurrent/Strict.hs view
@@ -21,12 +21,16 @@     -- *** Running RWSC actions     runRWSC, evalRWSC, execRWSC, mapRWSC, withRWSC, +    -- *** Running concurrent operations on a single input+    runRWSCs, evalRWSCs, execRWSCs,+     -- *** Lifting other operations-    liftCallCCC, liftCatch+    liftCallCC, liftCatch ) where  import Control.Applicative import Control.Concurrent.Lifted.Fork+import Control.Concurrent.MVar import Control.Concurrent.STM import Control.Exception (throwIO) import Control.Monad.Catch@@ -187,8 +191,8 @@     uncurry3 q (a,b,c) = q a b c  -- | Uniform lifting of a @callCC@ operation to the new monad.-liftCallCCC :: ((((a, TVar s, TVar w) -> m (b, TVar s, TVar w)) -> m (a, TVar s, TVar w)) -> m (a, TVar s, TVar w)) -> ((a -> RWSC r w s m b) -> RWSC r w s m a) -> RWSC r w s m a-liftCallCCC callCC f = RWSC $ \r s w ->+liftCallCC :: ((((a, TVar s, TVar w) -> m (b, TVar s, TVar w)) -> m (a, TVar s, TVar w)) -> m (a, TVar s, TVar w)) -> ((a -> RWSC r w s m b) -> RWSC r w s m a) -> RWSC r w s m a+liftCallCC callCC f = RWSC $ \r s w ->     callCC $ \c ->         _runRWSC (f (\a -> RWSC $ \_ _ _ -> c (a, s, w))) r s w @@ -196,3 +200,40 @@ liftCatch :: (m (a, TVar s, TVar w) -> (e -> m (a, TVar s, TVar w)) -> m (a, TVar s, TVar w)) -> RWSC l w s m a -> (e -> RWSC l w s m a) -> RWSC l w s m a liftCatch catchError m h =     RWSC $ \r s w -> _runRWSC m r s w `catchError` \e -> _runRWSC (h e) r s w++-- | Run multiple RWS operations on the same value, returning the resultant+-- state, output, and the value produced by each operation.+runRWSCs :: (MonadFork m, Monoid w)+         => [RWSC r w s m a] -- ^ RWS computations to execute+         -> r -- ^ environment+         -> s -- ^ initial state+         -> m ([a], s, w) -- ^ return values, final state, and output+runRWSCs ms r s = do+    output <- liftIO $ newTVarIO mempty+    st <- liftIO $ newTVarIO s+    mvs <- mapM (const (liftIO newEmptyMVar)) ms+    forM_ (zip mvs ms) $ \(mv, operation) -> fork $ do+        (res, _, _) <- runRWSC operation r st output+        liftIO $ putMVar mv res+    items <- forM mvs (liftIO . takeMVar)+    end <- liftIO $ readTVarIO st+    out <- liftIO $ readTVarIO output+    return (items, end, out)++-- | Run multiple RWS operations on the same value, returning the final+-- output and the return values of each operation.+evalRWSCs :: (MonadFork m, Monoid w)+          => [RWSC r w s m a] -- ^ RWS computations to execute+          -> r -- ^ environment+          -> s -- ^ initial state+          -> m ([a], w) -- ^ return values and output+evalRWSCs ms r s = liftM (\(a,_,w) -> (a,w)) $ runRWSCs ms r s++-- | Run multiple RWS operations on the same value, returning the final+-- state and the return values of each operation.+execRWSCs :: (MonadFork m, Monoid w)+          => [RWSC r w s m a] -- ^ RWS computations to execute+          -> r -- ^ environment+          -> s -- ^ initial state+          -> m (s, w) -- ^ final state and output+execRWSCs ms r s = liftM (\(_,s',w) -> (s',w)) $ runRWSCs ms r s
src/Control/Monad/State/Concurrent/Lazy.hs view
@@ -27,7 +27,7 @@     runStatesC, evalStatesC, execStatesC,      -- *** Lifting other operations-    liftCallCCC, liftCatchC, liftListenC, liftPassC+    liftCallCC, liftCatch, liftListen, liftPass ) where  import Control.Applicative@@ -106,7 +106,7 @@  instance (MonadIO m, MonadCatch m) => MonadCatch (StateC s m) where     throwM = liftIO . throwIO-    catch = liftCatchC catch+    catch = liftCatch catch     mask a = StateC $ \tv -> mask $ \u -> _runStateC (a $ q u) tv where         q u (StateC f) = StateC (u . f)     uninterruptibleMask a =@@ -155,29 +155,29 @@ execStateC m s = liftM snd $ runStateC m s  -- | Uniform lifting of a @callCC@ operation to the new monad.-liftCallCCC :: ((((a, TVar s) -> m (b, TVar s)) -> m (a, TVar s)) -> m (a, TVar s)) ->+liftCallCC :: ((((a, TVar s) -> m (b, TVar s)) -> m (a, TVar s)) -> m (a, TVar s)) ->     ((a -> StateC s m b) -> StateC s m a) -> StateC s m a-liftCallCCC callCC f = StateC $ \tv ->+liftCallCC callCC f = StateC $ \tv ->     callCC $ \c ->         _runStateC (f (\a -> StateC $ \_ -> c (a, tv))) tv  -- | Lift a @catchError@ operation to the new monad.-liftCatchC :: (m (a, TVar s) -> (e -> m (a, TVar s)) -> m (a, TVar s)) ->+liftCatch :: (m (a, TVar s) -> (e -> m (a, TVar s)) -> m (a, TVar s)) ->     StateC s m a -> (e -> StateC s m a) -> StateC s m a-liftCatchC catchError m h =+liftCatch catchError m h =     StateC $ \s -> _runStateC m s `catchError` \e -> _runStateC (h e) s  -- | Lift a @listen@ operation to the new monad.-liftListenC :: Monad m =>+liftListen :: Monad m =>     (m (a, TVar s) -> m ((a, TVar s), w)) -> StateC s m a -> StateC s m (a,w)-liftListenC listen m = StateC $ \tv -> do+liftListen listen m = StateC $ \tv -> do     ~((a, s'), w) <- listen (_runStateC m tv)     return ((a, w), s')  -- | Lift a @pass@ operation to the new monad.-liftPassC :: Monad m =>+liftPass :: Monad m =>     (m ((a, TVar s), b) -> m (a, TVar s)) -> StateC s m (a, b) -> StateC s m a-liftPassC pass m = StateC $ \tv -> pass $ do+liftPass pass m = StateC $ \tv -> pass $ do     ~((a, f), s') <- _runStateC m tv     return ((a, s'), f)
src/Control/Monad/State/Concurrent/Strict.hs view
@@ -27,7 +27,7 @@     runStatesC, evalStatesC, execStatesC,      -- *** Lifting other operations-    liftCallCCC, liftCatchC, liftListenC, liftPassC+    liftCallCC, liftCatch, liftListen, liftPass ) where  import Control.Applicative@@ -107,7 +107,7 @@  instance (MonadIO m, MonadCatch m) => MonadCatch (StateC s m) where     throwM = liftIO . throwIO-    catch = liftCatchC catch+    catch = liftCatch catch     mask a = StateC $ \tv -> mask $ \u -> _runStateC (a $ q u) tv where         q u (StateC f) = StateC (u . f)     uninterruptibleMask a =@@ -156,29 +156,29 @@ execStateC m s = liftM snd $ runStateC m s  -- | Uniform lifting of a @callCC@ operation to the new monad.-liftCallCCC :: ((((a, TVar s) -> m (b, TVar s)) -> m (a, TVar s)) -> m (a, TVar s)) ->+liftCallCC :: ((((a, TVar s) -> m (b, TVar s)) -> m (a, TVar s)) -> m (a, TVar s)) ->     ((a -> StateC s m b) -> StateC s m a) -> StateC s m a-liftCallCCC callCC f = StateC $ \tv ->+liftCallCC callCC f = StateC $ \tv ->     callCC $ \c ->         _runStateC (f (\a -> StateC $ \_ -> c (a, tv))) tv  -- | Lift a @catchError@ operation to the new monad.-liftCatchC :: (m (a, TVar s) -> (e -> m (a, TVar s)) -> m (a, TVar s)) ->+liftCatch :: (m (a, TVar s) -> (e -> m (a, TVar s)) -> m (a, TVar s)) ->     StateC s m a -> (e -> StateC s m a) -> StateC s m a-liftCatchC catchError m h =+liftCatch catchError m h =     StateC $ \s -> _runStateC m s `catchError` \e -> _runStateC (h e) s  -- | Lift a @listen@ operation to the new monad.-liftListenC :: Monad m =>+liftListen :: Monad m =>     (m (a, TVar s) -> m ((a, TVar s), w)) -> StateC s m a -> StateC s m (a,w)-liftListenC listen m = StateC $ \tv -> do+liftListen listen m = StateC $ \tv -> do     ((a, s'), w) <- listen (_runStateC m tv)     return ((a, w), s')  -- | Lift a @pass@ operation to the new monad.-liftPassC :: Monad m =>+liftPass :: Monad m =>     (m ((a, TVar s), b) -> m (a, TVar s)) -> StateC s m (a, b) -> StateC s m a-liftPassC pass m = StateC $ \tv -> pass $ do+liftPass pass m = StateC $ \tv -> pass $ do     ((a, f), s') <- _runStateC m tv     return ((a, s'), f)
+ src/Control/Monad/Writer/Concurrent.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-}++-----------------------------------------------------------------------------+-- |+-- Maintainer  : me@joelt.io+-- Stability   : experimental+-- Portability : portable+--+-- A monad whose actions produce an output.+-----------------------------------------------------------------------------+module Control.Monad.Writer.Concurrent (+    module Control.Monad.Writer.Concurrent.Lazy+) where++import Control.Monad.Writer.Concurrent.Lazy
+ src/Control/Monad/Writer/Concurrent/Lazy.hs view
@@ -0,0 +1,182 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-}++-----------------------------------------------------------------------------+-- |+-- Maintainer  : me@joelt.io+-- Stability   : experimental+-- Portability : portable+--+-- A monad whose actions produce an output.+--+-- This module builds output lazily. For a strict version, see+-- "Control.Monad.Writer.Concurrent.Strict".+-----------------------------------------------------------------------------+module Control.Monad.Writer.Concurrent.Lazy (+    module Control.Monad.Writer,+    -- *** The WriterC monad transformer+    WriterC,++    -- *** Running WriterC actions+    runWriterC, execWriterC, mapWriterC,++    -- *** Running concurrent operations on a single input+    runWritersC, execWritersC,++    -- *** Lifting other operations+    liftCallCC, liftCatch+) where++import Control.Applicative+import Control.Concurrent.Lifted.Fork+import Control.Concurrent.MVar+import Control.Concurrent.STM+import Control.Exception (throwIO)+import Control.Monad+import Control.Monad.Catch+import Control.Monad.Fix+import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Control.Monad.Reader+import Control.Monad.Writer++-- ---------------------------------------------------------------------------+-- | A concurrent monad transformer collecting output of type @w@.+--+-- This is very similar to @transformers@' 'WriterT', with the exception of+-- the 'MonadIO' constraint on every instance, which is necessary to+-- perform STM actions.+newtype WriterC w m a = WriterC+    { _runWriterC :: TVar w -> m (a, TVar w) }++instance MonadTrans (WriterC w) where+    lift m = WriterC $ \w -> do+        a <- m+        return (a, w)++instance MonadIO m => MonadIO (WriterC w m) where+    liftIO i = WriterC $ \w -> do+        a <- liftIO i+        return (a, w)++instance Functor m => Functor (WriterC w m) where+    fmap f m = WriterC $ \w ->+        fmap (\ ~(a, w') -> (f a, w')) $ _runWriterC m w++instance (Functor m, Monad m) => Applicative (WriterC w m) where+    pure = return+    (<*>) = ap++instance (Functor m, MonadPlus m) => Alternative (WriterC w m) where+    empty = mzero+    (<|>) = mplus++instance Monad m => Monad (WriterC w m) where+    return a = WriterC $ \w -> return (a, w)+    m >>= k = WriterC $ \w -> do+        ~(a, w') <- _runWriterC m w+        _runWriterC (k a) w'++instance MonadPlus m => MonadPlus (WriterC w m) where+    mzero = WriterC $ const mzero+    m `mplus` n = WriterC $ \w -> _runWriterC m w `mplus` _runWriterC n w++instance MonadFix m => MonadFix (WriterC w m) where+    mfix f = WriterC $ \w -> mfix $ \ ~(a, _) -> _runWriterC (f a) w++instance (Monoid w, MonadReader r m) => MonadReader r (WriterC w m) where+    ask = lift ask+    local f m = WriterC $ \w -> local f $ _runWriterC m w+    reader = lift . reader++instance (Monoid w, MonadIO m) => MonadWriter w (WriterC w m) where+    writer (a, w) = WriterC $ \tw -> do+        liftIO . atomically $ modifyTVar tw (<> w)+        return (a, tw)+    listen m = WriterC $ \tw -> do+        ~(a, tw') <- _runWriterC m tw+        w <- liftIO $ readTVarIO tw'+        return ((a, w), tw')+    pass m = WriterC $ \tw -> do+        ~((a, f), tw') <- _runWriterC m tw+        liftIO . atomically $ modifyTVar tw' f+        return (a, tw')++instance (MonadIO m, MonadCatch m) => MonadCatch (WriterC w m) where+    throwM = liftIO . throwIO+    catch = liftCatch catch+    mask a = WriterC $ \w -> mask $ \u -> _runWriterC (a $ q u) w where+        q u (WriterC f) = WriterC (u . f)+    uninterruptibleMask a =+        WriterC $ \w -> uninterruptibleMask $ \u -> _runWriterC (a $ q u) w where+        q u (WriterC f) = WriterC (u . f)++instance (Monoid w, MonadFork m) => MonadFork (WriterC w m) where+    fork = liftFork fork+    forkOn i = liftFork (forkOn i)+    forkOS = liftFork forkOS++liftFork :: Monad m => (m () -> m a) -> WriterC w m () -> WriterC w m a+liftFork f (WriterC m) = WriterC $ \w -> do+    tid <- f . voidM $ m w+    return (tid, w)+    where voidM = (>> return ())++-- | Unwrap a concurrent Writer monad computation as a function.+runWriterC :: MonadIO m+           => WriterC w m a -- ^ computation to execute+           -> TVar w -- ^ output channel+           -> m (a, w) -- ^ return value and collected output+runWriterC m tw = do+    (a, w) <- _runWriterC m tw+    w' <- liftIO $ readTVarIO w+    return (a, w')++-- | Unwrap a concurrent Writer monad computation as a function, discarding+-- the return value.+--+-- * @'execWriterC' m w = 'liftM' 'snd' ('runWriterC' m w)@+execWriterC :: MonadIO m+            => WriterC w m a -- ^ computation to execute+            -> TVar w -- ^ output channel+            -> m w -- ^ collected output+execWriterC m tw = liftM snd $ runWriterC m tw++-- | Map both the return value and output of a computation using the given+-- function.+mapWriterC :: (m (a, TVar w) -> n (b, TVar w)) -> WriterC w m a -> WriterC w n b+mapWriterC f m = WriterC $ \w -> f (_runWriterC m w)++-- | Lift a @callCC@ operation to the new monad.+liftCallCC :: ((((a, TVar w) -> m (b, TVar w)) -> m (a, TVar w)) -> m (a, TVar w)) -> ((a -> WriterC w m b) -> WriterC w m a) -> WriterC w m a+liftCallCC callCC f = WriterC $ \w ->+    callCC $ \c ->+        _runWriterC (f (\a -> WriterC $ \_ -> c (a, w))) w++-- | Lift a @catchError@ operation to the new monad.+liftCatch :: (m (a, TVar w) -> (e -> m (a, TVar w)) -> m (a, TVar w)) -> WriterC w m a -> (e -> WriterC w m a) -> WriterC w m a+liftCatch catchError m h =+    WriterC $ \w -> _runWriterC m w `catchError` \e -> _runWriterC (h e) w++-- | Run multiple Writer operations on the same value, returning the+-- resultant output and the value produced by each operation.+runWritersC :: (MonadFork m, Monoid w)+            => [WriterC w m a] -- ^ writer computations to execute+            -> m ([a], w) -- ^ return values and output+runWritersC ms = do+    output <- liftIO $ newTVarIO mempty+    mvs <- mapM (const (liftIO newEmptyMVar)) ms+    forM_ (zip mvs ms) $ \(mv, operation) -> fork $ do+        ~(res, _) <- runWriterC operation output+        liftIO $ putMVar mv res+    items <- forM mvs (liftIO . takeMVar)+    out <- liftIO $ readTVarIO output+    return (items, out)++-- | Run multiple Writer operations on the same value, returning the+-- resultant output.+execWritersC :: (MonadFork m, Monoid w)+             => [WriterC w m a] -- ^ writer computations to execute+             -> m w -- ^ output+execWritersC = liftM snd . runWritersC
+ src/Control/Monad/Writer/Concurrent/Strict.hs view
@@ -0,0 +1,183 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-}++-----------------------------------------------------------------------------+-- |+-- Maintainer  : me@joelt.io+-- Stability   : experimental+-- Portability : portable+--+-- A monad whose actions produce an output.+--+-- This module builds output strictly. For a lazy version, see+-- "Control.Monad.Writer.Concurrent.Lazy".+-----------------------------------------------------------------------------+module Control.Monad.Writer.Concurrent.Strict (+    module Control.Monad.Writer,+    -- *** The WriterC monad transformer+    WriterC,++    -- *** Running WriterC actions+    runWriterC, execWriterC, mapWriterC,++    -- *** Running concurrent operations on a single input+    runWritersC, execWritersC,++    -- *** Lifting other operations+    liftCallCC, liftCatch+) where++import Control.Applicative+import Control.Arrow (first)+import Control.Concurrent.Lifted.Fork+import Control.Concurrent.MVar+import Control.Concurrent.STM+import Control.Exception (throwIO)+import Control.Monad+import Control.Monad.Catch+import Control.Monad.Fix+import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Control.Monad.Reader+import Control.Monad.Writer++-- ---------------------------------------------------------------------------+-- | A concurrent monad transformer collecting output of type @w@.+--+-- This is very similar to @transformers@' 'WriterT', with the exception of+-- the 'MonadIO' constraint on every instance, which is necessary to+-- perform STM actions.+newtype WriterC w m a = WriterC+    { _runWriterC :: TVar w -> m (a, TVar w) }++instance MonadTrans (WriterC w) where+    lift m = WriterC $ \w -> do+        a <- m+        return (a, w)++instance MonadIO m => MonadIO (WriterC w m) where+    liftIO i = WriterC $ \w -> do+        a <- liftIO i+        return (a, w)++instance Functor m => Functor (WriterC w m) where+    fmap f m = WriterC $ \w ->+        fmap (first f) $ _runWriterC m w++instance (Functor m, Monad m) => Applicative (WriterC w m) where+    pure = return+    (<*>) = ap++instance (Functor m, MonadPlus m) => Alternative (WriterC w m) where+    empty = mzero+    (<|>) = mplus++instance Monad m => Monad (WriterC w m) where+    return a = WriterC $ \w -> return (a, w)+    m >>= k = WriterC $ \w -> do+        (a, w') <- _runWriterC m w+        _runWriterC (k a) w'++instance MonadPlus m => MonadPlus (WriterC w m) where+    mzero = WriterC $ const mzero+    m `mplus` n = WriterC $ \w -> _runWriterC m w `mplus` _runWriterC n w++instance MonadFix m => MonadFix (WriterC w m) where+    mfix f = WriterC $ \w -> mfix $ \(a, _) -> _runWriterC (f a) w++instance (Monoid w, MonadReader r m) => MonadReader r (WriterC w m) where+    ask = lift ask+    local f m = WriterC $ \w -> local f $ _runWriterC m w+    reader = lift . reader++instance (Monoid w, MonadIO m) => MonadWriter w (WriterC w m) where+    writer (a, w) = WriterC $ \tw -> do+        liftIO . atomically $ modifyTVar' tw (<> w)+        return (a, tw)+    listen m = WriterC $ \tw -> do+        (a, tw') <- _runWriterC m tw+        w <- liftIO $ readTVarIO tw'+        return ((a, w), tw')+    pass m = WriterC $ \tw -> do+        ((a, f), tw') <- _runWriterC m tw+        liftIO . atomically $ modifyTVar' tw' f+        return (a, tw')++instance (MonadIO m, MonadCatch m) => MonadCatch (WriterC w m) where+    throwM = liftIO . throwIO+    catch = liftCatch catch+    mask a = WriterC $ \w -> mask $ \u -> _runWriterC (a $ q u) w where+        q u (WriterC f) = WriterC (u . f)+    uninterruptibleMask a =+        WriterC $ \w -> uninterruptibleMask $ \u -> _runWriterC (a $ q u) w where+        q u (WriterC f) = WriterC (u . f)++instance (Monoid w, MonadFork m) => MonadFork (WriterC w m) where+    fork = liftFork fork+    forkOn i = liftFork (forkOn i)+    forkOS = liftFork forkOS++liftFork :: Monad m => (m () -> m a) -> WriterC w m () -> WriterC w m a+liftFork f (WriterC m) = WriterC $ \w -> do+    tid <- f . voidM $ m w+    return (tid, w)+    where voidM = (>> return ())++-- | Unwrap a concurrent Writer monad computation as a function.+runWriterC :: MonadIO m+           => WriterC w m a -- ^ computation to execute+           -> TVar w -- ^ output channel+           -> m (a, w) -- ^ return value and collected output+runWriterC m tw = do+    (a, w) <- _runWriterC m tw+    w' <- liftIO $ readTVarIO w+    return (a, w')++-- | Unwrap a concurrent Writer monad computation as a function, discarding+-- the return value.+--+-- * @'execWriterC' m w = 'liftM' 'snd' ('runWriterC' m w)@+execWriterC :: MonadIO m+            => WriterC w m a -- ^ computation to execute+            -> TVar w -- ^ output channel+            -> m w -- ^ collected output+execWriterC m tw = liftM snd $ runWriterC m tw++-- | Map both the return value and output of a computation using the given+-- function.+mapWriterC :: (m (a, TVar w) -> n (b, TVar w)) -> WriterC w m a -> WriterC w n b+mapWriterC f m = WriterC $ \w -> f (_runWriterC m w)++-- | Lift a @callCC@ operation to the new monad.+liftCallCC :: ((((a, TVar w) -> m (b, TVar w)) -> m (a, TVar w)) -> m (a, TVar w)) -> ((a -> WriterC w m b) -> WriterC w m a) -> WriterC w m a+liftCallCC callCC f = WriterC $ \w ->+    callCC $ \c ->+        _runWriterC (f (\a -> WriterC $ \_ -> c (a, w))) w++-- | Lift a @catchError@ operation to the new monad.+liftCatch :: (m (a, TVar w) -> (e -> m (a, TVar w)) -> m (a, TVar w)) -> WriterC w m a -> (e -> WriterC w m a) -> WriterC w m a+liftCatch catchError m h =+    WriterC $ \w -> _runWriterC m w `catchError` \e -> _runWriterC (h e) w++-- | Run multiple Writer operations on the same value, returning the+-- resultant output and the value produced by each operation.+runWritersC :: (MonadFork m, Monoid w)+            => [WriterC w m a] -- ^ writer computations to execute+            -> m ([a], w) -- ^ return values and output+runWritersC ms = do+    output <- liftIO $ newTVarIO mempty+    mvs <- mapM (const (liftIO newEmptyMVar)) ms+    forM_ (zip mvs ms) $ \(mv, operation) -> fork $ do+        (res, _) <- runWriterC operation output+        liftIO $ putMVar mv res+    items <- forM mvs (liftIO . takeMVar)+    out <- liftIO $ readTVarIO output+    return (items, out)++-- | Run multiple Writer operations on the same value, returning the+-- resultant output.+execWritersC :: (MonadFork m, Monoid w)+             => [WriterC w m a] -- ^ writer computations to execute+             -> m w -- ^ output+execWritersC = liftM snd . runWritersC