{-# LANGUAGE CPP, OverloadedStrings, PatternSynonyms #-}
#ifndef ghcjs_HOST_OS
{-# LANGUAGE RecursiveDo #-}
#endif
module JSDOM (
currentWindow
, currentWindowUnchecked
, currentDocument
, currentDocumentUnchecked
, syncPoint
, syncAfter
, waitForAnimationFrame
, nextAnimationFrame
, AnimationFrameHandle
, inAnimationFrame
, inAnimationFrame'
, catch
, bracket
) where
#ifdef ghcjs_HOST_OS
import JSDOM.Types
(FromJSVal(..), MonadDOM, liftDOM, Document(..), Window(..), JSM)
import Language.Javascript.JSaddle.Object (jsg)
import JavaScript.Web.AnimationFrame (AnimationFrameHandle, inAnimationFrame)
#else
import Control.Monad (void, forM_, when)
import Control.Monad.IO.Class (MonadIO(..))
import Control.Concurrent.MVar (putMVar, takeMVar)
import Language.Javascript.JSaddle.Types (JSContextRef(..))
import Language.Javascript.JSaddle.Object (freeFunction, jsg)
import Language.Javascript.JSaddle.Monad (askJSM)
import JSDOM.Types
(Callback(..), RequestAnimationFrameCallback(..), FromJSVal(..),
MonadDOM, liftDOM, Document(..), Window(..), JSM, JSContextRef(..))
import JSDOM.Generated.RequestAnimationFrameCallback
(newRequestAnimationFrameCallbackSync)
import JSDOM.Generated.Window (requestAnimationFrame)
#endif
import GHCJS.Concurrent (OnBlocked(..))
import Language.Javascript.JSaddle
(syncPoint, syncAfter, waitForAnimationFrame,
nextAnimationFrame, catch, bracket)
currentWindow :: MonadDOM m => m (Maybe Window)
currentWindow = liftDOM $ jsg ("window" :: String) >>= fromJSVal
currentWindowUnchecked :: MonadDOM m => m Window
currentWindowUnchecked = liftDOM $ jsg ("window" :: String) >>= fromJSValUnchecked
currentDocument :: MonadDOM m => m (Maybe Document)
currentDocument = liftDOM $ jsg ("document" :: String) >>= fromJSVal
currentDocumentUnchecked :: MonadDOM m => m Document
currentDocumentUnchecked = liftDOM $ jsg ("document" :: String) >>= fromJSValUnchecked
#ifndef ghcjs_HOST_OS
data AnimationFrameHandle = AnimationFrameHandle
inAnimationFrame :: OnBlocked
-> (Double -> JSM ())
-> JSM AnimationFrameHandle
inAnimationFrame _ f = do
handlersMVar <- animationFrameHandlers <$> askJSM
handlers <- liftIO $ takeMVar handlersMVar
liftIO $ putMVar handlersMVar (f : handlers)
when (null handlers) $ do
win <- currentWindowUnchecked
rec cb@(RequestAnimationFrameCallback (Callback fCb)) <- newRequestAnimationFrameCallbackSync $ \t -> do
freeFunction fCb
handlersToRun <- liftIO $ takeMVar handlersMVar
liftIO $ putMVar handlersMVar []
forM_ (reverse handlersToRun) (\handler -> handler t)
void $ requestAnimationFrame win cb
return AnimationFrameHandle
#endif
inAnimationFrame' :: (Double -> JSM ())
-> JSM AnimationFrameHandle
inAnimationFrame' = inAnimationFrame ContinueAsync