5d0ed25 · jsaddle · git.iko.soy

git.iko.soy/jsaddle

on master help sign in

Switch from Gtk2Hs to haskell-gi

5d0ed25Hamish Mackenzie11 years ago

jsaddle.cabal+13−27

compare with master

unifiedsplit

@@ -1,5 +1,5 @@

1name: jsaddle

2−version: 0.3.0.3

2+version: 0.4.0.0

3cabal-version: >=1.10

4build-type: Simple

5license: MIT

@@ -17,10 +17,6 @@ source-repository head

17 type: git

18 location: https://github.com/ghcjs/jsaddle

20−flag gtk3

21− description:

22− Use GTK3 rather than GTK2

23−

24library

20library

26 if impl(ghcjs -any)

22 if impl(ghcjs -any)

@@ -28,18 +24,13 @@ library

28 ghcjs-base -any,

24 ghcjs-base -any,

29 ghcjs-prim -any

25 ghcjs-prim -any

30 else

26 else

31− if flag(gtk3)

32− build-depends:

33− gtk3 >=0.14.2 && <0.15,

34− webkitgtk3 >=0.13.0.0 && <0.15,

35− webkitgtk3-javascriptcore >=0.13.1.2 && <0.14

36− else

37− build-depends:

38− gtk >=0.14.2 && <0.15,

39− webkit >=0.13.0.0 && <0.15,

40− webkit-javascriptcore >=0.13.1.2 && <0.14

41 build-depends:

27 build-depends:

42− glib -any

28+ haskell-gi-base >= 0.13 && < 0.14,

29+ gi-glib >=0.2.44 && <0.2.47,

30+ gi-gtk >=0.3.16 && <0.3.19,

31+ gi-webkit >=0.2.4 && <0.2.5,

32+ gi-javascriptcore >=0.2.4 && <0.2.5,

33+ webkitgtk3-javascriptcore >=0.14.0.0 && <0.15

43 exposed-modules:

34 exposed-modules:

44 Language.Javascript.JSaddle

35 Language.Javascript.JSaddle

45 Language.Javascript.JSaddle.Arguments

36 Language.Javascript.JSaddle.Arguments

@@ -69,18 +60,13 @@ test-suite test-tool

69 if impl(ghcjs -any)

60 if impl(ghcjs -any)

70 buildable: False

61 buildable: False

71 else

62 else

72− if flag(gtk3)

73− build-depends:

74− gtk3 -any,

75− webkitgtk3 -any,

76− webkitgtk3-javascriptcore -any

77− else

78− build-depends:

79− gtk -any,

80− webkit -any,

81− webkit-javascriptcore -any

82 build-depends:

63 build-depends:

83− glib -any

64+ haskell-gi-base >= 0.13 && < 0.14,

65+ gi-glib >=0.2.44 && <0.2.47,

66+ gi-gtk >=0.3.16 && <0.3.19,

67+ gi-webkit >=0.2.4 && <0.2.5,

68+ gi-javascriptcore >=0.2.4 && <0.2.5,

69+ webkitgtk3-javascriptcore >=0.14.0.0 && <0.15

84 type: exitcode-stdio-1.0

70 type: exitcode-stdio-1.0

85 main-is: DocTest.hs

71 main-is: DocTest.hs

86 build-depends:

72 build-depends:

src/Language/Javascript/JSaddle/Monad.hs+34−6

@@ -1,4 +1,5 @@

