git.iko.soy/reflex-dom
on develop help sign in
Add getQuitWidget :: MonadWidget m => m (WidgetHost m ())

On non-Windows platforms, install a signal handler to cleanly shut down the gui when Ctrl-C is pressed in the terminal.

commit35ce446401d475e6ce72b152a02295501581d4f4 authorCale Gibbard <cgibbard@gmail.com> dateThu 14 Jan 2016, 19:54 (11 years ago) parent21b7c7e
6 files changed+101−2
compare with develop
unifiedsplit
reflex-dom.cabal+2 src-ghc/Reflex/Dom/Internal/Foreign.hs+17−1 src-ghcjs/Reflex/Dom/Internal/Foreign.hs+4−1 src/Reflex/Dom/Internal.hs+4 test/BrokenHaltSpec.hs+40 test/HaltSpec.hs+34
reflex-dom.cabal+2
@@ -54,6 +54,8 @@ library
5454 gtk3 == 0.13.*,
5555 webkitgtk3 == 0.13.*,
5656 webkitgtk3-javascriptcore == 0.13.*
57+ if !os(windows)
58+ build-depends: unix == 2.7.*
5759
5860 exposed-modules:
5961 Reflex.Dom
src-ghc/Reflex/Dom/Internal/Foreign.hs+17−1
@@ -1,4 +1,4 @@
1−{-# LANGUAGE ForeignFunctionInterface #-}
1+{-# LANGUAGE CPP, ForeignFunctionInterface, ScopedTypeVariables, LambdaCase #-}
22module Reflex.Dom.Internal.Foreign where
33
44import Control.Lens hiding (set)
@@ -22,6 +22,21 @@ import Data.List
2222import System.Directory
2323import System.Glib.FFI hiding (void)
2424
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+
2540makeDefaultWebView :: String -> (WebView -> IO ()) -> IO ()
2641makeDefaultWebView userAgentKey main = do
2742 _ <- initGUI
@@ -57,6 +72,7 @@ makeDefaultWebView userAgentKey main = do
5772 wf <- webViewGetMainFrame webView
5873 pwd <- getCurrentDirectory
5974 webFrameLoadString wf "" Nothing $ "file://" ++ pwd ++ "/"
75+ installQuitHandler webView
6076 mainGUI
6177
6278runWebGUI :: (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
22
33import GHCJS.DOM
44import GHCJS.DOM.Types
55import GHCJS.Types
66import Data.Function
77
8+quitWebView :: WebView -> IO ()
9+quitWebView = error "quitWebView: unimplemented in GHCJS"
10+
811instance Eq Node where
912 (==) = 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
162162-- runWidget :: (Monad m, IsNode n, Reflex t) => n -> Widget t m a -> m (a, Event t (m ()))
163163 getRunWidget = return runWidget
164164
165+getQuitWidget :: (MonadWidget t m) => m (WidgetHost m ())
166+getQuitWidget = return $ do wv <- askWebView
167+ liftIO $ quitWebView wv
168+
165169runWidget :: (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)) ()))
166170runWidget rootElement w = do
167171 (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 ()