module Language.Sunroof.JS.Chan
( JSChan
, newChan
, writeChan, readChan
) 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 JSChan a = JSChan JSObject
deriveJSTuple
[d| instance (SunroofArgument o) => JSTuple (JSChan o) where
type Internals (JSChan o) =
( (JSArray (JSContinuation (JSContinuation o)))
, (JSArray (JSContinuation o))
)
|]
instance (SunroofArgument o) => EqB (JSChan o) where
(JSChan a) ==* (JSChan b) = a ==* b
newChan :: (SunroofArgument a) => JS t (JSChan a)
newChan = do
written <- newArray ()
waiting <- newArray ()
tuple (written, waiting)
writeChan :: forall t a . (SunroofThread t, SunroofArgument a) => a -> JSChan a -> JS t ()
writeChan a (match -> (written,waiting)) = do
ifB ((waiting ! length') ==* 0)
(do f <- continuation $ \ (k :: JSContinuation a) -> goto k a :: JSB ()
written # push (f :: JSContinuation (JSContinuation a))
)
(do f <- shift waiting
forkJS (goto f a :: JSB ())
)
readChan :: forall a . (Sunroof a, SunroofArgument a) => JSChan a -> JS B a
readChan (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
)