module Language.Javascript.JSaddle.Monad (
JSM
, JSContextRef
, runJSaddle
, catchval
, catch
, bracket
, postGUIAsyncJS
, postGUISyncJS
) where
import Prelude hiding (catch, read)
import Control.Monad.Trans.Reader (runReaderT, ask, ReaderT(..))
import Language.Javascript.JSaddle.Types
(JSM, JSVal, MutableJSArray, JSContextRef)
import Control.Monad.IO.Class (MonadIO(..))
#ifdef ghcjs_HOST_OS
import GHCJS.Types (isUndefined, isNull)
import qualified JavaScript.Array as Array (create, read)
#else
import Language.Javascript.JSaddle.Native (makeNewJSVal)
import Foreign (nullPtr, alloca)
import Foreign.Storable (Storable(..))
import Graphics.UI.Gtk.WebKit.Types
(WebView(..))
import Graphics.UI.Gtk.WebKit.WebView
(webViewGetMainFrame)
import Graphics.UI.Gtk.WebKit.JavaScriptCore.WebFrame
(webFrameGetGlobalContext)
import Graphics.UI.Gtk.General.General (postGUIAsync, postGUISync)
#endif
import qualified Control.Exception as E (Exception, catch, bracket)
catch :: (MonadIO m, E.Exception e)
=> ReaderT r IO b
-> (e -> ReaderT r IO b)
-> ReaderT r m b
t `catch` c = do
r <- ask
liftIO (runReaderT t r `E.catch` \e -> runReaderT (c e) r)
bracket :: MonadIO m => ReaderT r IO a -> (a -> ReaderT r IO b) -> (a -> ReaderT r IO c) -> ReaderT r m c
bracket aquire release f = do
r <- ask
liftIO $ E.bracket
(runReaderT aquire r)
(\x -> runReaderT (release x) r)
(\x -> runReaderT (f x) r)
catchval :: (MutableJSArray -> JSM a) -> (JSVal -> JSM a) -> JSM a
catchval f catcher = do
#ifdef ghcjs_HOST_OS
pexc <- liftIO Array.create
result <- f pexc
exc <- liftIO $ Array.read 0 pexc
if isUndefined exc || isNull exc
then return result
else catcher exc
#else
gctxt <- ask
liftIO . alloca $ \pexc -> flip runReaderT gctxt $ do
liftIO $ poke pexc nullPtr
result <- f pexc
exc <- liftIO $ peek pexc
if exc == nullPtr
then return result
else makeNewJSVal exc >>= catcher
#endif
#ifdef ghcjs_HOST_OS
runJSaddle :: w -> JSM a -> IO a
runJSaddle _ f = runReaderT f ()
#else
runJSaddle :: WebView -> JSM a -> IO a
runJSaddle webView f = do
gctxt <- webViewGetMainFrame webView >>= webFrameGetGlobalContext
runReaderT f gctxt
#endif
postGUIAsyncJS :: JSM () -> JSM ()
#ifdef ghcjs_HOST_OS
postGUIAsyncJS = id
#else
postGUIAsyncJS f = do
r <- ask
liftIO . postGUIAsync $ runReaderT f r
#endif
postGUISyncJS :: JSM a -> JSM a
#ifdef ghcjs_HOST_OS
postGUISyncJS = id
#else
postGUISyncJS f = do
r <- ask
liftIO . postGUISync $ runReaderT f r
#endif