@@ -1,4 +1,5 @@
11{-# LANGUAGE RecordWildCards #-}
2+{-# LANGUAGE PatternSynonyms #-}
23-----------------------------------------------------------------------------
34--
45-- Module : TestJSC
@@ -19,21 +20,19 @@ module Language.Javascript.JSaddle.Test (
1920
2021import Control.Applicative
2122import Prelude hiding((!!), catch)
22−import Graphics.UI.Gtk
23− (Window, widgetDestroy, postGUIAsync, postGUISync, widgetShowAll,
24− mainGUI, mainQuit, on, objectDestroy, containerAdd, scrolledWindowNew,
25− windowSetPosition, windowSetDefaultSize, timeoutAddFull, windowNew,
26− initGUI)
23+import GI.Gtk
24+ (Window, widgetDestroy, widgetShowAll,
25+ mainQuit, containerAdd, scrolledWindowNew,
26+ windowSetPosition, windowSetDefaultSize, windowNew)
2727import Control.Concurrent
2828 (tryTakeMVar, forkIO, newMVar, putMVar, takeMVar, newEmptyMVar,
2929 yield)
30−import System.Glib.MainLoop (priorityLow)
31−import Graphics.UI.Gtk.General.Enums (WindowPosition(..))
32−import Graphics.UI.Gtk.WebKit.WebView
30+import GI.Gtk.Enums (WindowType(..), WindowPosition(..))
31+import GI.WebKit.Objects.WebView
3332 (webViewGetMainFrame, webViewNew)
3433import System.IO.Unsafe (unsafePerformIO)
3534import Control.Monad.Trans.Reader (runReaderT)
36−import Graphics.UI.Gtk.WebKit.JavaScriptCore.WebFrame
35+import GI.WebKit.Objects.WebFrame
3736 (webFrameGetGlobalContext)
3837import Language.Javascript.JSaddle
3938import qualified Data.Text as T
@@ -42,8 +41,40 @@ import Control.Monad (forM, when)
4241import Control.Lens.Getter ((^.))
4342import Data.Monoid ((<>))
4443import Control.Concurrent.MVar (MVar)
44+import qualified GI.Gtk.Functions as Gtk (init, main)
45+import GI.GLib.Functions (timeoutAdd)
46+import GI.Gtk.Enums (WindowPosition(..))
47+import Data.GI.Base.Signals (on)
48+import GI.GLib (idleAdd)
49+import GI.GLib.Constants(pattern PRIORITY_DEFAULT, pattern PRIORITY_LOW)
50+import GI.Gtk.Objects.Widget (onWidgetDestroy)
51+import GI.JavaScriptCore.Structs.GlobalContext (GlobalContext(..))
52+import Foreign.ForeignPtr (withForeignPtr)
53+import Foreign.Ptr (castPtr)
54+import GI.Gtk.Objects.Adjustment (Adjustment(..))
55+
56+-- | Post an action to be run in the main GUI thread.
57+--
58+-- The current thread blocks until the action completes and the result is
59+-- returned.
60+--
61+postGUISync :: IO a -> IO a
62+postGUISync action = do
63+ resultVar <- newEmptyMVar
64+ idleAdd PRIORITY_DEFAULT $ action >>= putMVar resultVar >> return False
65+ takeMVar resultVar
66+
67+-- | Post an action to be run in the main GUI thread.
68+--
69+-- The current thread continues and does not wait for the result of the
70+-- action.
71+--
72+postGUIAsync :: IO () -> IO ()
73+postGUIAsync action = do
74+ idleAdd PRIORITY_DEFAULT $ action >> return False
75+ return ()
4576
46−data TestState = TestState { jsContext :: JSContextRef, window :: Window }
77+data TestState = TestState { jsContext :: GlobalContext, window :: Window }
4778
4879state :: MVar (Maybe TestState)
4980state = unsafePerformIO $ newMVar Nothing
@@ -77,18 +108,18 @@ testJSaddle' showWindow f = do
77108 debugLog "fork"
78109 _ <- forkIO $ do
79110 debugLog "initGUI"
80− _ <- initGUI
111+ _ <- Gtk.init Nothing
81112 debugLog "windowNew"
82− window <- windowNew
113+ window <- windowNew WindowTypeToplevel
83114 debugLog "timeoutAdd"
84− _ <- timeoutAddFull (yield >> return True) priorityLow 10
115+ _ <- timeoutAdd PRIORITY_LOW 10 $ yield >> return True
85116 windowSetDefaultSize window 900 600
86− windowSetPosition window WinPosCenter
87− scrollWin <- scrolledWindowNew Nothing Nothing
117+ windowSetPosition window WindowPositionCenter
118+ scrollWin <- scrolledWindowNew (Nothing :: Maybe Adjustment) (Nothing :: Maybe Adjustment)
88119 webView <- webViewNew
89120 window `containerAdd` scrollWin
90121 scrollWin `containerAdd` webView
91− _ <- on window objectDestroy $ do
122+ _ <- onWidgetDestroy window $ do
92123 debugLog "onDestroy"
93124 _ <- tryTakeMVar state
94125 debugLog "put state"
@@ -105,19 +136,22 @@ testJSaddle' showWindow f = do
105136 debugLog "maybe show"
106137 when showWindow $ widgetShowAll window
107138 debugLog "mainGUI"
108− mainGUI
139+ Gtk.main
109140 debugLog "mainGUI exited"
110141 takeMVar newState
111142 Just s@TestState {..} -> do
112143 debugLog "maybe show (2)"
113144 when showWindow . postGUISync $ widgetShowAll window
114145 return s
115− x <- postGUISync $ runReaderT ((f >>= valToText >>= liftIO . putStrLn . T.unpack)
116− `catch` \ (JSException e) -> valToText e >>= liftIO . putStrLn . T.unpack) jsContext
146+ x <- postGUISync $ withContext jsContext $ runReaderT ((f >>= valToText >>= liftIO . putStrLn . T.unpack)
147+ `catch` \ (JSException e) -> valToText e >>= liftIO . putStrLn . T.unpack)
117148 debugLog "put state"
118149 putMVar state $ Just TestState {..}
119150 return x
120151
152+withContext :: GlobalContext -> (JSContextRef -> IO a) -> IO a
153+withContext (GlobalContext fptr) f = withForeignPtr fptr $ f . castPtr
154+
121155listWindowProperties :: IO ()
122156listWindowProperties = testJSaddle $ T.pack . show <$> do
123157 window <- jsg "window"