1{-# LANGUAGE CPP #-}

2+{-# LANGUAGE PatternSynonyms #-}

2-----------------------------------------------------------------------------

3-----------------------------------------------------------------------------

3--

4--

4-- Module : Language.Javascript.JSaddle.Monad

5-- Module : Language.Javascript.JSaddle.Monad

@@ -41,15 +42,41 @@ import qualified JavaScript.Array as Array (create, read)

41import Language.Javascript.JSaddle.Native (makeNewJSVal)

42import Language.Javascript.JSaddle.Native (makeNewJSVal)

42import Foreign (nullPtr, alloca)

43import Foreign (nullPtr, alloca)

43import Foreign.Storable (Storable(..))

44import Foreign.Storable (Storable(..))

44−import Graphics.UI.Gtk.WebKit.Types

45+import GI.WebKit.Types

45 (WebView(..))

46 (WebView(..))

46−import Graphics.UI.Gtk.WebKit.WebView

47+import GI.WebKit.Objects.WebView

47 (webViewGetMainFrame)

48 (webViewGetMainFrame)

48−import Graphics.UI.Gtk.WebKit.JavaScriptCore.WebFrame

49+import GI.WebKit.Objects.WebFrame

49 (webFrameGetGlobalContext)

50 (webFrameGetGlobalContext)

50−import Graphics.UI.Gtk.General.General (postGUIAsync, postGUISync)

51+import GI.GLib (idleAdd)

52+import GI.GLib.Constants(pattern PRIORITY_DEFAULT)

51#endif

53#endif

52import qualified Control.Exception as E (Exception, catch, bracket)

54import qualified Control.Exception as E (Exception, catch, bracket)

55+import Control.Concurrent.MVar (takeMVar, putMVar, newEmptyMVar)

56+import Foreign.Ptr (castPtr)

57+import GI.JavaScriptCore.Structs.GlobalContext (GlobalContext(..))

58+import Foreign.ForeignPtr (withForeignPtr)

59+

60+-- | Post an action to be run in the main GUI thread.

61+--

62+-- The current thread blocks until the action completes and the result is

63+-- returned.

64+--

65+postGUISync :: IO a -> IO a

66+postGUISync action = do

67+ resultVar <- newEmptyMVar

68+ idleAdd PRIORITY_DEFAULT $ action >>= putMVar resultVar >> return False

69+ takeMVar resultVar

70+

71+-- | Post an action to be run in the main GUI thread.

72+--

73+-- The current thread continues and does not wait for the result of the

74+-- action.

75+--

76+postGUIAsync :: IO () -> IO ()

77+postGUIAsync action = do

78+ idleAdd PRIORITY_DEFAULT $ action >> return False

79+ return ()

54-- | Wrapped version of 'E.catch' that runs in a MonadIO that works

81-- | Wrapped version of 'E.catch' that runs in a MonadIO that works

55-- a bit better with 'JSM'

82-- a bit better with 'JSM'

@@ -101,8 +128,9 @@ runJSaddle _ f = runReaderT f ()

101#else

128#else

102runJSaddle :: WebView -> JSM a -> IO a

129runJSaddle :: WebView -> JSM a -> IO a

103runJSaddle webView f = do

130runJSaddle webView f = do

104− gctxt <- webViewGetMainFrame webView >>= webFrameGetGlobalContext

131+ GlobalContext gctxt <- webViewGetMainFrame webView >>= webFrameGetGlobalContext

132+ withForeignPtr gctxt $ \ptr ->

105− runReaderT f gctxt

133+ runReaderT f (castPtr ptr)

106#endif

134#endif

107{-# INLINE runJSaddle #-}

135{-# INLINE runJSaddle #-}

108

136

src/Language/Javascript/JSaddle/Test.hs+53−19

@@ -1,4 +1,5 @@

1{-# LANGUAGE RecordWildCards #-}

2+{-# LANGUAGE PatternSynonyms #-}

2-----------------------------------------------------------------------------

3-----------------------------------------------------------------------------

3--

4--

4-- Module : TestJSC

5-- Module : TestJSC

@@ -19,21 +20,19 @@ module Language.Javascript.JSaddle.Test (

20import Control.Applicative

21import Control.Applicative

21import Prelude hiding((!!), catch)

22import Prelude hiding((!!), catch)

22−import Graphics.UI.Gtk

23+import GI.Gtk

23− (Window, widgetDestroy, postGUIAsync, postGUISync, widgetShowAll,

24+ (Window, widgetDestroy, widgetShowAll,

24− mainGUI, mainQuit, on, objectDestroy, containerAdd, scrolledWindowNew,

25+ mainQuit, containerAdd, scrolledWindowNew,

25− windowSetPosition, windowSetDefaultSize, timeoutAddFull, windowNew,

26+ windowSetPosition, windowSetDefaultSize, windowNew)

26− initGUI)

27import Control.Concurrent

28 (tryTakeMVar, forkIO, newMVar, putMVar, takeMVar, newEmptyMVar,

29 yield)

30−import System.Glib.MainLoop (priorityLow)

31−import Graphics.UI.Gtk.General.Enums (WindowPosition(..))

30+import GI.Gtk.Enums (WindowType(..), WindowPosition(..))

32−import Graphics.UI.Gtk.WebKit.WebView

31+import GI.WebKit.Objects.WebView

33 (webViewGetMainFrame, webViewNew)

32 (webViewGetMainFrame, webViewNew)

34import System.IO.Unsafe (unsafePerformIO)

33import System.IO.Unsafe (unsafePerformIO)

35import Control.Monad.Trans.Reader (runReaderT)

34import Control.Monad.Trans.Reader (runReaderT)

36−import Graphics.UI.Gtk.WebKit.JavaScriptCore.WebFrame

35+import GI.WebKit.Objects.WebFrame

37 (webFrameGetGlobalContext)

36 (webFrameGetGlobalContext)

38import Language.Javascript.JSaddle

37import Language.Javascript.JSaddle

39import qualified Data.Text as T

38import qualified Data.Text as T

@@ -42,8 +41,40 @@ import Control.Monad (forM, when)

42import Control.Lens.Getter ((^.))

41import Control.Lens.Getter ((^.))

43import Data.Monoid ((<>))

42import Data.Monoid ((<>))

44import Control.Concurrent.MVar (MVar)

43import 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 ()

46−data TestState = TestState { jsContext :: JSContextRef, window :: Window }

77+data TestState = TestState { jsContext :: GlobalContext, window :: Window }

48state :: MVar (Maybe TestState)

79state :: MVar (Maybe TestState)

49state = unsafePerformIO $ newMVar Nothing

80state = unsafePerformIO $ newMVar Nothing

@@ -77,18 +108,18 @@ testJSaddle' showWindow f = do

77 debugLog "fork"

108 debugLog "fork"

78 _ <- forkIO $ do

109 _ <- forkIO $ do

79 debugLog "initGUI"

110 debugLog "initGUI"

80− _ <- initGUI

111+ _ <- Gtk.init Nothing

81 debugLog "windowNew"

112 debugLog "windowNew"

82− window <- windowNew

113+ window <- windowNew WindowTypeToplevel

83 debugLog "timeoutAdd"

114 debugLog "timeoutAdd"

84− _ <- timeoutAddFull (yield >> return True) priorityLow 10

115+ _ <- timeoutAdd PRIORITY_LOW 10 $ yield >> return True

85 windowSetDefaultSize window 900 600

116 windowSetDefaultSize window 900 600

86− windowSetPosition window WinPosCenter

117+ windowSetPosition window WindowPositionCenter

87− scrollWin <- scrolledWindowNew Nothing Nothing

118+ scrollWin <- scrolledWindowNew (Nothing :: Maybe Adjustment) (Nothing :: Maybe Adjustment)

88 webView <- webViewNew

119 webView <- webViewNew

89 window `containerAdd` scrollWin

120 window `containerAdd` scrollWin

90 scrollWin `containerAdd` webView

121 scrollWin `containerAdd` webView

91− _ <- on window objectDestroy $ do

122+ _ <- onWidgetDestroy window $ do

92 debugLog "onDestroy"

123 debugLog "onDestroy"

93 _ <- tryTakeMVar state

124 _ <- tryTakeMVar state

94 debugLog "put state"

125 debugLog "put state"

@@ -105,19 +136,22 @@ testJSaddle' showWindow f = do

105 debugLog "maybe show"

136 debugLog "maybe show"

106 when showWindow $ widgetShowAll window

137 when showWindow $ widgetShowAll window

107 debugLog "mainGUI"

138 debugLog "mainGUI"

108− mainGUI

139+ Gtk.main

109 debugLog "mainGUI exited"

140 debugLog "mainGUI exited"

110 takeMVar newState

141 takeMVar newState

111 Just s@TestState {..} -> do

142 Just s@TestState {..} -> do

112 debugLog "maybe show (2)"

143 debugLog "maybe show (2)"

113 when showWindow . postGUISync $ widgetShowAll window

144 when showWindow . postGUISync $ widgetShowAll window

114 return s

145 return s

115− x <- postGUISync $ runReaderT ((f >>= valToText >>= liftIO . putStrLn . T.unpack)

146+ x <- postGUISync $ withContext jsContext $ runReaderT ((f >>= valToText >>= liftIO . putStrLn . T.unpack)

116− `catch` \ (JSException e) -> valToText e >>= liftIO . putStrLn . T.unpack) jsContext

147+ `catch` \ (JSException e) -> valToText e >>= liftIO . putStrLn . T.unpack)

117 debugLog "put state"

148 debugLog "put state"

118 putMVar state $ Just TestState {..}

149 putMVar state $ Just TestState {..}

119 return x

150 return x

120

151

152+withContext :: GlobalContext -> (JSContextRef -> IO a) -> IO a

153+withContext (GlobalContext fptr) f = withForeignPtr fptr $ f . castPtr

154+

121listWindowProperties :: IO ()

155listWindowProperties :: IO ()

122listWindowProperties = testJSaddle $ T.pack . show <$> do

156listWindowProperties = testJSaddle $ T.pack . show <$> do

123 window <- jsg "window"

157 window <- jsg "window"

tests/DocTest.hs−9

@@ -8,16 +8,7 @@ import Test.DocTest

8main :: IO ()

9main = doctest [

10 "-hide-all-packages",

11−#ifdef VERSION_gtk3

12− "-package=gtk3-" ++ VERSION_gtk3,

13− "-package=webkitgtk3-" ++ VERSION_webkitgtk3,

14 "-package=webkitgtk3-javascriptcore-" ++ VERSION_webkitgtk3_javascriptcore,

11 "-package=webkitgtk3-javascriptcore-" ++ VERSION_webkitgtk3_javascriptcore,

15−#else

16− "-package=gtk-" ++ VERSION_gtk,

17− "-package=webkit-" ++ VERSION_webkit,

18− "-package=webkit-javascriptcore-" ++ VERSION_webkit_javascriptcore,

19−#endif

20− "-package=glib-" ++ VERSION_glib,

21 "-package=template-haskell-" ++ VERSION_template_haskell,

12 "-package=template-haskell-" ++ VERSION_template_haskell,

22 "-package=base-" ++ VERSION_base,

13 "-package=base-" ++ VERSION_base,

23 "-package=lens-" ++ VERSION_lens,

14 "-package=lens-" ++ VERSION_lens,