d87cf28 · reflex-dom · git.iko.soy

reflex-dom.cabal+4

compare with develop

unifiedsplit

@@ -15,6 +15,7 @@ extra-source-files: src-ghc/Reflex/Dom/Internal/Foreign.hs

15 src-ghc/Reflex/Dom/Xhr/Foreign.hs

16 src-ghcjs/Reflex/Dom/Internal/Foreign.hs

17 src-ghcjs/Reflex/Dom/Xhr/Foreign.hs

18+ src/Reflex/Dom/Xhr/ResponseType.hs

18

19

19library

20library

20 hs-source-dirs: src

21 hs-source-dirs: src

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

53 gtk3 >= 0.13.0 && < 0.15,

54 gtk3 >= 0.13.0 && < 0.15,

54 webkitgtk3 == 0.14.*,

55 webkitgtk3 == 0.14.*,

55 webkitgtk3-javascriptcore == 0.13.*

56 webkitgtk3-javascriptcore == 0.13.*

57+ if !os(windows)

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

56

59

57 exposed-modules:

60 exposed-modules:

58 Reflex.Dom

61 Reflex.Dom

@@ -71,6 +74,7 @@ library

71 Reflex.Dom.Internal.Foreign

74 Reflex.Dom.Internal.Foreign

72 Reflex.Dom.WebSocket.Foreign

75 Reflex.Dom.WebSocket.Foreign

73 Reflex.Dom.Xhr.Foreign

76 Reflex.Dom.Xhr.Foreign

77+ Reflex.Dom.Xhr.ResponseType

74

78

75 other-extensions: TemplateHaskell

79 other-extensions: TemplateHaskell

76 ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 -ferror-spans

80 ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 -ferror-spans

src-ghc/Reflex/Dom/Internal/Foreign.hs+18−2

@@ -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)

@@ -15,7 +15,7 @@ import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSStringRef

15import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSValueRef

16import Graphics.UI.Gtk.WebKit.JavaScriptCore.WebFrame

17import Graphics.UI.Gtk.WebKit.WebView

18−import Graphics.UI.Gtk.WebKit.Types hiding (Event, Widget, unWidget)

18+import Graphics.UI.Gtk.WebKit.Types hiding (Event, Widget)

19import Graphics.UI.Gtk.WebKit.WebSettings

20import Graphics.UI.Gtk.WebKit.WebFrame

21import Graphics.UI.Gtk.WebKit.WebInspector

@@ -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-ghc/Reflex/Dom/Xhr/Foreign.hs+20−17

@@ -1,10 +1,8 @@

1{-# LANGUAGE ForeignFunctionInterface #-}

2module Reflex.Dom.Xhr.Foreign where

3

4−import Control.Lens.Indexed

5import qualified Data.Text as T

4import qualified Data.Text as T

6import Data.Text (Text)

5import Data.Text (Text)

7−import Data.Typeable (Typeable)

8import System.Glib.FFI

6import System.Glib.FFI

9import Graphics.UI.Gtk.WebKit.WebView

7import Graphics.UI.Gtk.WebKit.WebView

10import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSBase

8import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSBase

@@ -12,6 +10,7 @@ import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSObjectRef

12import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSStringRef

10import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSStringRef

13import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSValueRef

11import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSValueRef

14import Graphics.UI.Gtk.WebKit.JavaScriptCore.WebFrame

12import Graphics.UI.Gtk.WebKit.JavaScriptCore.WebFrame

13+import Reflex.Dom.Xhr.ResponseType

15

14

16import Reflex.Dom.Internal.Foreign

15import Reflex.Dom.Internal.Foreign

17

16

@@ -21,6 +20,8 @@ data XMLHttpRequest

21 }

20 }

22 deriving (Eq, Ord)

21 deriving (Eq, Ord)

23

22

23+data XhrResponseBody = XhrResponseBody { unXhrResponseBody :: JSValueRef }

24+

24responseTextToText :: Maybe String -> Maybe Text

25responseTextToText :: Maybe String -> Maybe Text

25responseTextToText = fmap T.pack

26responseTextToText = fmap T.pack

26

27

@@ -30,21 +31,13 @@ statusTextToText = T.pack

