module Language.Sunroof.JS.MVar
( JSMVar
, newMVar, newEmptyMVar
, putMVar, takeMVar
) where
import Data.Boolean ( IfB(..), EqB(..) )
import Language.Sunroof.Classes
( Sunroof(..), SunroofArgument(..) )
import Language.Sunroof.Types
import Language.Sunroof.Concurrent ( forkJS )
import Language.Sunroof.Selector ( (!) )
import Language.Sunroof.TH
import Language.Sunroof.JS.Object ( JSObject )
import Language.Sunroof.JS.Array
( JSArray
, newArray, length'
, push, shift )
newtype JSMVar a = JSMVar JSObject
deriveJSTuple
[d| instance (SunroofArgument o) => JSTuple (JSMVar o) where
type Internals (JSMVar o) =
( (JSArray (JSContinuation (JSContinuation o)))
, (JSArray (JSContinuation o))
)
|]
instance (SunroofArgument o) => EqB (JSMVar o) where
(JSMVar a) ==* (JSMVar b) = a ==* b
newMVar :: forall a t . (SunroofArgument a) => a -> JS t (JSMVar a)
newMVar a = do
written <- newArray ()
waiting <- newArray ()
f <- continuation $ \ (k :: JSContinuation a) -> goto k a :: JSB ()
written # push (f :: JSContinuation (JSContinuation a))
tuple (written, waiting)
newEmptyMVar :: (SunroofArgument a) => JS t (JSMVar a)
newEmptyMVar = do
written <- newArray ()
waiting <- newArray ()
tuple (written, waiting)
putMVar :: forall a . (SunroofArgument a) => a -> JSMVar a -> JS B ()
putMVar a (match -> (written,waiting)) = do
ifB ((waiting ! length') ==* 0)
(
ifB ((written ! length') ==* 0)
(
do f <- continuation $ \ (k :: JSContinuation a) -> goto k a :: JSB ()
written # push (f :: JSContinuation (JSContinuation a))
)
(
callcc $ \ (k :: JSContinuation ()) -> do
f <- continuation $ \ (kr :: JSContinuation a) -> do
forkJS $ (goto k () :: JSB ())
goto kr a :: JSB ()
written # push (f :: JSContinuation (JSContinuation a))
done
)
)
(do f <- shift waiting
forkJS (goto f a :: JSB ())
return ()
)
takeMVar :: forall a . (Sunroof a, SunroofArgument a) => JSMVar a -> JS B a
takeMVar (match -> (written,waiting)) = do
ifB ((written ! length') ==* 0)
(do
callcc $ \ k -> do waiting # push (k :: JSContinuation a)
done
)
(do f <- shift written
callcc $ \ k -> goto f k
)