module General.Concurrent(
    Fence, newFence, signalFence, waitFence, testFence,
    ) where

import Control.Applicative
import Control.Monad
import Data.IORef
import Prelude


---------------------------------------------------------------------
-- FENCE

-- | Like a barrier, but based on callbacks
newtype Fence a = Fence (IORef (Either [a -> IO ()] a))
instance Show (Fence a) where show :: Fence a -> String
show _ = "Fence"

newFence :: IO (Fence a)
newFence :: IO (Fence a)
newFence = IORef (Either [a -> IO ()] a) -> Fence a
forall a. IORef (Either [a -> IO ()] a) -> Fence a
Fence (IORef (Either [a -> IO ()] a) -> Fence a)
-> IO (IORef (Either [a -> IO ()] a)) -> IO (Fence a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either [a -> IO ()] a -> IO (IORef (Either [a -> IO ()] a))
forall a. a -> IO (IORef a)
newIORef ([a -> IO ()] -> Either [a -> IO ()] a
forall a b. a -> Either a b
Left [])

signalFence :: Fence a -> a -> IO ()
signalFence :: Fence a -> a -> IO ()
signalFence (Fence ref :: IORef (Either [a -> IO ()] a)
ref) v :: a
v = IO (IO ()) -> IO ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO ()) -> IO ()) -> IO (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef (Either [a -> IO ()] a)
-> (Either [a -> IO ()] a -> (Either [a -> IO ()] a, IO ()))
-> IO (IO ())
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef (Either [a -> IO ()] a)
ref ((Either [a -> IO ()] a -> (Either [a -> IO ()] a, IO ()))
 -> IO (IO ()))
-> (Either [a -> IO ()] a -> (Either [a -> IO ()] a, IO ()))
-> IO (IO ())
forall a b. (a -> b) -> a -> b
$ \x :: Either [a -> IO ()] a
x -> case Either [a -> IO ()] a
x of
    Left queue :: [a -> IO ()]
queue -> (a -> Either [a -> IO ()] a
forall a b. b -> Either a b
Right a
v, ((a -> IO ()) -> IO ()) -> [a -> IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((a -> IO ()) -> a -> IO ()
forall a b. (a -> b) -> a -> b
$ a
v) ([a -> IO ()] -> IO ()) -> [a -> IO ()] -> IO ()
forall a b. (a -> b) -> a -> b
$ [a -> IO ()] -> [a -> IO ()]
forall a. [a] -> [a]
reverse [a -> IO ()]
queue)
    Right v :: a
v -> String -> (Either [a -> IO ()] a, IO ())
forall a. HasCallStack => String -> a
error "Shake internal error, signalFence called twice on one Fence"

waitFence :: Fence a -> (a -> IO ()) -> IO ()
waitFence :: Fence a -> (a -> IO ()) -> IO ()
waitFence (Fence ref :: IORef (Either [a -> IO ()] a)
ref) call :: a -> IO ()
call = IO (IO ()) -> IO ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO ()) -> IO ()) -> IO (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef (Either [a -> IO ()] a)
-> (Either [a -> IO ()] a -> (Either [a -> IO ()] a, IO ()))
-> IO (IO ())
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef (Either [a -> IO ()] a)
ref ((Either [a -> IO ()] a -> (Either [a -> IO ()] a, IO ()))
 -> IO (IO ()))
-> (Either [a -> IO ()] a -> (Either [a -> IO ()] a, IO ()))
-> IO (IO ())
forall a b. (a -> b) -> a -> b
$ \x :: Either [a -> IO ()] a
x -> case Either [a -> IO ()] a
x of
    Left queue :: [a -> IO ()]
queue -> ([a -> IO ()] -> Either [a -> IO ()] a
forall a b. a -> Either a b
Left (a -> IO ()
call(a -> IO ()) -> [a -> IO ()] -> [a -> IO ()]
forall a. a -> [a] -> [a]
:[a -> IO ()]
queue), () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
    Right v :: a
v -> (a -> Either [a -> IO ()] a
forall a b. b -> Either a b
Right a
v, a -> IO ()
call a
v)

testFence :: Fence a -> IO (Maybe a)
testFence :: Fence a -> IO (Maybe a)
testFence (Fence x :: IORef (Either [a -> IO ()] a)
x) = ([a -> IO ()] -> Maybe a)
-> (a -> Maybe a) -> Either [a -> IO ()] a -> Maybe a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe a -> [a -> IO ()] -> Maybe a
forall a b. a -> b -> a
const Maybe a
forall a. Maybe a
Nothing) a -> Maybe a
forall a. a -> Maybe a
Just (Either [a -> IO ()] a -> Maybe a)
-> IO (Either [a -> IO ()] a) -> IO (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (Either [a -> IO ()] a) -> IO (Either [a -> IO ()] a)
forall a. IORef a -> IO a
readIORef IORef (Either [a -> IO ()] a)
x