30stringToJSValue :: JSContextRef -> String -> IO JSValueRef

31stringToJSValue :: JSContextRef -> String -> IO JSValueRef

31stringToJSValue ctx s = jsvaluemakestring ctx =<< jsstringcreatewithutf8cstring s

32stringToJSValue ctx s = jsvaluemakestring ctx =<< jsstringcreatewithutf8cstring s

32

33

33−data XMLHttpRequestResponseType = XMLHttpRequestResponseType

34− | XMLHttpRequestResponseTypeArraybuffer

35− | XMLHttpRequestResponseTypeBlob

36− | XMLHttpRequestResponseTypeDocument

37− | XMLHttpRequestResponseTypeJson

38− | XMLHttpRequestResponseTypeText

39− deriving (Show, Read, Eq, Ord, Typeable)

40−

41−toResponseType :: XMLHttpRequestResponseType -> String

34+toResponseType :: XhrResponseType -> String

42−toResponseType XMLHttpRequestResponseType = ""

35+toResponseType XhrResponseType_Default = ""

43−toResponseType XMLHttpRequestResponseTypeArraybuffer = "arraybuffer"

36+toResponseType XhrResponseType_ArrayBuffer = "arraybuffer"

44−toResponseType XMLHttpRequestResponseTypeBlob = "blob"

37+toResponseType XhrResponseType_Blob = "blob"

45−toResponseType XMLHttpRequestResponseTypeDocument = "document"

38+toResponseType XhrResponseType_Document = "document"

46−toResponseType XMLHttpRequestResponseTypeJson = "json"

39+toResponseType XhrResponseType_JSON = "json"

47−toResponseType XMLHttpRequestResponseTypeText = "text"

40+toResponseType XhrResponseType_Text = "text"

48

41

49xmlHttpRequestNew :: WebView -> IO XMLHttpRequest

42xmlHttpRequestNew :: WebView -> IO XMLHttpRequest

50xmlHttpRequestNew wv = do

43xmlHttpRequestNew wv = do

@@ -88,6 +81,16 @@ xmlHttpRequestGetReadyState xhr = do

88 d <- jsvaluetonumber c rs nullPtr

81 d <- jsvaluetonumber c rs nullPtr

89 return $ truncate d

82 return $ truncate d

90

83

84+xmlHttpRequestGetResponse :: XMLHttpRequest -> IO (Maybe XhrResponseBody)

85+xmlHttpRequestGetResponse xhr = do

86+ let c = xhrContext xhr

87+ script <- jsstringcreatewithutf8cstring "this.response"

88+ t <- jsevaluatescript c script (xhrValue xhr) nullPtr 1 nullPtr

89+ isNull <- jsvalueisnull c t

90+ case isNull of

91+ True -> return Nothing

92+ False -> return $ Just $ XhrResponseBody t

93+

91xmlHttpRequestGetResponseText :: XMLHttpRequest -> IO (Maybe String)

94xmlHttpRequestGetResponseText :: XMLHttpRequest -> IO (Maybe String)

92xmlHttpRequestGetResponseText xhr = do

95xmlHttpRequestGetResponseText xhr = do

93 let c = xhrContext xhr

96 let c = xhrContext xhr

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

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

1{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI #-}

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

5 ) where

4 ) where

6

5

7import Control.Monad

6import Control.Monad

@@ -9,6 +8,9 @@ import GHCJS.DOM

9import GHCJS.DOM.Types

8import GHCJS.DOM.Types

10import GHCJS.Types

9import GHCJS.Types

11

10

11+quitWebView :: WebView -> IO ()

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

13+

12foreign import javascript unsafe "location['host']" getLocationHost_ :: IO JSString

14foreign import javascript unsafe "location['host']" getLocationHost_ :: IO JSString

13

15

14getLocationHost :: FromJSString r => a -> IO r

16getLocationHost :: FromJSString r => a -> IO r

src-ghcjs/Reflex/Dom/Xhr/Foreign.hs+18−4

@@ -2,7 +2,7 @@

2

3module Reflex.Dom.Xhr.Foreign (

4 XMLHttpRequest

5− , XMLHttpRequestResponseType

5+ , XMLHttpRequestResponseType(..)

6 , module Reflex.Dom.Xhr.Foreign

7) where

