diff --git a/jsaddle.cabal b/jsaddle.cabal --- a/jsaddle.cabal +++ b/jsaddle.cabal @@ -1,5 +1,5 @@ name: jsaddle -version: 0.3.0.3 +version: 0.4.0.1 cabal-version: >=1.10 build-type: Simple license: MIT @@ -17,10 +17,6 @@ type: git location: https://github.com/ghcjs/jsaddle -flag gtk3 - description: - Use GTK3 rather than GTK2 - library if impl(ghcjs -any) @@ -28,18 +24,13 @@ ghcjs-base -any, ghcjs-prim -any else - if flag(gtk3) - build-depends: - gtk3 >=0.14.2 && <0.15, - webkitgtk3 >=0.13.0.0 && <0.15, - webkitgtk3-javascriptcore >=0.13.1.2 && <0.14 - else - build-depends: - gtk >=0.14.2 && <0.15, - webkit >=0.13.0.0 && <0.15, - webkit-javascriptcore >=0.13.1.2 && <0.14 build-depends: - glib -any + haskell-gi-base >= 0.17 && < 0.18, + gi-glib >=2.0.2 && <2.1, + gi-gtk >=3.0.2 && <3.1, + gi-webkit >=3.0.2 && <3.1, + gi-javascriptcore >=3.0.2 && <3.1, + webkitgtk3-javascriptcore >=0.14.0.0 && <0.15 exposed-modules: Language.Javascript.JSaddle Language.Javascript.JSaddle.Arguments @@ -57,9 +48,9 @@ build-depends: template-haskell -any, base <5, - lens >=3.8.5 && <4.14, + lens >=3.8.5 && <4.15, text >=0.11.2.3 && <1.3, - transformers >=0.3.0.0 && <0.5 + transformers >=0.3.0.0 && <0.6 default-language: Haskell2010 hs-source-dirs: src ghc-options: -ferror-spans @@ -69,18 +60,13 @@ if impl(ghcjs -any) buildable: False else - if flag(gtk3) - build-depends: - gtk3 -any, - webkitgtk3 -any, - webkitgtk3-javascriptcore -any - else - build-depends: - gtk -any, - webkit -any, - webkit-javascriptcore -any build-depends: - glib -any + haskell-gi-base >= 0.17 && < 0.18, + gi-glib >=2.0.2 && <2.1, + gi-gtk >=3.0.2 && <3.1, + gi-webkit >=3.0.2 && <3.1, + gi-javascriptcore >=3.0.2 && <3.1, + webkitgtk3-javascriptcore >=0.14.0.0 && <0.15 type: exitcode-stdio-1.0 main-is: DocTest.hs build-depends: diff --git a/src/Language/Javascript/JSaddle/Monad.hs b/src/Language/Javascript/JSaddle/Monad.hs --- a/src/Language/Javascript/JSaddle/Monad.hs +++ b/src/Language/Javascript/JSaddle/Monad.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE PatternSynonyms #-} ----------------------------------------------------------------------------- -- -- Module : Language.Javascript.JSaddle.Monad @@ -41,16 +42,42 @@ import Language.Javascript.JSaddle.Native (makeNewJSVal) import Foreign (nullPtr, alloca) import Foreign.Storable (Storable(..)) -import Graphics.UI.Gtk.WebKit.Types +import GI.WebKit.Types (WebView(..)) -import Graphics.UI.Gtk.WebKit.WebView +import GI.WebKit.Objects.WebView (webViewGetMainFrame) -import Graphics.UI.Gtk.WebKit.JavaScriptCore.WebFrame +import GI.WebKit.Objects.WebFrame (webFrameGetGlobalContext) -import Graphics.UI.Gtk.General.General (postGUIAsync, postGUISync) +import GI.GLib (idleAdd) +import GI.GLib.Constants(pattern PRIORITY_DEFAULT) #endif import qualified Control.Exception as E (Exception, catch, bracket) +import Control.Concurrent.MVar (takeMVar, putMVar, newEmptyMVar) +import Foreign.Ptr (castPtr) +import GI.JavaScriptCore.Structs.GlobalContext (GlobalContext(..)) +import Foreign.ForeignPtr (withForeignPtr) +-- | Post an action to be run in the main GUI thread. +-- +-- The current thread blocks until the action completes and the result is +-- returned. +-- +postGUISync :: IO a -> IO a +postGUISync action = do + resultVar <- newEmptyMVar + idleAdd PRIORITY_DEFAULT $ action >>= putMVar resultVar >> return False + takeMVar resultVar + +-- | Post an action to be run in the main GUI thread. +-- +-- The current thread continues and does not wait for the result of the +-- action. +-- +postGUIAsync :: IO () -> IO () +postGUIAsync action = do + idleAdd PRIORITY_DEFAULT $ action >> return False + return () + -- | Wrapped version of 'E.catch' that runs in a MonadIO that works -- a bit better with 'JSM' catch :: (MonadIO m, E.Exception e) @@ -101,8 +128,9 @@ #else runJSaddle :: WebView -> JSM a -> IO a runJSaddle webView f = do - gctxt <- webViewGetMainFrame webView >>= webFrameGetGlobalContext - runReaderT f gctxt + GlobalContext gctxt <- webViewGetMainFrame webView >>= webFrameGetGlobalContext + withForeignPtr gctxt $ \ptr -> + runReaderT f (castPtr ptr) #endif {-# INLINE runJSaddle #-} diff --git a/src/Language/Javascript/JSaddle/Test.hs b/src/Language/Javascript/JSaddle/Test.hs --- a/src/Language/Javascript/JSaddle/Test.hs +++ b/src/Language/Javascript/JSaddle/Test.hs @@ -1,4 +1,5 @@ {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE PatternSynonyms #-} ----------------------------------------------------------------------------- -- -- Module : TestJSC @@ -19,21 +20,19 @@ import Control.Applicative import Prelude hiding((!!), catch) -import Graphics.UI.Gtk - (Window, widgetDestroy, postGUIAsync, postGUISync, widgetShowAll, - mainGUI, mainQuit, on, objectDestroy, containerAdd, scrolledWindowNew, - windowSetPosition, windowSetDefaultSize, timeoutAddFull, windowNew, - initGUI) +import GI.Gtk + (Window, widgetDestroy, widgetShowAll, + mainQuit, containerAdd, scrolledWindowNew, + windowSetPosition, windowSetDefaultSize, windowNew) import Control.Concurrent (tryTakeMVar, forkIO, newMVar, putMVar, takeMVar, newEmptyMVar, yield) -import System.Glib.MainLoop (priorityLow) -import Graphics.UI.Gtk.General.Enums (WindowPosition(..)) -import Graphics.UI.Gtk.WebKit.WebView +import GI.Gtk.Enums (WindowType(..), WindowPosition(..)) +import GI.WebKit.Objects.WebView (webViewGetMainFrame, webViewNew) import System.IO.Unsafe (unsafePerformIO) import Control.Monad.Trans.Reader (runReaderT) -import Graphics.UI.Gtk.WebKit.JavaScriptCore.WebFrame +import GI.WebKit.Objects.WebFrame (webFrameGetGlobalContext) import Language.Javascript.JSaddle import qualified Data.Text as T @@ -42,9 +41,41 @@ import Control.Lens.Getter ((^.)) import Data.Monoid ((<>)) import Control.Concurrent.MVar (MVar) +import qualified GI.Gtk.Functions as Gtk (init, main) +import GI.GLib.Functions (timeoutAdd) +import GI.Gtk.Enums (WindowPosition(..)) +import Data.GI.Base.Signals (on) +import GI.GLib (idleAdd) +import GI.GLib.Constants(pattern PRIORITY_DEFAULT, pattern PRIORITY_LOW) +import GI.Gtk.Objects.Widget (onWidgetDestroy) +import GI.JavaScriptCore.Structs.GlobalContext (GlobalContext(..)) +import Foreign.ForeignPtr (withForeignPtr) +import Foreign.Ptr (castPtr) +import GI.Gtk.Objects.Adjustment (Adjustment(..)) -data TestState = TestState { jsContext :: JSContextRef, window :: Window } +-- | Post an action to be run in the main GUI thread. +-- +-- The current thread blocks until the action completes and the result is +-- returned. +-- +postGUISync :: IO a -> IO a +postGUISync action = do + resultVar <- newEmptyMVar + idleAdd PRIORITY_DEFAULT $ action >>= putMVar resultVar >> return False + takeMVar resultVar +-- | Post an action to be run in the main GUI thread. +-- +-- The current thread continues and does not wait for the result of the +-- action. +-- +postGUIAsync :: IO () -> IO () +postGUIAsync action = do + idleAdd PRIORITY_DEFAULT $ action >> return False + return () + +data TestState = TestState { jsContext :: GlobalContext, window :: Window } + state :: MVar (Maybe TestState) state = unsafePerformIO $ newMVar Nothing {-# NOINLINE state #-} @@ -77,18 +108,18 @@ debugLog "fork" _ <- forkIO $ do debugLog "initGUI" - _ <- initGUI + _ <- Gtk.init Nothing debugLog "windowNew" - window <- windowNew + window <- windowNew WindowTypeToplevel debugLog "timeoutAdd" - _ <- timeoutAddFull (yield >> return True) priorityLow 10 + _ <- timeoutAdd PRIORITY_LOW 10 $ yield >> return True windowSetDefaultSize window 900 600 - windowSetPosition window WinPosCenter - scrollWin <- scrolledWindowNew Nothing Nothing + windowSetPosition window WindowPositionCenter + scrollWin <- scrolledWindowNew (Nothing :: Maybe Adjustment) (Nothing :: Maybe Adjustment) webView <- webViewNew window `containerAdd` scrollWin scrollWin `containerAdd` webView - _ <- on window objectDestroy $ do + _ <- onWidgetDestroy window $ do debugLog "onDestroy" _ <- tryTakeMVar state debugLog "put state" @@ -105,18 +136,21 @@ debugLog "maybe show" when showWindow $ widgetShowAll window debugLog "mainGUI" - mainGUI + Gtk.main debugLog "mainGUI exited" takeMVar newState Just s@TestState {..} -> do debugLog "maybe show (2)" when showWindow . postGUISync $ widgetShowAll window return s - x <- postGUISync $ runReaderT ((f >>= valToText >>= liftIO . putStrLn . T.unpack) - `catch` \ (JSException e) -> valToText e >>= liftIO . putStrLn . T.unpack) jsContext + x <- postGUISync $ withContext jsContext $ runReaderT ((f >>= valToText >>= liftIO . putStrLn . T.unpack) + `catch` \ (JSException e) -> valToText e >>= liftIO . putStrLn . T.unpack) debugLog "put state" putMVar state $ Just TestState {..} return x + +withContext :: GlobalContext -> (JSContextRef -> IO a) -> IO a +withContext (GlobalContext fptr) f = withForeignPtr fptr $ f . castPtr listWindowProperties :: IO () listWindowProperties = testJSaddle $ T.pack . show <$> do diff --git a/tests/DocTest.hs b/tests/DocTest.hs --- a/tests/DocTest.hs +++ b/tests/DocTest.hs @@ -8,16 +8,7 @@ main :: IO () main = doctest [ "-hide-all-packages", -#ifdef VERSION_gtk3 - "-package=gtk3-" ++ VERSION_gtk3, - "-package=webkitgtk3-" ++ VERSION_webkitgtk3, "-package=webkitgtk3-javascriptcore-" ++ VERSION_webkitgtk3_javascriptcore, -#else - "-package=gtk-" ++ VERSION_gtk, - "-package=webkit-" ++ VERSION_webkit, - "-package=webkit-javascriptcore-" ++ VERSION_webkit_javascriptcore, -#endif - "-package=glib-" ++ VERSION_glib, "-package=template-haskell-" ++ VERSION_template_haskell, "-package=base-" ++ VERSION_base, "-package=lens-" ++ VERSION_lens,