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.

commit8479471bfaec585ea74ea93d2f3311473d5db3ed authorCale Gibbard <cgibbard@gmail.com> dateMon 23 Nov 2015, 21:12 (11 years ago) parent89cd4fd
6 files changed+98−4
compare with develop
unifiedsplit
reflex-dom.cabal+2 src-ghc/Reflex/Dom/Internal/Foreign.hs+17−1 src-ghcjs/Reflex/Dom/Internal/Foreign.hs+6−3 src/Reflex/Dom/Internal.hs+4 test/BrokenHaltSpec.hs+40 test/HaltSpec.hs+29
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)
@@ -23,6 +23,21 @@ import Data.List
2323import System.Directory
2424import System.Glib.FFI hiding (void)
2525
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+
2641makeDefaultWebView :: String -> (WebView -> IO ()) -> IO ()
2742makeDefaultWebView userAgentKey main = do
2843 _ <- initGUI
@@ -58,6 +73,7 @@ makeDefaultWebView userAgentKey main = do
5873 wf <- webViewGetMainFrame webView
5974 pwd <- getCurrentDirectory
6075 webFrameLoadString wf "" Nothing $ "file://" ++ pwd ++ "/"
76+ installQuitHandler webView
6177 mainGUI
6278
6379runWebGUI :: (WebView -> IO ()) -> IO ()
src-ghcjs/Reflex/Dom/Internal/Foreign.hs+6−3
@@ -1,7 +1,7 @@
11{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI, CPP #-}
2−
3−module Reflex.Dom.Internal.Foreign ( runWebGUI
4− , module Reflex.Dom.Internal.Foreign
2+module Reflex.Dom.Internal.Foreign ( module Reflex.Dom.Internal.Foreign
3+ , runWebGUI
4+ , quitWebView
55 ) where
66
77import Control.Monad
@@ -13,6 +13,9 @@ import GHCJS.Foreign
1313
1414#define JS(name, js, type) foreign import javascript unsafe js name :: type
1515
16+quitWebView :: WebView -> IO ()
17+quitWebView = error "quitWebView: unimplemented in GHCJS"
18+
1619instance Eq Node where
1720 (==) = eqRef `on` unNode
1821
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+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 ()