{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveFunctor #-}

-- | A bit like 'Fence', but not thread safe and optimised for avoiding taking the fence
module General.Wait(
    Wait(Now,Later), runWait, quickly, fromLater,
    firstJustWaitUnordered, firstLeftWaitUnordered
    ) where

import Control.Monad.Extra
import Control.Monad.IO.Class
import Data.IORef.Extra
import Data.List.Extra
import Data.Primitive.Array
import GHC.Exts(RealWorld)
import Control.Monad.Fail
import Prelude


runWait :: Monad m => Wait m a -> m (Wait m a)
runWait :: Wait m a -> m (Wait m a)
runWait (Lift m (Wait m a)
x) = Wait m a -> m (Wait m a)
forall (m :: * -> *) a. Monad m => Wait m a -> m (Wait m a)
runWait (Wait m a -> m (Wait m a)) -> m (Wait m a) -> m (Wait m a)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m (Wait m a)
x
runWait Wait m a
x = Wait m a -> m (Wait m a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Wait m a
x

fromLater :: Monad m => Wait m a -> (a -> m ()) -> m ()
fromLater :: Wait m a -> (a -> m ()) -> m ()
fromLater (Lift m (Wait m a)
x) a -> m ()
f = do Wait m a
x <- m (Wait m a)
x; Wait m a -> (a -> m ()) -> m ()
forall (m :: * -> *) a. Monad m => Wait m a -> (a -> m ()) -> m ()
fromLater Wait m a
x a -> m ()
f
fromLater (Now a
x) a -> m ()
f = a -> m ()
f a
x
fromLater (Later (a -> m ()) -> m ()
x) a -> m ()
f = (a -> m ()) -> m ()
x a -> m ()
f

quickly :: Functor m => m a -> Wait m a
quickly :: m a -> Wait m a
quickly = m (Wait m a) -> Wait m a
forall (m :: * -> *) a. m (Wait m a) -> Wait m a
Lift (m (Wait m a) -> Wait m a)
-> (m a -> m (Wait m a)) -> m a -> Wait m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Wait m a) -> m a -> m (Wait m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Wait m a
forall (m :: * -> *) a. a -> Wait m a
Now

data Wait m a = Now a
              | Lift (m (Wait m a))
              | Later ((a -> m ()) -> m ())
                deriving a -> Wait m b -> Wait m a
(a -> b) -> Wait m a -> Wait m b
(forall a b. (a -> b) -> Wait m a -> Wait m b)
-> (forall a b. a -> Wait m b -> Wait m a) -> Functor (Wait m)
forall a b. a -> Wait m b -> Wait m a
forall a b. (a -> b) -> Wait m a -> Wait m b
forall (m :: * -> *) a b. Functor m => a -> Wait m b -> Wait m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> Wait m a -> Wait m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Wait m b -> Wait m a
$c<$ :: forall (m :: * -> *) a b. Functor m => a -> Wait m b -> Wait m a
fmap :: (a -> b) -> Wait m a -> Wait m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> Wait m a -> Wait m b
Functor

instance (Monad m, Applicative m) => Applicative (Wait m) where
    pure :: a -> Wait m a
pure = a -> Wait m a
forall (m :: * -> *) a. a -> Wait m a
Now
    Now a -> b
x <*> :: Wait m (a -> b) -> Wait m a -> Wait m b
<*> Wait m a
y = a -> b
x (a -> b) -> Wait m a -> Wait m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Wait m a
y
    Lift m (Wait m (a -> b))
x <*> Wait m a
y = m (Wait m b) -> Wait m b
forall (m :: * -> *) a. m (Wait m a) -> Wait m a
Lift (m (Wait m b) -> Wait m b) -> m (Wait m b) -> Wait m b
forall a b. (a -> b) -> a -> b
$ (Wait m (a -> b) -> Wait m a -> Wait m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Wait m a
y) (Wait m (a -> b) -> Wait m b)
-> m (Wait m (a -> b)) -> m (Wait m b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Wait m (a -> b))
x
    Later ((a -> b) -> m ()) -> m ()
x <*> Now a
y = ((b -> m ()) -> m ()) -> Wait m b
forall (m :: * -> *) a. ((a -> m ()) -> m ()) -> Wait m a
Later (((b -> m ()) -> m ()) -> Wait m b)
-> ((b -> m ()) -> m ()) -> Wait m b
forall a b. (a -> b) -> a -> b
$ \b -> m ()
c -> ((a -> b) -> m ()) -> m ()
x (((a -> b) -> m ()) -> m ()) -> ((a -> b) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \a -> b
x -> b -> m ()
c (b -> m ()) -> b -> m ()
forall a b. (a -> b) -> a -> b
$ a -> b
x a
y
    -- Note: We pull the Lift from the right BEFORE the Later, to enable parallelism
    Later ((a -> b) -> m ()) -> m ()
x <*> Lift m (Wait m a)
y = m (Wait m b) -> Wait m b
forall (m :: * -> *) a. m (Wait m a) -> Wait m a
Lift (m (Wait m b) -> Wait m b) -> m (Wait m b) -> Wait m b
forall a b. (a -> b) -> a -> b
$ do Wait m a
y <- m (Wait m a)
y; Wait m b -> m (Wait m b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Wait m b -> m (Wait m b)) -> Wait m b -> m (Wait m b)
forall a b. (a -> b) -> a -> b
$ (((a -> b) -> m ()) -> m ()) -> Wait m (a -> b)
forall (m :: * -> *) a. ((a -> m ()) -> m ()) -> Wait m a
Later ((a -> b) -> m ()) -> m ()
x Wait m (a -> b) -> Wait m a -> Wait m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Wait m a
y
    Later ((a -> b) -> m ()) -> m ()
x <*> Later (a -> m ()) -> m ()
y = ((b -> m ()) -> m ()) -> Wait m b
forall (m :: * -> *) a. ((a -> m ()) -> m ()) -> Wait m a
Later (((b -> m ()) -> m ()) -> Wait m b)
-> ((b -> m ()) -> m ()) -> Wait m b
forall a b. (a -> b) -> a -> b
$ \b -> m ()
c -> ((a -> b) -> m ()) -> m ()
x (((a -> b) -> m ()) -> m ()) -> ((a -> b) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \a -> b
x -> (a -> m ()) -> m ()
y ((a -> m ()) -> m ()) -> (a -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \a
y -> b -> m ()
c (b -> m ()) -> b -> m ()
forall a b. (a -> b) -> a -> b
$ a -> b
x a
y

instance (Monad m, Applicative m) => Monad (Wait m) where
    return :: a -> Wait m a
return = a -> Wait m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    >> :: Wait m a -> Wait m b -> Wait m b
(>>) = Wait m a -> Wait m b -> Wait m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
(*>)
    Now a
x >>= :: Wait m a -> (a -> Wait m b) -> Wait m b
>>= a -> Wait m b
f = a -> Wait m b
f a
x
    Lift m (Wait m a)
x >>= a -> Wait m b
f = m (Wait m b) -> Wait m b
forall (m :: * -> *) a. m (Wait m a) -> Wait m a
Lift (m (Wait m b) -> Wait m b) -> m (Wait m b) -> Wait m b
forall a b. (a -> b) -> a -> b
$ do Wait m a
x <- m (Wait m a)
x; Wait m b -> m (Wait m b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Wait m b -> m (Wait m b)) -> Wait m b -> m (Wait m b)
forall a b. (a -> b) -> a -> b
$ Wait m a
x Wait m a -> (a -> Wait m b) -> Wait m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> Wait m b
f
    Later (a -> m ()) -> m ()
x >>= a -> Wait m b
f = ((b -> m ()) -> m ()) -> Wait m b
forall (m :: * -> *) a. ((a -> m ()) -> m ()) -> Wait m a
Later (((b -> m ()) -> m ()) -> Wait m b)
-> ((b -> m ()) -> m ()) -> Wait m b
forall a b. (a -> b) -> a -> b
$ \b -> m ()
c -> (a -> m ()) -> m ()
x ((a -> m ()) -> m ()) -> (a -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \a
x -> do
        Wait m b
x <- Wait m b -> m (Wait m b)
forall (m :: * -> *) a. Monad m => Wait m a -> m (Wait m a)
runWait (Wait m b -> m (Wait m b)) -> Wait m b -> m (Wait m b)
forall a b. (a -> b) -> a -> b
$ a -> Wait m b
f a
x
        case Wait m b
x of
            Now b
x -> b -> m ()
c b
x
            Wait m b
_ -> Wait m b -> (b -> m ()) -> m ()
forall (m :: * -> *) a. Monad m => Wait m a -> (a -> m ()) -> m ()
fromLater Wait m b
x b -> m ()
c

instance (MonadIO m,  Applicative m) => MonadIO (Wait m) where
    liftIO :: IO a -> Wait m a
liftIO = m (Wait m a) -> Wait m a
forall (m :: * -> *) a. m (Wait m a) -> Wait m a
Lift (m (Wait m a) -> Wait m a)
-> (IO a -> m (Wait m a)) -> IO a -> Wait m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Wait m a) -> m (Wait m a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Wait m a) -> m (Wait m a))
-> (IO a -> IO (Wait m a)) -> IO a -> m (Wait m a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Wait m a) -> IO a -> IO (Wait m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Wait m a
forall (m :: * -> *) a. a -> Wait m a
Now

instance MonadFail m => MonadFail (Wait m) where
    fail :: String -> Wait m a
fail = m (Wait m a) -> Wait m a
forall (m :: * -> *) a. m (Wait m a) -> Wait m a
Lift (m (Wait m a) -> Wait m a)
-> (String -> m (Wait m a)) -> String -> Wait m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> m (Wait m a)
forall (m :: * -> *) a. MonadFail m => String -> m a
Control.Monad.Fail.fail

firstJustWaitUnordered :: MonadIO m => (a -> Wait m (Maybe b)) -> [a] -> Wait m (Maybe b)
firstJustWaitUnordered :: (a -> Wait m (Maybe b)) -> [a] -> Wait m (Maybe b)
firstJustWaitUnordered a -> Wait m (Maybe b)
f = Int
-> [(Maybe b -> m ()) -> m ()]
-> [Wait m (Maybe b)]
-> Wait m (Maybe b)
forall (m :: * -> *) a.
MonadIO m =>
Int
-> [(Maybe a -> m ()) -> m ()]
-> [Wait m (Maybe a)]
-> Wait m (Maybe a)
go Int
0 [] ([Wait m (Maybe b)] -> Wait m (Maybe b))
-> ([a] -> [Wait m (Maybe b)]) -> [a] -> Wait m (Maybe b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Wait m (Maybe b)) -> [a] -> [Wait m (Maybe b)]
forall a b. (a -> b) -> [a] -> [b]
map a -> Wait m (Maybe b)
f
    where
        -- keep a list of those things we might visit later, and ask for each we see in turn
        go :: MonadIO m => Int -> [(Maybe a -> m ()) -> m ()] -> [Wait m (Maybe a)] -> Wait m (Maybe a)
        go :: Int
-> [(Maybe a -> m ()) -> m ()]
-> [Wait m (Maybe a)]
-> Wait m (Maybe a)
go !Int
nlater [(Maybe a -> m ()) -> m ()]
later (Wait m (Maybe a)
x:[Wait m (Maybe a)]
xs) = case Wait m (Maybe a)
x of
            Now (Just a
a) -> Maybe a -> Wait m (Maybe a)
forall (m :: * -> *) a. a -> Wait m a
Now (Maybe a -> Wait m (Maybe a)) -> Maybe a -> Wait m (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
a
            Now Maybe a
Nothing -> Int
-> [(Maybe a -> m ()) -> m ()]
-> [Wait m (Maybe a)]
-> Wait m (Maybe a)
forall (m :: * -> *) a.
MonadIO m =>
Int
-> [(Maybe a -> m ()) -> m ()]
-> [Wait m (Maybe a)]
-> Wait m (Maybe a)
go Int
nlater [(Maybe a -> m ()) -> m ()]
later [Wait m (Maybe a)]
xs
            Later (Maybe a -> m ()) -> m ()
l -> Int
-> [(Maybe a -> m ()) -> m ()]
-> [Wait m (Maybe a)]
-> Wait m (Maybe a)
forall (m :: * -> *) a.
MonadIO m =>
Int
-> [(Maybe a -> m ()) -> m ()]
-> [Wait m (Maybe a)]
-> Wait m (Maybe a)
go (Int -> Int
forall a. Enum a => a -> a
succ Int
nlater) ((Maybe a -> m ()) -> m ()
l((Maybe a -> m ()) -> m ())
-> [(Maybe a -> m ()) -> m ()] -> [(Maybe a -> m ()) -> m ()]
forall a. a -> [a] -> [a]
:[(Maybe a -> m ()) -> m ()]
later) [Wait m (Maybe a)]
xs
            Lift m (Wait m (Maybe a))
x -> m (Wait m (Maybe a)) -> Wait m (Maybe a)
forall (m :: * -> *) a. m (Wait m a) -> Wait m a
Lift (m (Wait m (Maybe a)) -> Wait m (Maybe a))
-> m (Wait m (Maybe a)) -> Wait m (Maybe a)
forall a b. (a -> b) -> a -> b
$ do
                Wait m (Maybe a)
x <- m (Wait m (Maybe a))
x
                Wait m (Maybe a) -> m (Wait m (Maybe a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Wait m (Maybe a) -> m (Wait m (Maybe a)))
-> Wait m (Maybe a) -> m (Wait m (Maybe a))
forall a b. (a -> b) -> a -> b
$ Int
-> [(Maybe a -> m ()) -> m ()]
-> [Wait m (Maybe a)]
-> Wait m (Maybe a)
forall (m :: * -> *) a.
MonadIO m =>
Int
-> [(Maybe a -> m ()) -> m ()]
-> [Wait m (Maybe a)]
-> Wait m (Maybe a)
go Int
nlater [(Maybe a -> m ()) -> m ()]
later (Wait m (Maybe a)
xWait m (Maybe a) -> [Wait m (Maybe a)] -> [Wait m (Maybe a)]
forall a. a -> [a] -> [a]
:[Wait m (Maybe a)]
xs)
        go Int
_ [] [] = Maybe a -> Wait m (Maybe a)
forall (m :: * -> *) a. a -> Wait m a
Now Maybe a
forall a. Maybe a
Nothing
        go Int
_ [(Maybe a -> m ()) -> m ()
l] [] = ((Maybe a -> m ()) -> m ()) -> Wait m (Maybe a)
forall (m :: * -> *) a. ((a -> m ()) -> m ()) -> Wait m a
Later (Maybe a -> m ()) -> m ()
l
        go Int
nls [(Maybe a -> m ()) -> m ()]
ls [] = ((Maybe a -> m ()) -> m ()) -> Wait m (Maybe a)
forall (m :: * -> *) a. ((a -> m ()) -> m ()) -> Wait m a
Later (((Maybe a -> m ()) -> m ()) -> Wait m (Maybe a))
-> ((Maybe a -> m ()) -> m ()) -> Wait m (Maybe a)
forall a b. (a -> b) -> a -> b
$ \Maybe a -> m ()
callback -> do
            IORef Int
ref <- IO (IORef Int) -> m (IORef Int)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef Int) -> m (IORef Int))
-> IO (IORef Int) -> m (IORef Int)
forall a b. (a -> b) -> a -> b
$ Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef Int
nls
            [(Maybe a -> m ()) -> m ()]
-> (((Maybe a -> m ()) -> m ()) -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Maybe a -> m ()) -> m ()]
ls ((((Maybe a -> m ()) -> m ()) -> m ()) -> m ())
-> (((Maybe a -> m ()) -> m ()) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \(Maybe a -> m ()) -> m ()
l -> (Maybe a -> m ()) -> m ()
l ((Maybe a -> m ()) -> m ()) -> (Maybe a -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Maybe a
r -> do
                Int
old <- IO Int -> m Int
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> m Int) -> IO Int -> m Int
forall a b. (a -> b) -> a -> b
$ IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
ref
                Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
old Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ case Maybe a
r of
                    Just a
a -> do
                        IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef Int -> Int -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef' IORef Int
ref Int
0
                        Maybe a -> m ()
callback (Maybe a -> m ()) -> Maybe a -> m ()
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
a
                    Maybe a
Nothing -> do
                        IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef Int -> Int -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef' IORef Int
ref (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Int
oldInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1
                        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
old Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Maybe a -> m ()
callback Maybe a
forall a. Maybe a
Nothing


firstLeftWaitUnordered :: MonadIO m => (a -> Wait m (Either e b)) -> [a] -> Wait m (Either e [b])
firstLeftWaitUnordered :: (a -> Wait m (Either e b)) -> [a] -> Wait m (Either e [b])
firstLeftWaitUnordered a -> Wait m (Either e b)
f [a]
xs = do
        let n :: Int
n = [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs
        MutableArray RealWorld b
mut <- IO (MutableArray RealWorld b) -> Wait m (MutableArray RealWorld b)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (MutableArray RealWorld b)
 -> Wait m (MutableArray RealWorld b))
-> IO (MutableArray RealWorld b)
-> Wait m (MutableArray RealWorld b)
forall a b. (a -> b) -> a -> b
$ Int -> b -> IO (MutableArray (PrimState IO) b)
forall (m :: * -> *) a.
PrimMonad m =>
Int -> a -> m (MutableArray (PrimState m) a)
newArray Int
n b
forall a. HasCallStack => a
undefined
        Maybe e
res <- MutableArray RealWorld b
-> [(Int, (Either e b -> m ()) -> m ())]
-> [(Int, Wait m (Either e b))]
-> Wait m (Maybe e)
forall (m :: * -> *) b e.
MonadIO m =>
MutableArray RealWorld b
-> [(Int, (Either e b -> m ()) -> m ())]
-> [(Int, Wait m (Either e b))]
-> Wait m (Maybe e)
go MutableArray RealWorld b
mut [] ([(Int, Wait m (Either e b))] -> Wait m (Maybe e))
-> [(Int, Wait m (Either e b))] -> Wait m (Maybe e)
forall a b. (a -> b) -> a -> b
$ Int -> [Wait m (Either e b)] -> [(Int, Wait m (Either e b))]
forall a b. Enum a => a -> [b] -> [(a, b)]
zipFrom Int
0 ([Wait m (Either e b)] -> [(Int, Wait m (Either e b))])
-> [Wait m (Either e b)] -> [(Int, Wait m (Either e b))]
forall a b. (a -> b) -> a -> b
$ (a -> Wait m (Either e b)) -> [a] -> [Wait m (Either e b)]
forall a b. (a -> b) -> [a] -> [b]
map a -> Wait m (Either e b)
f [a]
xs
        case Maybe e
res of
            Just e
e -> Either e [b] -> Wait m (Either e [b])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either e [b] -> Wait m (Either e [b]))
-> Either e [b] -> Wait m (Either e [b])
forall a b. (a -> b) -> a -> b
$ e -> Either e [b]
forall a b. a -> Either a b
Left e
e
            Maybe e
Nothing -> IO (Either e [b]) -> Wait m (Either e [b])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either e [b]) -> Wait m (Either e [b]))
-> IO (Either e [b]) -> Wait m (Either e [b])
forall a b. (a -> b) -> a -> b
$ [b] -> Either e [b]
forall a b. b -> Either a b
Right ([b] -> Either e [b]) -> IO [b] -> IO (Either e [b])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> IO b) -> [Int] -> IO [b]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (MutableArray (PrimState IO) b -> Int -> IO b
forall (m :: * -> *) a.
PrimMonad m =>
MutableArray (PrimState m) a -> Int -> m a
readArray MutableArray RealWorld b
MutableArray (PrimState IO) b
mut) [Int
0..Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]
    where
        -- keep a list of those things we might visit later, and ask for each we see in turn
        go :: MonadIO m => MutableArray RealWorld b -> [(Int, (Either e b -> m ()) -> m ())] -> [(Int, Wait m (Either e b))] -> Wait m (Maybe e)
        go :: MutableArray RealWorld b
-> [(Int, (Either e b -> m ()) -> m ())]
-> [(Int, Wait m (Either e b))]
-> Wait m (Maybe e)
go MutableArray RealWorld b
mut [(Int, (Either e b -> m ()) -> m ())]
later ((Int
i,Wait m (Either e b)
x):[(Int, Wait m (Either e b))]
xs) = case Wait m (Either e b)
x of
            Now (Left e
e) -> Maybe e -> Wait m (Maybe e)
forall (m :: * -> *) a. a -> Wait m a
Now (Maybe e -> Wait m (Maybe e)) -> Maybe e -> Wait m (Maybe e)
forall a b. (a -> b) -> a -> b
$ e -> Maybe e
forall a. a -> Maybe a
Just e
e
            Now (Right b
b) -> do
                IO () -> Wait m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Wait m ()) -> IO () -> Wait m ()
forall a b. (a -> b) -> a -> b
$ MutableArray (PrimState IO) b -> Int -> b -> IO ()
forall (m :: * -> *) a.
PrimMonad m =>
MutableArray (PrimState m) a -> Int -> a -> m ()
writeArray MutableArray RealWorld b
MutableArray (PrimState IO) b
mut Int
i b
b
                MutableArray RealWorld b
-> [(Int, (Either e b -> m ()) -> m ())]
-> [(Int, Wait m (Either e b))]
-> Wait m (Maybe e)
forall (m :: * -> *) b e.
MonadIO m =>
MutableArray RealWorld b
-> [(Int, (Either e b -> m ()) -> m ())]
-> [(Int, Wait m (Either e b))]
-> Wait m (Maybe e)
go MutableArray RealWorld b
mut [(Int, (Either e b -> m ()) -> m ())]
later [(Int, Wait m (Either e b))]
xs
            Later (Either e b -> m ()) -> m ()
l -> MutableArray RealWorld b
-> [(Int, (Either e b -> m ()) -> m ())]
-> [(Int, Wait m (Either e b))]
-> Wait m (Maybe e)
forall (m :: * -> *) b e.
MonadIO m =>
MutableArray RealWorld b
-> [(Int, (Either e b -> m ()) -> m ())]
-> [(Int, Wait m (Either e b))]
-> Wait m (Maybe e)
go MutableArray RealWorld b
mut ((Int
i,(Either e b -> m ()) -> m ()
l)(Int, (Either e b -> m ()) -> m ())
-> [(Int, (Either e b -> m ()) -> m ())]
-> [(Int, (Either e b -> m ()) -> m ())]
forall a. a -> [a] -> [a]
:[(Int, (Either e b -> m ()) -> m ())]
later) [(Int, Wait m (Either e b))]
xs
            Lift m (Wait m (Either e b))
x -> m (Wait m (Maybe e)) -> Wait m (Maybe e)
forall (m :: * -> *) a. m (Wait m a) -> Wait m a
Lift (m (Wait m (Maybe e)) -> Wait m (Maybe e))
-> m (Wait m (Maybe e)) -> Wait m (Maybe e)
forall a b. (a -> b) -> a -> b
$ do
                Wait m (Either e b)
x <- m (Wait m (Either e b))
x
                Wait m (Maybe e) -> m (Wait m (Maybe e))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Wait m (Maybe e) -> m (Wait m (Maybe e)))
