{-# 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 = IO (IORef [JSContextRef]) -> IORef [JSContextRef]
forall a. IO a -> a
unsafePerformIO (IO (IORef [JSContextRef]) -> IORef [JSContextRef])
-> IO (IORef [JSContextRef]) -> IORef [JSContextRef]
forall a b. (a -> b) -> a -> b
$ [JSContextRef] -> IO (IORef [JSContextRef])
forall a. a -> IO (IORef a)
newIORef []
{-# NOINLINE contexts #-}

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

removeContext :: MonadIO m => Int64 -> m ()
removeContext :: forall (m :: * -> *). MonadIO m => Int64 -> m ()
removeContext Int64
cid =
    IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef [JSContextRef]
-> ([JSContextRef] -> ([JSContextRef], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [JSContextRef]
contexts (([JSContextRef] -> ([JSContextRef], ())) -> IO ())
-> ([JSContextRef] -> ([JSContextRef], ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[JSContextRef]
c -> ((JSContextRef -> Bool) -> [JSContextRef] -> [JSContextRef]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
/= Int64
cid) (Int64 -> Bool) -> (JSContextRef -> Int64) -> JSContextRef -> Bool
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 = IO [JSContextRef] -> m [JSContextRef]
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef [JSContextRef] -> IO [JSContextRef]
forall a. IORef a -> IO a
readIORef IORef [JSContextRef]
contexts) m [JSContextRef] -> ([JSContextRef] -> m [a]) -> m [a]
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (JSContextRef -> m a) -> [JSContextRef] -> m [a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (JSM a -> JSContextRef -> m a
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 = IO [JSContextRef] -> m [JSContextRef]
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef [JSContextRef] -> IO [JSContextRef]
forall a. IORef a -> IO a
readIORef IORef [JSContextRef]
contexts) m [JSContextRef] -> ([JSContextRef] -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (JSContextRef -> m a) -> [JSContextRef] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (JSM a -> JSContextRef -> m a
forall (m :: * -> *) a. MonadIO m => JSM a -> JSContextRef -> m a
runJSM JSM a
f)