8479471 · reflex-dom · git.iko.soy

reflex-dom.cabal+2

compare with develop

unifiedsplit

@@ -54,6 +54,8 @@ library

54 gtk3 == 0.13.*,

55 webkitgtk3 == 0.13.*,

56 webkitgtk3-javascriptcore == 0.13.*

57+ if !os(windows)

58+ build-depends: unix == 2.7.*

57

59

58 exposed-modules:

60 exposed-modules:

59 Reflex.Dom

61 Reflex.Dom

src-ghc/Reflex/Dom/Internal/Foreign.hs+17−1

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

1−{-# LANGUAGE ForeignFunctionInterface #-}

1+{-# LANGUAGE CPP, ForeignFunctionInterface, ScopedTypeVariables, LambdaCase #-}

2module Reflex.Dom.Internal.Foreign where

3

4import Control.Lens hiding (set)

@@ -23,6 +23,21 @@ import Data.List

23import System.Directory

24import System.Glib.FFI hiding (void)

25

26+#ifndef mingw32_HOST_OS

27+import System.Posix.Signals

28+#endif

29+

30+quitWebView :: WebView -> IO ()

31+quitWebView wv = postGUIAsync $ do w <- widgetGetToplevel wv

32+ widgetDestroy w

33+

34+installQuitHandler :: WebView -> IO ()

35+#ifdef mingw32_HOST_OS

36+installQuitHandler wv = return () -- TODO: Maybe figure something out here for Windows users.

37+#else

38+installQuitHandler wv = installHandler keyboardSignal (Catch (quitWebView wv)) Nothing >> return ()

39+#endif

40+

26makeDefaultWebView :: String -> (WebView -> IO ()) -> IO ()

41makeDefaultWebView :: String -> (WebView -> IO ()) -> IO ()

27makeDefaultWebView userAgentKey main = do

42makeDefaultWebView userAgentKey main = do

28 _ <- initGUI

43 _ <- initGUI

@@ -58,6 +73,7 @@ makeDefaultWebView userAgentKey main = do

58 wf <- webViewGetMainFrame webView

73 wf <- webViewGetMainFrame webView

59 pwd <- getCurrentDirectory

74 pwd <- getCurrentDirectory

60 webFrameLoadString wf "" Nothing $ "file://" ++ pwd ++ "/"

75 webFrameLoadString wf "" Nothing $ "file://" ++ pwd ++ "/"

76+ installQuitHandler webView

61 mainGUI

77 mainGUI

62

78

63runWebGUI :: (WebView -> IO ()) -> IO ()

79runWebGUI :: (WebView -> IO ()) -> IO ()

src-ghcjs/Reflex/Dom/Internal/Foreign.hs+6−3

@@ -1,7 +1,7 @@

1{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI, CPP #-}

2−

3−module Reflex.Dom.Internal.Foreign ( runWebGUI

2+module Reflex.Dom.Internal.Foreign ( module Reflex.Dom.Internal.Foreign

4− , module Reflex.Dom.Internal.Foreign

3+ , runWebGUI

4+ , quitWebView

5 ) where

6

7import Control.Monad

@@ -13,6 +13,9 @@ import GHCJS.Foreign

13

14#define JS(name, js, type) foreign import javascript unsafe js name :: type

15

16+quitWebView :: WebView -> IO ()

17+quitWebView = error "quitWebView: unimplemented in GHCJS"

18+

16instance Eq Node where

19instance Eq Node where

17 (==) = eqRef `on` unNode

20 (==) = eqRef `on` unNode

18

21

src/Reflex/Dom/Internal.hs+4

@@ -162,6 +162,10 @@ instance ( MonadRef m, Ref m ~ Ref IO, MonadRef h, Ref h ~ Ref IO --TODO: Should

162-- runWidget :: (Monad m, IsNode n, Reflex t) => n -> Widget t m a -> m (a, Event t (m ()))

163 getRunWidget = return runWidget

164

165+getQuitWidget :: MonadWidget t m => m (WidgetHost m ())

166+getQuitWidget = return $ do wv <- askWebView

167+ liftIO $ quitWebView wv

168+

165runWidget :: (Monad m, Reflex t, IsNode n) => n -> Widget t (Gui t h m) a -> WidgetHost (Widget t (Gui t h m)) (a, WidgetHost (Widget t (Gui t h m)) (), Event t (WidgetHost (Widget t (Gui t h m)) ()))

169runWidget :: (Monad m, Reflex t, IsNode n) => n -> Widget t (Gui t h m) a -> WidgetHost (Widget t (Gui t h m)) (a, WidgetHost (Widget t (Gui t h m)) (), Event t (WidgetHost (Widget t (Gui t h m)) ()))

166runWidget rootElement w = do

170runWidget rootElement w = do

167 (result, WidgetState postBuild voidActions) <- runStateT (runReaderT (unWidget w) (WidgetEnv $ toNode rootElement)) (WidgetState (return ()) [])

171 (result, WidgetState postBuild voidActions) <- runStateT (runReaderT (unWidget w) (WidgetEnv $ toNode rootElement)) (WidgetState (return ()) [])

test/BrokenHaltSpec.hsnew file+40

@@ -0,0 +1,40 @@

1+{-# LANGUAGE FlexibleContexts #-}

2+

3+module HaltSpec where

4+

5+import Control.Monad.IO.Class

6+import Data.Foldable

7+import GHCJS.DOM

8+import qualified Graphics.UI.Gtk as Gtk

9+import Reflex.Dom

10+import Reflex.Spider.Internal (SpiderHostFrame)

11+import Test.Hspec

12+

13+spec :: Spec

14+spec = do

15+ describe "haltGui" $ do

16+ it "works" $ do

17+ getFirstEventAndHalt return `shouldReturn` ()

18+

19+ it "works multiple times" $ do

20+ forM_ [1 .. 100] $ \ i -> do

21+ getFirstEventAndHalt return `shouldReturn` ()

22+

23+type SpiderM =

24+ Widget Spider (Gui Spider (WithWebView SpiderHost) SpiderHostFrame)

25+

26+getFirstEventAndHalt :: (Event Spider () -> SpiderM (Event Spider ())) -> IO ()

27+getFirstEventAndHalt action = do

28+ _ <- mainWidget $ do

29+ tick <- getPostBuild

30+ event <- action tick

31+ webView <- askWebView

32+ _ <- foldDynM (\ a () -> liftIO $ haltGui webView) () event

33+ return ()

34+ return ()

35+

36+haltGui :: WebView -> IO ()

37+haltGui wv = do

38+ Gtk.postGUIAsync $ do

39+ w <- Gtk.widgetGetToplevel wv

40+ Gtk.widgetDestroy w

test/HaltSpec.hsnew file+29

@@ -0,0 +1,29 @@

1+{-# LANGUAGE FlexibleContexts #-}

2+

3+import Control.Monad.IO.Class

4+import Data.Foldable

5+import GHCJS.DOM

6+import qualified Graphics.UI.Gtk as Gtk

7+import Reflex.Dom

8+import Reflex.Spider.Internal (SpiderHostFrame)

9+

10+main = do

11+ getFirstEventAndHalt return

12+ putStrLn "stopped once"

13+

14+ forM_ [1 .. 1000] $ \ i -> do

15+ getFirstEventAndHalt return

16+ putStrLn "stopped many times"

17+

18+type SpiderM = Widget Spider (Gui Spider (WithWebView SpiderHost) SpiderHostFrame)

19+

20+getFirstEventAndHalt :: (Event Spider () -> SpiderM (Event Spider ())) -> IO ()

21+getFirstEventAndHalt action = do

22+ _ <- mainWidget $ do

23+ tick <- getPostBuild

24+ event <- action tick

25+ webView <- askWebView

26+ quit <- getQuitWidget

27+ performEvent_ (quit <$ event)

28+ return ()

29+ return ()