{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
-----------------------------------------------------------------------------
--
-- Module      :  Language.Javascript.JSaddle.WebSockets
-- Copyright   :  (c) Hamish Mackenzie
-- License     :  MIT
--
-- Maintainer  :  Hamish Mackenzie <Hamish.K.Mackenzie@googlemail.com>
--
-- |
--
-----------------------------------------------------------------------------

module Language.Javascript.JSaddle.Debug (
    contexts
  , addContext
  , removeContext
  , runOnAll
  , runOnAll_
) where

import Language.Javascript.JSaddle
       (runJSM, askJSM, JSM, JSContextRef(..))
import Data.IORef (readIORef, atomicModifyIORef', newIORef, IORef)
import System.IO.Unsafe (unsafePerformIO)
import Data.Monoid ((<>))
import Control.Monad.IO.Class (MonadIO(..))
import Data.Int (Int64)

contexts :: IORef [JSContextRef]
contexts :: IORef [JSContextRef]
contexts = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef []
{-# NOINLINE contexts #-}

addContext :: JSM ()
addContext :: JSM ()
addContext = do
    JSContextRef
ctx <- forall (m :: * -> *). MonadJSM m => m JSContextRef
askJSM
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [JSContextRef]
contexts forall a b. (a -> b) -> a -> b
$ \[JSContextRef]
c -> ([JSContextRef]
c forall a. Semigroup a => a -> a -> a
<> [JSContextRef
ctx], ())

removeContext :: MonadIO m => Int64 -> m ()
removeContext :: forall (m :: * -> *). MonadIO m => Int64 -> m ()
removeContext Int64
cid =
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [JSContextRef]
contexts forall a b. (a -> b) -> a -> b
$ \[JSContextRef]
c -> (forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
/= Int64
cid) forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSContextRef -> Int64
contextId) [JSContextRef]
c, ())

runOnAll :: MonadIO m => JSM a -> m [a]
runOnAll :: forall (m :: * -> *) a. MonadIO m => JSM a -> m [a]
runOnAll JSM a
f = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a. IORef a -> IO a
readIORef IORef [JSContextRef]
contexts) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *) a. MonadIO m => JSM a -> JSContextRef -> m a
runJSM JSM a
f)

runOnAll_ :: MonadIO m => JSM a -> m ()
runOnAll_ :: forall (m :: * -> *) a. MonadIO m => JSM a -> m ()
runOnAll_ JSM a
f = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a. IORef a -> IO a
readIORef IORef [JSContextRef]
contexts) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall (m :: * -> *) a. MonadIO m => JSM a -> JSContextRef -> m a
runJSM JSM a
f)