8

@@ -15,12 +15,16 @@ import GHCJS.DOM.XMLHttpRequest

15import Data.Maybe (fromMaybe)

16import GHCJS.DOM.EventTarget (dispatchEvent)

17import GHCJS.DOM.EventM (EventM, on)

18+import GHCJS.Types

19+import Reflex.Dom.Xhr.ResponseType

20+

21+data XhrResponseBody = XhrResponseBody { unXhrResponseBody :: JSVal }

18

22

19prepareWebView :: WebView -> IO ()

23prepareWebView :: WebView -> IO ()

20prepareWebView _ = return ()

24prepareWebView _ = return ()

21

25

22xmlHttpRequestNew :: a -> IO XMLHttpRequest

26xmlHttpRequestNew :: a -> IO XMLHttpRequest

23−xmlHttpRequestNew _ = newXMLHttpRequest -- XMLHttpRequest <$> ghcjs_dom_xml_http_request_new

27+xmlHttpRequestNew _ = newXMLHttpRequest

24

28

25xmlHttpRequestOpen ::

29xmlHttpRequestOpen ::

26 (ToJSString method, ToJSString url, ToJSString user, ToJSString password) =>

30 (ToJSString method, ToJSString url, ToJSString user, ToJSString password) =>

@@ -105,8 +109,13 @@ xmlHttpRequestGetResponseXML = getResponseXML

105xmlHttpRequestSetResponseType :: XMLHttpRequest -> XMLHttpRequestResponseType -> IO ()

109xmlHttpRequestSetResponseType :: XMLHttpRequest -> XMLHttpRequestResponseType -> IO ()

106xmlHttpRequestSetResponseType = setResponseType

110xmlHttpRequestSetResponseType = setResponseType

107

111

108−toResponseType :: a -> a

112+toResponseType :: XhrResponseType -> XMLHttpRequestResponseType

109−toResponseType = id

113+toResponseType XhrResponseType_Default = XMLHttpRequestResponseType

114+toResponseType XhrResponseType_ArrayBuffer = XMLHttpRequestResponseTypeArraybuffer

115+toResponseType XhrResponseType_Blob = XMLHttpRequestResponseTypeBlob

116+toResponseType XhrResponseType_Document = XMLHttpRequestResponseTypeDocument

117+toResponseType XhrResponseType_JSON = XMLHttpRequestResponseTypeJson

118+toResponseType XhrResponseType_Text = XMLHttpRequestResponseTypeText

110

119

111xmlHttpRequestGetResponseType :: XMLHttpRequest -> IO XMLHttpRequestResponseType

120xmlHttpRequestGetResponseType :: XMLHttpRequest -> IO XMLHttpRequestResponseType

112xmlHttpRequestGetResponseType = getResponseType

121xmlHttpRequestGetResponseType = getResponseType

@@ -120,5 +129,10 @@ xmlHttpRequestGetStatusText = getStatusText

120xmlHttpRequestGetResponseURL :: FromJSString result => XMLHttpRequest -> IO result

129xmlHttpRequestGetResponseURL :: FromJSString result => XMLHttpRequest -> IO result

121xmlHttpRequestGetResponseURL = getResponseURL

130xmlHttpRequestGetResponseURL = getResponseURL

122

131

132+xmlHttpRequestGetResponse :: XMLHttpRequest -> IO (Maybe XhrResponseBody)

133+xmlHttpRequestGetResponse xhr = do

134+ mr <- getResponse xhr

135+ return $ fmap (\(GObject r) -> XhrResponseBody r) mr

136+

123statusTextToText :: Text -> Text

137statusTextToText :: Text -> Text

124statusTextToText = id

138statusTextToText = id

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 ()) [])

src/Reflex/Dom/Widget/Basic.hs+9

@@ -330,6 +330,15 @@ deleteBetweenInclusive s e = do

330 _ <- removeChild currentParent $ Just e

331 return ()

332

333+nodeClear :: IsNode self => self -> IO ()

334+nodeClear n = do

335+ mfc <- getFirstChild n

336+ case mfc of

337+ Nothing -> return ()

338+ Just fc -> do