-> Wait m (Maybe e) -> m (Wait m (Maybe e))
forall a b. (a -> b) -> a -> b
$ MutableArray RealWorld b
-> [(Int, (Either e b -> m ()) -> m ())]
-> [(Int, Wait m (Either e b))]
-> Wait m (Maybe e)
forall (m :: * -> *) b e.
MonadIO m =>
MutableArray RealWorld b
-> [(Int, (Either e b -> m ()) -> m ())]
-> [(Int, Wait m (Either e b))]
-> Wait m (Maybe e)
go MutableArray RealWorld b
mut [(Int, (Either e b -> m ()) -> m ())]
later ((Int
i,Wait m (Either e b)
x)(Int, Wait m (Either e b))
-> [(Int, Wait m (Either e b))] -> [(Int, Wait m (Either e b))]
forall a. a -> [a] -> [a]
:[(Int, Wait m (Either e b))]
xs)
        go MutableArray RealWorld b
_ [] [] = Maybe e -> Wait m (Maybe e)
forall (m :: * -> *) a. a -> Wait m a
Now Maybe e
forall a. Maybe a
Nothing
        go MutableArray RealWorld b
mut [(Int, (Either e b -> m ()) -> m ())]
ls [] = ((Maybe e -> m ()) -> m ()) -> Wait m (Maybe e)
forall (m :: * -> *) a. ((a -> m ()) -> m ()) -> Wait m a
Later (((Maybe e -> m ()) -> m ()) -> Wait m (Maybe e))
-> ((Maybe e -> m ()) -> m ()) -> Wait m (Maybe e)
forall a b. (a -> b) -> a -> b
$ \Maybe e -> m ()
callback -> do
            IORef Int
