{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
module Control.Monad.Schedule.Class where
import Control.Arrow
import Control.Concurrent
import Control.Monad (void)
import Control.Monad.IO.Class
import Data.Either
import Data.Foldable (fold, forM_)
import Data.Function
import Data.Functor.Identity
import Data.Kind (Type)
import Data.List.NonEmpty hiding (length)
import qualified Data.List.NonEmpty as NonEmpty
import Data.Maybe (fromJust)
import Data.Void
import Unsafe.Coerce (unsafeCoerce)
import Prelude hiding (map, zip)
import Control.Monad.Trans.Accum
import Control.Monad.Trans.Class
import Control.Monad.Trans.Cont
import Control.Monad.Trans.Except
import Control.Monad.Trans.Identity
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Reader
import qualified Control.Monad.Trans.Writer.CPS as CPSWriter
import qualified Control.Monad.Trans.Writer.Lazy as LazyWriter
import qualified Control.Monad.Trans.Writer.Strict as StrictWriter
class MonadSchedule m where
schedule :: NonEmpty (m a) -> m (NonEmpty a, [m a])
scheduleAndFinish :: (Monad m, MonadSchedule m) => NonEmpty (m a) -> m (NonEmpty a)
scheduleAndFinish :: forall (m :: * -> *) a.
(Monad m, MonadSchedule m) =>
NonEmpty (m a) -> m (NonEmpty a)
scheduleAndFinish NonEmpty (m a)
actions = do
(NonEmpty a
finishedFirst, [m a]
running) <- NonEmpty (m a) -> m (NonEmpty a, [m a])
forall a. NonEmpty (m a) -> m (NonEmpty a, [m a])
forall (m :: * -> *) a.
MonadSchedule m =>
NonEmpty (m a) -> m (NonEmpty a, [m a])
schedule NonEmpty (m a)
actions
case [m a]
running of
[] -> NonEmpty a -> m (NonEmpty a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return NonEmpty a
finishedFirst
(m a
a : [m a]
as) -> do
NonEmpty a
finishedLater <- NonEmpty (m a) -> m (NonEmpty a)
forall (m :: * -> *) a.
(Monad m, MonadSchedule m) =>
NonEmpty (m a) -> m (NonEmpty a)
scheduleAndFinish (NonEmpty (m a) -> m (NonEmpty a))
-> NonEmpty (m a) -> m (NonEmpty a)
forall a b. (a -> b) -> a -> b
$ m a
a m a -> [m a] -> NonEmpty (m a)
forall a. a -> [a] -> NonEmpty a
:| [m a]
as
return $ NonEmpty a
finishedFirst NonEmpty a -> NonEmpty a -> NonEmpty a
forall a. Semigroup a => a -> a -> a
<> NonEmpty a
finishedLater
sequenceScheduling :: (Monad m, MonadSchedule m) => NonEmpty (m a) -> m (NonEmpty a)
sequenceScheduling :: forall (m :: * -> *) a.
(Monad m, MonadSchedule m) =>
NonEmpty (m a) -> m (NonEmpty a)
sequenceScheduling =
NonEmpty Integer -> NonEmpty (m a) -> NonEmpty (Integer, m a)
forall a b. NonEmpty a -> NonEmpty b -> NonEmpty (a, b)
zip [Integer
Item (NonEmpty Integer)
1 ..]
(NonEmpty (m a) -> NonEmpty (Integer, m a))
-> (NonEmpty (Integer, m a) -> m (NonEmpty a))
-> NonEmpty (m a)
-> m (NonEmpty a)
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ((Integer, m a) -> m (Integer, a))
-> NonEmpty (Integer, m a) -> NonEmpty (m (Integer, a))
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
map (Integer, m a) -> m (Integer, a)
forall (m :: * -> *) a b. Functor m => (a, m b) -> m (a, b)
strength
(NonEmpty (Integer, m a) -> NonEmpty (m (Integer, a)))
-> (NonEmpty (m (Integer, a)) -> m (NonEmpty a))
-> NonEmpty (Integer, m a)
-> m (NonEmpty a)
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> NonEmpty (m (Integer, a)) -> m (NonEmpty (Integer, a))
forall (m :: * -> *) a.
(Monad m, MonadSchedule m) =>
NonEmpty (m a) -> m (NonEmpty a)
scheduleAndFinish
(NonEmpty (m (Integer, a)) -> m (NonEmpty (Integer, a)))
-> (m (NonEmpty (Integer, a)) -> m (NonEmpty a))
-> NonEmpty (m (Integer, a))
-> m (NonEmpty a)
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (NonEmpty (Integer, a) -> NonEmpty a)
-> m (NonEmpty (Integer, a)) -> m (NonEmpty a)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((Integer, a) -> Integer)
-> NonEmpty (Integer, a) -> NonEmpty (Integer, a)
forall o a. Ord o => (a -> o) -> NonEmpty a -> NonEmpty a
sortWith (Integer, a) -> Integer
forall a b. (a, b) -> a
fst (NonEmpty (Integer, a) -> NonEmpty (Integer, a))
-> (NonEmpty (Integer, a) -> NonEmpty a)
-> NonEmpty (Integer, a)
-> NonEmpty a
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ((Integer, a) -> a) -> NonEmpty (Integer, a) -> NonEmpty a
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
map (Integer, a) -> a
forall a b. (a, b) -> b
snd)
where
strength :: (Functor m) => (a, m b) -> m (a, b)
strength :: forall (m :: * -> *) a b. Functor m => (a, m b) -> m (a, b)
strength (a
a, m b
mb) = (a
a,) (b -> (a, b)) -> m b -> m (a, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m b
mb
instance MonadSchedule Identity where
schedule :: forall a.
NonEmpty (Identity a) -> Identity (NonEmpty a, [Identity a])
schedule NonEmpty (Identity a)
as = (,[]) (NonEmpty a -> (NonEmpty a, [Identity a]))
-> Identity (NonEmpty a) -> Identity (NonEmpty a, [Identity a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (Identity a) -> Identity (NonEmpty a)
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => NonEmpty (m a) -> m (NonEmpty a)
sequence NonEmpty (Identity a)
as
instance MonadSchedule IO where
schedule :: forall a. NonEmpty (IO a) -> IO (NonEmpty a, [IO a])
schedule NonEmpty (IO a)
as = do
MVar a
var <- IO (MVar a)
forall a. IO (MVar a)
newEmptyMVar
NonEmpty (IO a) -> (IO a -> IO ThreadId) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ NonEmpty (IO a)
as ((IO a -> IO ThreadId) -> IO ()) -> (IO a -> IO ThreadId) -> IO ()
forall a b. (a -> b) -> a -> b
$ \IO a
action -> IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ MVar a -> a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar a
var (a -> IO ()) -> IO a -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO a
action
a
a <- MVar a -> IO a
forall a. MVar a -> IO a
takeMVar MVar a
var
[a]
as' <- MVar a -> IO [a]
forall a. MVar a -> IO [a]
drain MVar a
var
let remaining :: [IO a]
remaining = Int -> IO a -> [IO a]
forall a. Int -> a -> [a]
replicate (NonEmpty (IO a) -> Int
forall a. NonEmpty a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length NonEmpty (IO a)
as Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
as') (IO a -> [IO a]) -> IO a -> [IO a]
forall a b. (a -> b) -> a -> b
$ MVar a -> IO a
forall a. MVar a -> IO a
takeMVar MVar a
var
return (a
a a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| [a]
as', [IO a]
remaining)
where
drain :: MVar a -> IO [a]
drain :: forall a. MVar a -> IO [a]
drain MVar a
var = do
Maybe a
aMaybe <- MVar a -> IO (Maybe a)
forall a. MVar a -> IO (Maybe a)
tryTakeMVar MVar a
var
case Maybe a
aMaybe of
Just a
a -> do
[a]
as' <- MVar a -> IO [a]
forall a. MVar a -> IO [a]
drain MVar a
var
return $ a
a a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
as'
Maybe a
Nothing -> [a] -> IO [a]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
instance (Functor m, MonadSchedule m) => MonadSchedule (IdentityT m) where
schedule :: forall a.
NonEmpty (IdentityT m a)
-> IdentityT m (NonEmpty a, [IdentityT m a])
schedule =
(IdentityT m a -> m a)
-> NonEmpty (IdentityT m a) -> NonEmpty (m a)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap IdentityT m a -> m a
forall {k} (f :: k -> *) (a :: k). IdentityT f a -> f a
runIdentityT
(NonEmpty (IdentityT m a) -> NonEmpty (m a))
-> (NonEmpty (m a) -> IdentityT m (NonEmpty a, [IdentityT m a]))
-> NonEmpty (IdentityT m a)
-> IdentityT m (NonEmpty a, [IdentityT m a])
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> NonEmpty (m a) -> m (NonEmpty a, [m a])
forall a. NonEmpty (m a) -> m (NonEmpty a, [m a])
forall (m :: * -> *) a.
MonadSchedule m =>
NonEmpty (m a) -> m (NonEmpty a, [m a])
schedule
(NonEmpty (m a) -> m (NonEmpty a, [m a]))
-> (m (NonEmpty a, [m a])
-> IdentityT m (NonEmpty a, [IdentityT m a]))
-> NonEmpty (m a)
-> IdentityT m (NonEmpty a, [IdentityT m a])
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ((NonEmpty a, [m a]) -> (NonEmpty a, [IdentityT m a]))
-> m (NonEmpty a, [m a]) -> m (NonEmpty a, [IdentityT m a])
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([m a] -> [IdentityT m a])
-> (NonEmpty a, [m a]) -> (NonEmpty a, [IdentityT m a])
forall a b. (a -> b) -> (NonEmpty a, a) -> (NonEmpty a, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((m a -> IdentityT m a) -> [m a] -> [IdentityT m a]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap m a -> IdentityT m a
forall {k} (f :: k -> *) (a :: k). f a -> IdentityT f a
IdentityT))
(m (NonEmpty a, [m a]) -> m (NonEmpty a, [IdentityT m a]))
-> (m (NonEmpty a, [IdentityT m a])
-> IdentityT m (NonEmpty a, [IdentityT m a]))
-> m (NonEmpty a, [m a])
-> IdentityT m (NonEmpty a, [IdentityT m a])
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> m (NonEmpty a, [IdentityT m a])
-> IdentityT m (NonEmpty a, [IdentityT m a])
forall {k} (f :: k -> *) (a :: k). f a -> IdentityT f a
IdentityT
instance (Monoid w, Functor m, MonadSchedule m) => MonadSchedule (LazyWriter.WriterT w m) where
schedule :: forall a.
NonEmpty (WriterT w m a)
-> WriterT w m (NonEmpty a, [WriterT w m a])
schedule =
(WriterT w m a -> m (a, w))
-> NonEmpty (WriterT w m a) -> NonEmpty (m (a, w))
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap WriterT w m a -> m (a, w)
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
LazyWriter.runWriterT
(NonEmpty (WriterT w m a) -> NonEmpty (m (a, w)))
-> (NonEmpty (m (a, w))
-> WriterT w m (NonEmpty a, [WriterT w m a]))
-> NonEmpty (WriterT w m a)
-> WriterT w m (NonEmpty a, [WriterT w m a])
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> NonEmpty (m (a, w)) -> m (NonEmpty (a, w), [m (a, w)])
forall a. NonEmpty (m a) -> m (NonEmpty a, [m a])
forall (m :: * -> *) a.
MonadSchedule m =>
NonEmpty (m a) -> m (NonEmpty a, [m a])
schedule
(NonEmpty (m (a, w)) -> m (NonEmpty (a, w), [m (a, w)]))
-> (m (NonEmpty (a, w), [m (a, w)])
-> WriterT w m (NonEmpty a, [WriterT w m a]))
-> NonEmpty (m (a, w))
-> WriterT w m (NonEmpty a, [WriterT w m a])
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ((NonEmpty (a, w), [m (a, w)])
-> ((NonEmpty a, [WriterT w m a]), w))
-> m (NonEmpty (a, w), [m (a, w)])
-> m ((NonEmpty a, [WriterT w m a]), w)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((NonEmpty (a, w) -> (NonEmpty a, w))
-> (NonEmpty (a, w), [m (a, w)]) -> ((NonEmpty a, w), [m (a, w)])
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (((a, w) -> a) -> NonEmpty (a, w) -> NonEmpty a
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, w) -> a
forall a b. (a, b) -> a
fst (NonEmpty (a, w) -> NonEmpty a)
-> (NonEmpty (a, w) -> w) -> NonEmpty (a, w) -> (NonEmpty a, w)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& (((a, w) -> w) -> NonEmpty (a, w) -> NonEmpty w
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, w) -> w
forall a b. (a, b) -> b
snd (NonEmpty (a, w) -> NonEmpty w)
-> (NonEmpty w -> w) -> NonEmpty (a, w) -> w
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> NonEmpty w -> w
forall m. Monoid m => NonEmpty m -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold)) ((NonEmpty (a, w), [m (a, w)]) -> ((NonEmpty a, w), [m (a, w)]))
-> (((NonEmpty a, w), [m (a, w)])
-> ((NonEmpty a, [WriterT w m a]), w))
-> (NonEmpty (a, w), [m (a, w)])
-> ((NonEmpty a, [WriterT w m a]), w)
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ((NonEmpty a, w), [m (a, w)]) -> ((NonEmpty a, [m (a, w)]), w)
forall a c. ((a, w), c) -> ((a, c), w)
assoc (((NonEmpty a, w), [m (a, w)]) -> ((NonEmpty a, [m (a, w)]), w))
-> (((NonEmpty a, [m (a, w)]), w)
-> ((NonEmpty a, [WriterT w m a]), w))
-> ((NonEmpty a, w), [m (a, w)])
-> ((NonEmpty a, [WriterT w m a]), w)
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ((NonEmpty a, [m (a, w)]) -> (NonEmpty a, [WriterT w m a]))
-> ((NonEmpty a, [m (a, w)]), w)
-> ((NonEmpty a, [WriterT w m a]), w)
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (([m (a, w)] -> [WriterT w m a])
-> (NonEmpty a, [m (a, w)]) -> (NonEmpty a, [WriterT w m a])
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (([m (a, w)] -> [WriterT w m a])
-> (NonEmpty a, [m (a, w)]) -> (NonEmpty a, [WriterT w m a]))
-> ([m (a, w)] -> [WriterT w m a])
-> (NonEmpty a, [m (a, w)])
-> (NonEmpty a, [WriterT w m a])
forall a b. (a -> b) -> a -> b
$ (m (a, w) -> WriterT w m a) -> [m (a, w)] -> [WriterT w m a]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap m (a, w) -> WriterT w m a
forall w (m :: * -> *) a. m (a, w) -> WriterT w m a
LazyWriter.WriterT))
(m (NonEmpty (a, w), [m (a, w)])
-> m ((NonEmpty a, [WriterT w m a]), w))
-> (m ((NonEmpty a, [WriterT w m a]), w)
-> WriterT w m (NonEmpty a, [WriterT w m a]))
-> m (NonEmpty (a, w), [m (a, w)])
-> WriterT w m (NonEmpty a, [WriterT w m a])
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> m ((NonEmpty a, [WriterT w m a]), w)
-> WriterT w m (NonEmpty a, [WriterT w m a])
forall w (m :: * -> *) a. m (a, w) -> WriterT w m a
LazyWriter.WriterT
where
assoc :: ((a, w), c) -> ((a, c), w)
assoc :: forall a c. ((a, w), c) -> ((a, c), w)
assoc ((a
a, w
w), c
c) = ((a
a, c
c), w
w)
instance (Monoid w, Functor m, MonadSchedule m) => MonadSchedule (StrictWriter.WriterT w m) where
schedule :: forall a.
NonEmpty (WriterT w m a)
-> WriterT w m (NonEmpty a, [WriterT w m a])
schedule =
(WriterT w m a -> m (a, w))
-> NonEmpty (WriterT w m a) -> NonEmpty (m (a, w))
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap WriterT w m a -> m (a, w)
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
StrictWriter.runWriterT
(NonEmpty (WriterT w m a) -> NonEmpty (m (a, w)))
-> (NonEmpty (m (a, w))
-> WriterT w m (NonEmpty a, [WriterT w m a]))
-> NonEmpty (WriterT w m a)
-> WriterT w m (NonEmpty a, [WriterT w m a])
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> NonEmpty (m (a, w)) -> m (NonEmpty (a, w), [m (a, w)])
forall a. NonEmpty (m a) -> m (NonEmpty a, [m a])
forall (m :: * -> *) a.
MonadSchedule m =>
NonEmpty (m a) -> m (NonEmpty a, [m a])
schedule
(NonEmpty (m (a, w)) -> m (NonEmpty (a, w), [m (a, w)]))
-> (m (NonEmpty (a, w), [m (a, w)])
-> WriterT w m (NonEmpty a, [WriterT w m a]))
-> NonEmpty (m (a, w))
-> WriterT w m (NonEmpty a, [WriterT w m a])
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ((NonEmpty (a, w), [m (a, w)])
-> ((NonEmpty a, [WriterT w m a]), w))
-> m (NonEmpty (a, w), [m (a, w)])
-> m ((NonEmpty a, [WriterT w m a]), w)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((NonEmpty (a, w) -> (NonEmpty a, w))
-> (NonEmpty (a, w), [m (a, w)]) -> ((NonEmpty a, w), [m (a, w)])
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (((a, w) -> a) -> NonEmpty (a, w) -> NonEmpty a
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, w) -> a
forall a b. (a, b) -> a
fst (NonEmpty (a, w) -> NonEmpty a)
-> (NonEmpty (a, w) -> w) -> NonEmpty (a, w) -> (NonEmpty a, w)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& (((a, w) -> w) -> NonEmpty (a, w) -> NonEmpty w
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, w) -> w
forall a b. (a, b) -> b
snd (NonEmpty (a, w) -> NonEmpty w)
-> (NonEmpty w -> w) -> NonEmpty (a, w) -> w
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> NonEmpty w -> w
forall m. Monoid m => NonEmpty m -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold)) ((NonEmpty (a, w), [m (a, w)]) -> ((NonEmpty a, w), [m (a, w)]))
-> (((NonEmpty a, w), [m (a, w)])
-> ((NonEmpty a, [WriterT w m a]), w))
-> (NonEmpty (a, w), [m (a, w)])
-> ((NonEmpty a, [WriterT w m a]), w)
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ((NonEmpty a, w), [m (a, w)]) -> ((NonEmpty a, [m (a, w)]), w)
forall a c. ((a, w), c) -> ((a, c), w)
assoc (((NonEmpty a, w), [m (a, w)]) -> ((NonEmpty a, [m (a, w)]), w))
-> (((NonEmpty a, [m (a, w)]), w)
-> ((NonEmpty a, [WriterT w m a]), w))
-> ((NonEmpty a, w), [m (a, w)])
-> ((NonEmpty a, [WriterT w m a]), w)
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ((NonEmpty a, [m (a, w)]) -> (NonEmpty a, [WriterT w m a]))
-> ((NonEmpty a, [m (a, w)]), w)
-> ((NonEmpty a, [WriterT w m a]), w)
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (([m (a, w)] -> [WriterT w m a])
-> (NonEmpty a, [m (a, w)]) -> (NonEmpty a, [WriterT w m a])
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (([m (a, w)] -> [WriterT w m a])
-> (NonEmpty a, [m (a, w)]) -> (NonEmpty a, [WriterT w m a]))
-> ([m (a, w)] -> [WriterT w m a])
-> (NonEmpty a, [m (a, w)])
-> (NonEmpty a, [WriterT w m a])
forall a b. (a -> b) -> a -> b
$ (m (a, w) -> WriterT w m a) -> [m (a, w)] -> [WriterT w m a]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap m (a, w) -> WriterT w m a
forall w (m :: * -> *) a. m (a, w) -> WriterT w m a
StrictWriter.WriterT))
(m (NonEmpty (a, w), [m (a, w)])
-> m ((NonEmpty a, [WriterT w m a]), w))
-> (m ((NonEmpty a, [WriterT w m a]), w)
-> WriterT w m (NonEmpty a, [WriterT w m a]))
-> m (NonEmpty (a, w), [m (a, w)])
-> WriterT w m (NonEmpty a, [WriterT w m a])
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> m ((NonEmpty a, [WriterT w m a]), w)
-> WriterT w m (NonEmpty a, [WriterT w m a])
forall w (m :: * -> *) a. m (a, w) -> WriterT w m a
StrictWriter.WriterT
where
assoc :: ((a, w), c) -> ((a, c), w)
assoc :: forall a c. ((a, w), c) -> ((a, c), w)
assoc ((a
a, w
w), c
c) = ((a
a, c
c), w
w)
instance (Monoid w, Functor m, MonadSchedule m) => MonadSchedule (CPSWriter.WriterT w m) where
schedule :: forall a.
NonEmpty (WriterT w m a)
-> WriterT w m (NonEmpty a, [WriterT w m a])
schedule =
(WriterT w m a -> m (a, w))
-> NonEmpty (WriterT w m a) -> NonEmpty (m (a, w))
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap WriterT w m a -> m (a, w)
forall w (m :: * -> *) a. Monoid w => WriterT w m a -> m (a, w)
CPSWriter.runWriterT
(NonEmpty (WriterT w m a) -> NonEmpty (m (a, w)))
-> (NonEmpty (m (a, w))
-> WriterT w m (NonEmpty a, [WriterT w m a]))
-> NonEmpty (WriterT w m a)
-> WriterT w m (NonEmpty a, [WriterT w m a])
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> NonEmpty (m (a, w)) -> m (NonEmpty (a, w), [m (a, w)])
forall a. NonEmpty (m a) -> m (NonEmpty a, [m a])
forall (m :: * -> *) a.
MonadSchedule m =>
NonEmpty (m a) -> m (NonEmpty a, [m a])
schedule
(NonEmpty (m (a, w)) -> m (NonEmpty (a, w), [m (a, w)]))
-> (m (NonEmpty (a, w), [m (a, w)])
-> WriterT w m (NonEmpty a, [WriterT w m a]))
-> NonEmpty (m (a, w))
-> WriterT w m (NonEmpty a, [WriterT w m a])
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ((NonEmpty (a, w), [m (a, w)])
-> ((NonEmpty a, [WriterT w m a]), w))
-> m (NonEmpty (a, w), [m (a, w)])
-> m ((NonEmpty a, [WriterT w m a]), w)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((NonEmpty (a, w) -> (NonEmpty a, w))
-> (NonEmpty (a, w), [m (a, w)]) -> ((NonEmpty a, w), [m (a, w)])
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (((a, w) -> a) -> NonEmpty (a, w) -> NonEmpty a
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, w) -> a
forall a b. (a, b) -> a
fst (NonEmpty (a, w) -> NonEmpty a)
-> (NonEmpty (a, w) -> w) -> NonEmpty (a, w) -> (NonEmpty a, w)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& (((a, w) -> w) -> NonEmpty (a, w) -> NonEmpty w
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, w) -> w
forall a b. (a, b) -> b
snd (NonEmpty (a, w) -> NonEmpty w)
-> (NonEmpty w -> w) -> NonEmpty (a, w) -> w
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> NonEmpty w -> w
forall m. Monoid m => NonEmpty m -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold)) ((NonEmpty (a, w), [m (a, w)]) -> ((NonEmpty a, w), [m (a, w)]))
-> (((NonEmpty a, w), [m (a, w)])
-> ((NonEmpty a, [WriterT w m a]), w))
-> (NonEmpty (a, w), [m (a, w)])
-> ((NonEmpty a, [WriterT w m a]), w)
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ((NonEmpty a, w), [m (a, w)]) -> ((NonEmpty a, [m (a, w)]), w)
forall a c. ((a, w), c) -> ((a, c), w)
assoc (((NonEmpty a, w), [m (a, w)]) -> ((NonEmpty a, [m (a, w)]), w))
-> (((NonEmpty a, [m (a, w)]), w)
-> ((NonEmpty a, [WriterT w m a]), w))
-> ((NonEmpty a, w), [m (a, w)])
-> ((NonEmpty a, [WriterT w m a]), w)
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ((NonEmpty a, [m (a, w)]) -> (NonEmpty a, [WriterT w m a]))
-> ((NonEmpty a, [m (a, w)]), w)
-> ((NonEmpty a, [WriterT w m a]), w)
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (([m (a, w)] -> [WriterT w m a])
-> (NonEmpty a, [m (a, w)]) -> (NonEmpty a, [WriterT w m a])
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (([m (a, w)] -> [WriterT w m a])
-> (NonEmpty a, [m (a, w)]) -> (NonEmpty a, [WriterT w m a]))
-> ([m (a, w)] -> [WriterT w m a])
-> (NonEmpty a, [m (a, w)])
-> (NonEmpty a, [WriterT w m a])
forall a b. (a -> b) -> a -> b
$ (m (a, w) -> WriterT w m a) -> [m (a, w)] -> [WriterT w m a]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap m (a, w) -> WriterT w m a
forall (m :: * -> *) w a.
(Functor m, Monoid w) =>
m (a, w) -> WriterT w m a
CPSWriter.writerT))
(m (NonEmpty (a, w), [m (a, w)])
-> m ((NonEmpty a, [WriterT w m a]), w))
-> (m ((NonEmpty a, [WriterT w m a]), w)
-> WriterT w m (NonEmpty a, [WriterT w m a]))
-> m (NonEmpty (a, w), [m (a, w)])
-> WriterT w m (NonEmpty a, [WriterT w m a])
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> m ((NonEmpty a, [WriterT w m a]), w)
-> WriterT w m (NonEmpty a, [WriterT w m a])
forall (m :: * -> *) w a.
(Functor m, Monoid w) =>
m (a, w) -> WriterT w m a
CPSWriter.writerT
where
assoc :: ((a, w), c) -> ((a, c), w)
assoc :: forall a c. ((a, w), c) -> ((a, c), w)
assoc ((a
a, w
w), c
c) = ((a
a, c
c), w
w)
instance (Monad m, MonadSchedule m) => MonadSchedule (ReaderT r m) where
schedule :: forall a.
NonEmpty (ReaderT r m a)
-> ReaderT r m (NonEmpty a, [ReaderT r m a])
schedule NonEmpty (ReaderT r m a)
actions = (r -> m (NonEmpty a, [ReaderT r m a]))
-> ReaderT r m (NonEmpty a, [ReaderT r m a])
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((r -> m (NonEmpty a, [ReaderT r m a]))
-> ReaderT r m (NonEmpty a, [ReaderT r m a]))
-> (r -> m (NonEmpty a, [ReaderT r m a]))
-> ReaderT r m (NonEmpty a, [ReaderT r m a])
forall a b. (a -> b) -> a -> b
$ \r
r ->
(ReaderT r m a -> m a)
-> NonEmpty (ReaderT r m a) -> NonEmpty (m a)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ReaderT r m a -> r -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
`runReaderT` r
r) NonEmpty (ReaderT r m a)
actions
NonEmpty (m a)
-> (NonEmpty (m a) -> m (NonEmpty a, [m a]))
-> m (NonEmpty a, [m a])
forall a b. a -> (a -> b) -> b
& NonEmpty (m a) -> m (NonEmpty a, [m a])
forall a. NonEmpty (m a) -> m (NonEmpty a, [m a])
forall (m :: * -> *) a.
MonadSchedule m =>
NonEmpty (m a) -> m (NonEmpty a, [m a])
schedule
m (NonEmpty a, [m a])
-> (m (NonEmpty a, [m a]) -> m (NonEmpty a, [ReaderT r m a]))
-> m (NonEmpty a, [ReaderT r m a])
forall a b. a -> (a -> b) -> b
& ((NonEmpty a, [m a]) -> (NonEmpty a, [ReaderT r m a]))
-> m (NonEmpty a, [m a]) -> m (NonEmpty a, [ReaderT r m a])
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([m a] -> [ReaderT r m a])
-> (NonEmpty a, [m a]) -> (NonEmpty a, [ReaderT r m a])
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (([m a] -> [ReaderT r m a])
-> (NonEmpty a, [m a]) -> (NonEmpty a, [ReaderT r m a]))
-> ([m a] -> [ReaderT r m a])
-> (NonEmpty a, [m a])
-> (NonEmpty a, [ReaderT r m a])
forall a b. (a -> b) -> a -> b
$ (m a -> ReaderT r m a) -> [m a] -> [ReaderT r m a]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap m a -> ReaderT r m a
forall (m :: * -> *) a. Monad m => m a -> ReaderT r m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift)
instance (Monoid w, Monad m, MonadSchedule m) => MonadSchedule (AccumT w m) where
schedule :: forall a.
NonEmpty (AccumT w m a) -> AccumT w m (NonEmpty a, [AccumT w m a])
schedule NonEmpty (AccumT w m a)
actions = (w -> m ((NonEmpty a, [AccumT w m a]), w))
-> AccumT w m (NonEmpty a, [AccumT w m a])
forall w (m :: * -> *) a. (w -> m (a, w)) -> AccumT w m a
AccumT ((w -> m ((NonEmpty a, [AccumT w m a]), w))
-> AccumT w m (NonEmpty a, [AccumT w m a]))
-> (w -> m ((NonEmpty a, [AccumT w m a]), w))
-> AccumT w m (NonEmpty a, [AccumT w m a])
forall a b. (a -> b) -> a -> b
$ \w
w ->
(AccumT w m a -> m (a, w))
-> NonEmpty (AccumT w m a) -> NonEmpty (m (a, w))
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (AccumT w m a -> w -> m (a, w)
forall w (m :: * -> *) a. AccumT w m a -> w -> m (a, w)
`runAccumT` w
w) NonEmpty (AccumT w m a)
actions
NonEmpty (m (a, w))
-> (NonEmpty (m (a, w)) -> m (NonEmpty (a, w), [m (a, w)]))
-> m (NonEmpty (a, w), [m (a, w)])
forall a b. a -> (a -> b) -> b
& NonEmpty (m (a, w)) -> m (NonEmpty (a, w), [m (a, w)])
forall a. NonEmpty (m a) -> m (NonEmpty a, [m a])
forall (m :: * -> *) a.
MonadSchedule m =>
NonEmpty (m a) -> m (NonEmpty a, [m a])
schedule
m (NonEmpty (a, w), [m (a, w)])
-> (m (NonEmpty (a, w), [m (a, w)])
-> m ((NonEmpty a, [AccumT w m a]), w))
-> m ((NonEmpty a, [AccumT w m a]), w)
forall a b. a -> (a -> b) -> b
& ((NonEmpty (a, w), [m (a, w)])
-> ((NonEmpty a, [AccumT w m a]), w))
-> m (NonEmpty (a, w), [m (a, w)])
-> m ((NonEmpty a, [AccumT w m a]), w)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (NonEmpty (a, w), [m (a, w)]) -> ((NonEmpty a, [AccumT w m a]), w)
forall a.
Monoid w =>
(NonEmpty (a, w), [m (a, w)]) -> ((NonEmpty a, [AccumT w m a]), w)
collectWritesAndWrap
where
collectWritesAndWrap ::
(Monoid w) =>
(NonEmpty (a, w), [m (a, w)]) ->
((NonEmpty a, [AccumT w m a]), w)
collectWritesAndWrap :: forall a.
Monoid w =>
(NonEmpty (a, w), [m (a, w)]) -> ((NonEmpty a, [AccumT w m a]), w)
collectWritesAndWrap (NonEmpty (a, w)
finished, [m (a, w)]
running) =
let (NonEmpty a
as, NonEmpty w
logs) = NonEmpty (a, w) -> (NonEmpty a, NonEmpty w)
forall (f :: * -> *) a b. Functor f => f (a, b) -> (f a, f b)
NonEmpty.unzip NonEmpty (a, w)
finished
in ((NonEmpty a
as, (w -> m (a, w)) -> AccumT w m a
forall w (m :: * -> *) a. (w -> m (a, w)) -> AccumT w m a
AccumT ((w -> m (a, w)) -> AccumT w m a)
-> (m (a, w) -> w -> m (a, w)) -> m (a, w) -> AccumT w m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (a, w) -> w -> m (a, w)
forall a b. a -> b -> a
const (m (a, w) -> AccumT w m a) -> [m (a, w)] -> [AccumT w m a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [m (a, w)]
running), NonEmpty w -> w
forall m. Monoid m => NonEmpty m -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold NonEmpty w
logs)
instance (Monad m, MonadSchedule m) => MonadSchedule (ExceptT e m) where
schedule :: forall a.
NonEmpty (ExceptT e m a)
-> ExceptT e m (NonEmpty a, [ExceptT e m a])
schedule =
(ExceptT e m a -> m (Either e a))
-> NonEmpty (ExceptT e m a) -> NonEmpty (m (Either e a))
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ExceptT e m a -> m (Either e a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT
(NonEmpty (ExceptT e m a) -> NonEmpty (m (Either e a)))
-> (NonEmpty (m (Either e a))
-> ExceptT e m (NonEmpty a, [ExceptT e m a]))
-> NonEmpty (ExceptT e m a)
-> ExceptT e m (NonEmpty a, [ExceptT e m a])
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> NonEmpty (m (Either e a))
-> m (NonEmpty (Either e a), [m (Either e a)])
forall a. NonEmpty (m a) -> m (NonEmpty a, [m a])
forall (m :: * -> *) a.
MonadSchedule m =>
NonEmpty (m a) -> m (NonEmpty a, [m a])
schedule
(NonEmpty (m (Either e a))
-> m (NonEmpty (Either e a), [m (Either e a)]))
-> (m (NonEmpty (Either e a), [m (Either e a)])
-> ExceptT e m (NonEmpty a, [ExceptT e m a]))
-> NonEmpty (m (Either e a))
-> ExceptT e m (NonEmpty a, [ExceptT e m a])
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ((NonEmpty (Either e a), [m (Either e a)])
-> Either e (NonEmpty a, [ExceptT e m a]))
-> m (NonEmpty (Either e a), [m (Either e a)])
-> m (Either e (NonEmpty a, [ExceptT e m a]))
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (NonEmpty (Either e a) -> Either e (NonEmpty a)
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a.
Applicative f =>
NonEmpty (f a) -> f (NonEmpty a)
sequenceA (NonEmpty (Either e a) -> Either e (NonEmpty a))
-> ([m (Either e a)] -> [ExceptT e m a])
-> (NonEmpty (Either e a), [m (Either e a)])
-> (Either e (NonEmpty a), [ExceptT e m a])
forall b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** (m (Either e a) -> ExceptT e m a)
-> [m (Either e a)] -> [ExceptT e m a]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap m (Either e a) -> ExceptT e m a
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT ((NonEmpty (Either e a), [m (Either e a)])
-> (Either e (NonEmpty a), [ExceptT e m a]))
-> ((Either e (NonEmpty a), [ExceptT e m a])
-> Either e (NonEmpty a, [ExceptT e m a]))
-> (NonEmpty (Either e a), [m (Either e a)])
-> Either e (NonEmpty a, [ExceptT e m a])
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (Either e (NonEmpty a), [ExceptT e m a])
-> Either e (NonEmpty a, [ExceptT e m a])
forall a b. (Either e a, b) -> Either e (a, b)
extrudeEither)
(m (NonEmpty (Either e a), [m (Either e a)])
-> m (Either e (NonEmpty a, [ExceptT e m a])))
-> (m (Either e (NonEmpty a, [ExceptT e m a]))
-> ExceptT e m (NonEmpty a, [ExceptT e m a]))
-> m (NonEmpty (Either e a), [m (Either e a)])
-> ExceptT e m (NonEmpty a, [ExceptT e m a])
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> m (Either e (NonEmpty a, [ExceptT e m a]))
-> ExceptT e m (NonEmpty a, [ExceptT e m a])
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT
where
extrudeEither :: (Either e a, b) -> Either e (a, b)
extrudeEither :: forall a b. (Either e a, b) -> Either e (a, b)
extrudeEither (Either e a
ea, b
b) = (,b
b) (a -> (a, b)) -> Either e a -> Either e (a, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either e a
ea
instance (Monad m, MonadSchedule m) => MonadSchedule (MaybeT m) where
schedule :: forall a.
NonEmpty (MaybeT m a) -> MaybeT m (NonEmpty a, [MaybeT m a])
schedule =
(MaybeT m a -> ExceptT () m a)
-> NonEmpty (MaybeT m a) -> NonEmpty (ExceptT () m a)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (() -> MaybeT m a -> ExceptT () m a
forall (m :: * -> *) e a.
Functor m =>
e -> MaybeT m a -> ExceptT e m a
maybeToExceptT ())
(NonEmpty (MaybeT m a) -> NonEmpty (ExceptT () m a))
-> (NonEmpty (ExceptT () m a)
-> MaybeT m (NonEmpty a, [MaybeT m a]))
-> NonEmpty (MaybeT m a)
-> MaybeT m (NonEmpty a, [MaybeT m a])
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> NonEmpty (ExceptT () m a)
-> ExceptT () m (NonEmpty a, [ExceptT () m a])
forall a.
NonEmpty (ExceptT () m a)
-> ExceptT () m (NonEmpty a, [ExceptT () m a])
forall (m :: * -> *) a.
MonadSchedule m =>
NonEmpty (m a) -> m (NonEmpty a, [m a])
schedule
(NonEmpty (ExceptT () m a)
-> ExceptT () m (NonEmpty a, [ExceptT () m a]))
-> (ExceptT () m (NonEmpty a, [ExceptT () m a])
-> MaybeT m (NonEmpty a, [MaybeT m a]))
-> NonEmpty (ExceptT () m a)
-> MaybeT m (NonEmpty a, [MaybeT m a])
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ExceptT () m (NonEmpty a, [ExceptT () m a])
-> MaybeT m (NonEmpty a, [ExceptT () m a])
forall (m :: * -> *) e a. Functor m => ExceptT e m a -> MaybeT m a
exceptToMaybeT
(ExceptT () m (NonEmpty a, [ExceptT () m a])
-> MaybeT m (NonEmpty a, [ExceptT () m a]))
-> (MaybeT m (NonEmpty a, [ExceptT () m a])
-> MaybeT m (NonEmpty a, [MaybeT m a]))
-> ExceptT () m (NonEmpty a, [ExceptT () m a])
-> MaybeT m (NonEmpty a, [MaybeT m a])
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ((NonEmpty a, [ExceptT () m a]) -> (NonEmpty a, [MaybeT m a]))
-> MaybeT m (NonEmpty a, [ExceptT () m a])
-> MaybeT m (NonEmpty a, [MaybeT m a])
forall a b. (a -> b) -> MaybeT m a -> MaybeT m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([ExceptT () m a] -> [MaybeT m a])
-> (NonEmpty a, [ExceptT () m a]) -> (NonEmpty a, [MaybeT m a])
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (([ExceptT () m a] -> [MaybeT m a])
-> (NonEmpty a, [ExceptT () m a]) -> (NonEmpty a, [MaybeT m a]))
-> ([ExceptT () m a] -> [MaybeT m a])
-> (NonEmpty a, [ExceptT () m a])
-> (NonEmpty a, [MaybeT m a])
forall a b. (a -> b) -> a -> b
$ (ExceptT () m a -> MaybeT m a) -> [ExceptT () m a] -> [MaybeT m a]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ExceptT () m a -> MaybeT m a
forall (m :: * -> *) e a. Functor m => ExceptT e m a -> MaybeT m a
exceptToMaybeT)
race ::
(Monad m, MonadSchedule m) =>
m a ->
m b ->
m (Either (a, m b) (m a, b))
race :: forall (m :: * -> *) a b.
(Monad m, MonadSchedule m) =>
m a -> m b -> m (Either (a, m b) (m a, b))
race m a
aM m b
bM = (NonEmpty (Either a b), [m (Either a b)])
-> Either (a, m b) (m a, b)
forall (m :: * -> *) a b.
Monad m =>
(NonEmpty (Either a b), [m (Either a b)])
-> Either (a, m b) (m a, b)
recoverResult ((NonEmpty (Either a b), [m (Either a b)])
-> Either (a, m b) (m a, b))
-> m (NonEmpty (Either a b), [m (Either a b)])
-> m (Either (a, m b) (m a, b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (m (Either a b))
-> m (NonEmpty (Either a b), [m (Either a b)])
forall a. NonEmpty (m a) -> m (NonEmpty a, [m a])
forall (m :: * -> *) a.
MonadSchedule m =>
NonEmpty (m a) -> m (NonEmpty a, [m a])
schedule ((a -> Either a b
forall a b. a -> Either a b
Left (a -> Either a b) -> m a -> m (Either a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
aM) m (Either a b) -> [m (Either a b)] -> NonEmpty (m (Either a b))
forall a. a -> [a] -> NonEmpty a
:| [b -> Either a b
forall a b. b -> Either a b
Right (b -> Either a b) -> m b -> m (Either a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m b
bM])
where
recoverResult :: (Monad m) => (NonEmpty (Either a b), [m (Either a b)]) -> Either (a, m b) (m a, b)
recoverResult :: forall (m :: * -> *) a b.
Monad m =>
(NonEmpty (Either a b), [m (Either a b)])
-> Either (a, m b) (m a, b)
recoverResult (Left a
a :| [], [Item [m (Either a b)]
bM']) = (a, m b) -> Either (a, m b) (m a, b)
forall a b. a -> Either a b
Left (a
a, b -> Either a b -> b
forall b a. b -> Either a b -> b
fromRight b
forall {a}. a
e (Either a b -> b) -> m (Either a b) -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Either a b)
Item [m (Either a b)]
bM')
recoverResult (Right b
b :| [], [Item [m (Either a b)]
aM']) = (m a, b) -> Either (a, m b) (m a, b)
forall a b. b -> Either a b
Right (a -> Either a b -> a
forall a b. a -> Either a b -> a
fromLeft a
forall {a}. a
e (Either a b -> a) -> m (Either a b) -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Either a b)
Item [m (Either a b)]
aM', b
b)
recoverResult (Left a
a :| [Right b
b], []) = (a, m b) -> Either (a, m b) (m a, b)
forall a b. a -> Either a b
Left (a
a, b -> m b
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return b
b)
recoverResult (Right b
b :| [Left a
a], []) = (m a, b) -> Either (a, m b) (m a, b)
forall a b. b -> Either a b
Right (a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a, b
b)
recoverResult (NonEmpty (Either a b), [m (Either a b)])
_ = Either (a, m b) (m a, b)
forall {a}. a
e
e :: a
e = [Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"race: Internal error"
async ::
(Monad m, MonadSchedule m) =>
m a ->
m b ->
m (a, b)
async :: forall (m :: * -> *) a b.
(Monad m, MonadSchedule m) =>
m a -> m b -> m (a, b)
async m a
aSched m b
bSched = do
Either (a, m b) (m a, b)
ab <- m a -> m b -> m (Either (a, m b) (m a, b))
forall (m :: * -> *) a b.
(Monad m, MonadSchedule m) =>
m a -> m b -> m (Either (a, m b) (m a, b))
race m a
aSched m b
bSched
case Either (a, m b) (m a, b)
ab of
Left (a
a, m b
bCont) -> do
b
b <- m b
bCont
return (a
a, b
b)
Right (m a
aCont, b
b) -> do
a
a <- m a
aCont
return (a
a, b
b)