develop...35ce446 · reflex-dom

reflex-dom.cabal+2

since splitsnapshots

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)

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

22import System.Directory

23import System.Glib.FFI hiding (void)

24

25+#ifndef mingw32_HOST_OS

26+import System.Posix.Signals

27+#endif

28+

29+quitWebView :: WebView -> IO ()

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

31+ widgetDestroy w

32+

33+installQuitHandler :: WebView -> IO ()

34+#ifdef mingw32_HOST_OS

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

36+#else

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

38+#endif

39+

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

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

26makeDefaultWebView userAgentKey main = do

41makeDefaultWebView userAgentKey main = do

27 _ <- initGUI

42 _ <- initGUI

@@ -57,6 +72,7 @@ makeDefaultWebView userAgentKey main = do

57 wf <- webViewGetMainFrame webView

72 wf <- webViewGetMainFrame webView

58 pwd <- getCurrentDirectory

73 pwd <- getCurrentDirectory

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

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

75+ installQuitHandler webView

60 mainGUI

76 mainGUI

61

77

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

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

src-ghcjs/Reflex/Dom/Internal/Foreign.hs+4−1

@@ -1,9 +1,12 @@

1−module Reflex.Dom.Internal.Foreign (runWebGUI) where

1+module Reflex.Dom.Internal.Foreign (runWebGUI, quitWebView) where

2

3import GHCJS.DOM

4import GHCJS.DOM.Types

5import GHCJS.Types

6import Data.Function

7

8+quitWebView :: WebView -> IO ()

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

10+

8instance Eq Node where

11instance Eq Node where

9 (==) = eqRef `on` unNode

12 (==) = eqRef `on` unNode

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+34

@@ -0,0 +1,34 @@

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+import Test.Hspec

10+

11+main = hspec spec

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 .. 1000] $ \ i -> do

21+ getFirstEventAndHalt return `shouldReturn` ()

22+

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

24+

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

26+getFirstEventAndHalt action = do

27+ _ <- mainWidget $ do

28+ tick <- getPostBuild

29+ event <- action tick

30+ webView <- askWebView

31+ quit <- getQuitWidget

32+ performEvent_ (quit <$ event)

33+ return ()

34+ return ()