ref <- IO (IORef Int) -> m (IORef Int)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef Int) -> m (IORef Int))
-> IO (IORef Int) -> m (IORef Int)
forall a b. (a -> b) -> a -> b
$ Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef (Int -> IO (IORef Int)) -> Int -> IO (IORef Int)
forall a b. (a -> b) -> a -> b
$ [(Int, (Either e b -> m ()) -> m ())] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Int, (Either e b -> m ()) -> m ())]
ls
            [(Int, (Either e b -> m ()) -> m ())]
-> ((Int, (Either e b -> m ()) -> m ()) -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Int, (Either e b -> m ()) -> m ())]
ls (((Int, (Either e b -> m ()) -> m ()) -> m ()) -> m ())
-> ((Int, (Either e b -> m ()) -> m ()) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \(Int
i,(Either e b -> m ()) -> m ()
l) -> (Either e b -> m ()) -> m ()
l ((Either e b -> m ()) -> m ()) -> (Either e b -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Either e b
r -> do
                Int
old <- IO Int -> m Int
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> m Int) -> IO Int -> m Int
forall a b. (a -> b) -> a -> b
$ IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
ref
                Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
old Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ case Either e b
r of
                    Left e
a -> do
                        IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef Int -> Int -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef' IORef Int
ref Int
0
                        Maybe e -> m ()
callback (Maybe e -> m ()) -> Maybe e -> m ()
forall a b. (a -> b) -> a -> b
$ e -> Maybe e
forall a. a -> Maybe a
Just e
a
                    Right b
v -> do
                        IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ MutableArray (PrimState IO) b -> Int -> b -> IO ()
forall (m :: * -> *) a.
PrimMonad m =>
MutableArray (PrimState m) a -> Int -> a -> m ()
writeArray MutableArray RealWorld b
MutableArray (PrimState IO) b
mut Int
i b
v
                        IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef Int -> Int -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef' IORef Int
ref (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Int
oldInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1
                        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
old Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Maybe e -> m ()
callback Maybe e
forall a. Maybe a
Nothing