content: 
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE DataKinds #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  {-# LANGUAGE TypeFamilies #-}
  {-# LANGUAGE ViewPatterns #-}
  {-# LANGUAGE TemplateHaskell #-}
  {-# OPTIONS_GHC -fno-warn-missing-methods #-}
  
  -- | 'JSMVar' provides the same functionality and
  --   concurrency abstraction in Javascript computations
  --   as 'Control.Concurrent.MVar' in Haskell.
  module Language.Sunroof.JS.MVar
    ( JSMVar
    , newMVar, newEmptyMVar
    , putMVar, takeMVar
    ) where
  
  import Data.Boolean ( IfB(..), EqB(..), BooleanOf )
  
  import Language.Sunroof.Classes
  import Language.Sunroof.Types
  import Language.Sunroof.Concurrent ( forkJS )
  import Language.Sunroof.Selector ( (!) )
  import Language.Sunroof.JS.Bool
  import Language.Sunroof.JS.Object ( JSObject )
  import Language.Sunroof.JS.Array
    ( JSArray
    , newArray, length'
    , push, shift )
  
  -- -------------------------------------------------------------
  -- JSMVar Type
  -- -------------------------------------------------------------
  
  -- | 'JSMVar' abstraction. The type parameter gives
  --   the type of values held in a 'JSMVar'.
  newtype JSMVar a = JSMVar JSObject
  
  instance (SunroofArgument o) => Show (JSMVar o) where
    show (JSMVar o) = show o
  
  instance (SunroofArgument o) => Sunroof (JSMVar o) where
    unbox (JSMVar o) = unbox o
    box o = JSMVar (box o)
  
  instance (SunroofArgument o) => IfB (JSMVar o) where
    ifB = jsIfB
  
  type instance BooleanOf (JSMVar o) = JSBool
  
  instance (SunroofArgument o) => JSTuple (JSMVar o) where
    type Internals (JSMVar o) = 
      ( (JSArray (JSContinuation (JSContinuation o))) -- callbacks of written data
      , (JSArray (JSContinuation o))                 -- callbacks of waiting readers
      )
    match o = (o ! attr "written", o ! attr "waiting")
    tuple (written,waiting) = do
      o <- new "Object" ()
      o # attr "written" := written
      o # attr "waiting" := waiting
      return (JSMVar o)
  
  -- | Reference equality, not value equality.
  instance (SunroofArgument o) => EqB (JSMVar o) where
    (JSMVar a) ==* (JSMVar b) = a ==* b
  
  -- -------------------------------------------------------------
  -- JSMVar Combinators
  -- -------------------------------------------------------------
  
  -- | Create a new 'JSMVar' with the given value inside.
  --   See 'newEmptyMVar'.
  newMVar :: forall a t . (SunroofArgument a) => a -> JS t (JSMVar a)
  newMVar a = do
    written <- newArray ()
    waiting <- newArray ()
    -- mvar must be empty, with no one waiting, so just push and continue
    f <- continuation $ \ (k :: JSContinuation a) -> goto k a :: JSB ()
    _ <- written # push (f :: JSContinuation (JSContinuation a))
    tuple (written, waiting)
  
  -- | Create a new empty 'JSMVar'.
  --   See 'newMVar'.
  newEmptyMVar :: (SunroofArgument a) => JS t (JSMVar a)
  newEmptyMVar = do
    written <- newArray ()
    waiting <- newArray ()
    tuple (written, waiting)
  
  -- TODO: Not quite right; pauses until someone bites
  -- | Put the value into the 'JSMVar'. If there already is a
  --   value inside, this will block until it is taken out.
  putMVar :: forall a . (SunroofArgument a) => a -> JSMVar a -> JS 'B ()
  putMVar a (match -> (written,waiting)) = do
    ifB ((waiting ! length') ==* 0)
        (-- no-one is waiting, so check for fullness
         ifB ((written ! length') ==* 0)
            (-- mvar empty, so just push and continue
             do f <- continuation $ \ (k :: JSContinuation a) -> goto k a :: JSB ()
                _ <- written # push (f :: JSContinuation (JSContinuation a))
                return ()
            )
            (-- mvar full, so block
             callcc $ \ (k :: JSContinuation ()) -> do
              f <- continuation $ \ (kr :: JSContinuation a) -> do
                  -- we've got a request for the contents
                  -- so we can continue
                  forkJS $ (goto k () :: JSB ())
                  -- and send the boxed value
                  goto kr a :: JSB ()
              _ <- written # push (f :: JSContinuation (JSContinuation a))
              done
           )
        )
          -- If someone is already waiting, then just pass the value (and continue without pausing)
        (do f <- shift waiting
            forkJS (goto f a :: JSB ())
            return ()
        )
  
  -- | Take the value out of the 'JSMVar'. If there is no value
  --   inside, this will block until one is available.
  takeMVar :: forall a . (SunroofArgument a) => JSMVar a -> JS 'B a
  takeMVar (match -> (written,waiting)) = do
    ifB ((written ! length') ==* 0)
        (do -- Add yourself to the 'waiting for writer' Q.
            callcc $ \ k -> do _ <- waiting # push (k :: JSContinuation a)
                               done
        )
        (do f <- shift written
            -- Here, we add our continuation into the written Q.
            callcc $ \ k -> goto f k
        )
  
  
  