339+ _ <- removeChild n $ Just fc

340+ nodeClear n

341+

333--------------------------------------------------------------------------------

342--------------------------------------------------------------------------------

334-- Adapters

343-- Adapters

335--------------------------------------------------------------------------------

344--------------------------------------------------------------------------------

src/Reflex/Dom/Widget/Resize.hs+1−1

@@ -8,7 +8,7 @@ import Reflex.Dom.Widget.Basic

8import Control.Monad

9import Control.Monad.IO.Class

10import Data.Monoid

11−import GHCJS.DOM.Element

11+import GHCJS.DOM.Element hiding (reset)

12import GHCJS.DOM.EventM (on)

13

14-- | A widget that wraps the given widget in a div and fires an event when resized.

src/Reflex/Dom/Xhr.hs+28−8

@@ -3,6 +3,8 @@

3module Reflex.Dom.Xhr

4 ( module Reflex.Dom.Xhr

5 , XMLHttpRequest

6+ , XhrResponseBody(..)

7+ , XhrResponseType(..)

6 , responseTextToText

8 , responseTextToText

7 , xmlHttpRequestGetReadyState

9 , xmlHttpRequestGetReadyState

8 , xmlHttpRequestGetResponseText

10 , xmlHttpRequestGetResponseText

@@ -36,6 +38,7 @@ import Data.Traversable

36import Reflex

38import Reflex

37import Reflex.Dom.Class

39import Reflex.Dom.Class

38import Reflex.Dom.Xhr.Foreign

40import Reflex.Dom.Xhr.Foreign

41+import Reflex.Dom.Xhr.ResponseType

39import Data.Typeable

42import Data.Typeable

40

43

41data XhrRequest

44data XhrRequest

@@ -49,17 +52,26 @@ data XhrRequestConfig

49 = XhrRequestConfig { _xhrRequestConfig_headers :: Map String String

52 = XhrRequestConfig { _xhrRequestConfig_headers :: Map String String

50 , _xhrRequestConfig_user :: Maybe String

53 , _xhrRequestConfig_user :: Maybe String

51 , _xhrRequestConfig_password :: Maybe String

54 , _xhrRequestConfig_password :: Maybe String

52− , _xhrRequestConfig_responseType :: Maybe XMLHttpRequestResponseType

55+ , _xhrRequestConfig_responseType :: Maybe XhrResponseType

53 , _xhrRequestConfig_sendData :: Maybe String

56 , _xhrRequestConfig_sendData :: Maybe String

54 }

57 }

55 deriving (Show, Read, Eq, Ord, Typeable)

58 deriving (Show, Read, Eq, Ord, Typeable)

56

59

57data XhrResponse

60data XhrResponse

58− = XhrResponse { _xhrResponse_body :: Maybe Text

59− , _xhrResponse_status :: Word

61+ = XhrResponse { _xhrResponse_status :: Word

60 , _xhrResponse_statusText :: Text

62 , _xhrResponse_statusText :: Text

63+ , _xhrResponse_response :: Maybe XhrResponseBody

64+ , _xhrResponse_responseText :: Maybe Text

61 }

65 }

62− deriving (Show, Read, Eq, Ord, Typeable)

66+ deriving (Typeable)

67+

68+{-# DEPRECATED _xhrResponse_body "Use _xhrResponse_response or _xhrResponse_responseText instead." #-}

69+_xhrResponse_body :: XhrResponse -> Maybe Text

70+_xhrResponse_body = _xhrResponse_responseText

71+

72+{-# DEPRECATED xhrResponse_body "Use xhrResponse_response or xhrResponse_responseText instead." #-}

73+xhrResponse_body :: Lens XhrResponse XhrResponse (Maybe Text) (Maybe Text)

74+xhrResponse_body = lens _xhrResponse_responseText (\r t -> r { _xhrResponse_responseText = t })

63

75

64instance Default XhrRequestConfig where

76instance Default XhrRequestConfig where

65 def = XhrRequestConfig { _xhrRequestConfig_headers = Map.empty

77 def = XhrRequestConfig { _xhrRequestConfig_headers = Map.empty

@@ -80,6 +92,7 @@ newXMLHttpRequest req cb = do

80 liftIO $ do

92 liftIO $ do

81 xhr <- xmlHttpRequestNew wv

93 xhr <- xmlHttpRequestNew wv

82 let c = _xhrRequest_config req

94 let c = _xhrRequest_config req

95+ rt = _xhrRequestConfig_responseType c

83 xmlHttpRequestOpen

96 xmlHttpRequestOpen

84 xhr

97 xhr

85 (_xhrRequest_method req)

98 (_xhrRequest_method req)

@@ -88,15 +101,22 @@ newXMLHttpRequest req cb = do

88 (fromMaybe "" $ _xhrRequestConfig_user c)

101 (fromMaybe "" $ _xhrRequestConfig_user c)

89 (fromMaybe "" $ _xhrRequestConfig_password c)

102 (fromMaybe "" $ _xhrRequestConfig_password c)

90 iforM_ (_xhrRequestConfig_headers c) $ xmlHttpRequestSetRequestHeader xhr

103 iforM_ (_xhrRequestConfig_headers c) $ xmlHttpRequestSetRequestHeader xhr

91− maybe (return ()) (xmlHttpRequestSetResponseType xhr . toResponseType) (_xhrRequestConfig_responseType c)

104+ maybe (return ()) (xmlHttpRequestSetResponseType xhr . toResponseType) rt

92 _ <- xmlHttpRequestOnreadystatechange xhr $ do

105 _ <- xmlHttpRequestOnreadystatechange xhr $ do

93 readyState <- liftIO $ xmlHttpRequestGetReadyState xhr

106 readyState <- liftIO $ xmlHttpRequestGetReadyState xhr

94 status <- liftIO $ xmlHttpRequestGetStatus xhr

107 status <- liftIO $ xmlHttpRequestGetStatus xhr

95 statusText <- liftIO $ xmlHttpRequestGetStatusText xhr

108 statusText <- liftIO $ xmlHttpRequestGetStatusText xhr

96 if readyState == 4

109 if readyState == 4

97 then do

110 then do

111+ t <- if rt == Just XhrResponseType_Text || rt == Nothing

98− r <- liftIO $ xmlHttpRequestGetResponseText xhr

112+ then liftIO $ xmlHttpRequestGetResponseText xhr

113+ else return Nothing

114+ r <- liftIO $ xmlHttpRequestGetResponse xhr

99− _ <- liftIO $ postGui $ cb $ XhrResponse (responseTextToText r) status (statusTextToText statusText)

115+ _ <- liftIO $ postGui $ cb $ XhrResponse { _xhrResponse_status = status

116+ , _xhrResponse_statusText = statusTextToText statusText

117+ , _xhrResponse_response = r

118+ , _xhrResponse_responseText = responseTextToText t

119+ }

100 return ()

120 return ()

101 else return ()

121 else return ()

102 _ <- xmlHttpRequestSend xhr (_xhrRequestConfig_sendData c)

122 _ <- xmlHttpRequestSend xhr (_xhrRequestConfig_sendData c)

@@ -143,5 +163,5 @@ decodeText = decode . BL.fromStrict . encodeUtf8

143

163

144-- | Convenience function to decode JSON-encoded responses.

164-- | Convenience function to decode JSON-encoded responses.

145decodeXhrResponse :: FromJSON a => XhrResponse -> Maybe a

165decodeXhrResponse :: FromJSON a => XhrResponse -> Maybe a

146−decodeXhrResponse = join . fmap decodeText . _xhrResponse_body

166+decodeXhrResponse = join . fmap decodeText . _xhrResponse_responseText

147

167

src/Reflex/Dom/Xhr/ResponseType.hsnew file+14

@@ -0,0 +1,14 @@

1+{-# LANGUAGE DeriveDataTypeable #-}

2+

3+module Reflex.Dom.Xhr.ResponseType where

4+

5+import Data.Typeable

6+

7+data XhrResponseType = XhrResponseType_Default

8+ | XhrResponseType_ArrayBuffer

9+ | XhrResponseType_Blob

10+ | XhrResponseType_Document

11+ | XhrResponseType_JSON

12+ | XhrResponseType_Text

13+ deriving (Show, Read, Eq, Ord, Typeable)

14+

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