jsaddle 0.3.0.3 → 0.4.0.1
raw patch · 4 files changed
+102/−63 lines, 4 filesdep +gi-glibdep +gi-gtkdep +gi-javascriptcoredep −glibdep −gtkdep −gtk3dep ~lensdep ~transformersdep ~webkitgtk3-javascriptcore
Dependencies added: gi-glib, gi-gtk, gi-javascriptcore, gi-webkit, haskell-gi-base
Dependencies removed: glib, gtk, gtk3, webkit, webkit-javascriptcore, webkitgtk3
Dependency ranges changed: lens, transformers, webkitgtk3-javascriptcore
Files
- jsaddle.cabal +15/−29
- src/Language/Javascript/JSaddle/Monad.hs +34/−6
- src/Language/Javascript/JSaddle/Test.hs +53/−19
- tests/DocTest.hs +0/−9
jsaddle.cabal view
@@ -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:
src/Language/Javascript/JSaddle/Monad.hs view
@@ -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 #-}
src/Language/Javascript/JSaddle/Test.hs view
@@ -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
tests/DocTest.hs view
@@ -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,