d87cf28 · reflex-dom · git.iko.soy

git.iko.soy/reflex-dom

Merge branch 'develop' into ghcjs-improved-base-2

Conflicts: src-ghcjs/Reflex/Dom/Internal/Foreign.hs src-ghcjs/Reflex/Dom/Xhr/Foreign.hs src/Reflex/Dom/Xhr.hs

commitd87cf2816a4d07985e9c2f2f59a8f0e4a10cb477 authorAli Abrar <aliabrar@gmail.com> dateThu 14 Jan 2016, 20:58 (11 years ago) parent6ce4728 e0f35ae

12 files changed+190−35

compare with develop

unifiedsplit

reflex-dom.cabal+4 src-ghc/Reflex/Dom/Internal/Foreign.hs+18−2 src-ghc/Reflex/Dom/Xhr/Foreign.hs+20−17 src-ghcjs/Reflex/Dom/Internal/Foreign.hs+5−3 src-ghcjs/Reflex/Dom/Xhr/Foreign.hs+18−4 src/Reflex/Dom/Internal.hs+4 src/Reflex/Dom/Widget/Basic.hs+9 src/Reflex/Dom/Widget/Resize.hs+1−1 src/Reflex/Dom/Xhr.hs+28−8 src/Reflex/Dom/Xhr/ResponseType.hs+14 test/BrokenHaltSpec.hs+40 test/HaltSpec.hs+29

reflex-dom.cabal+4

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

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

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

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

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

1819

1920library

2021 hs-source-dirs: src

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

5354 gtk3 >= 0.13.0 && < 0.15,

5455 webkitgtk3 == 0.14.*,

5556 webkitgtk3-javascriptcore == 0.13.*

57+ if !os(windows)

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

5659

5760 exposed-modules:

5861 Reflex.Dom

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

7174 Reflex.Dom.Internal.Foreign

7275 Reflex.Dom.WebSocket.Foreign

7376 Reflex.Dom.Xhr.Foreign

77+ Reflex.Dom.Xhr.ResponseType

7478

7579 other-extensions: TemplateHaskell

7680 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 #-}

22module Reflex.Dom.Internal.Foreign where

44import Control.Lens hiding (set)

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

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

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

1717import 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)

1919import Graphics.UI.Gtk.WebKit.WebSettings

2020import Graphics.UI.Gtk.WebKit.WebFrame

2121import Graphics.UI.Gtk.WebKit.WebInspector

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

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

11{-# LANGUAGE ForeignFunctionInterface #-}

22module Reflex.Dom.Xhr.Foreign where

4−import Control.Lens.Indexed

54import qualified Data.Text as T

65import Data.Text (Text)

7−import Data.Typeable (Typeable)

86import System.Glib.FFI

97import Graphics.UI.Gtk.WebKit.WebView

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

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

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

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

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

13+import Reflex.Dom.Xhr.ResponseType

1514

1615import Reflex.Dom.Internal.Foreign

1716

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

2120 }

2221 deriving (Eq, Ord)

2322

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

24+

2425responseTextToText :: Maybe String -> Maybe Text

2526responseTextToText = fmap T.pack

2627

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

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

3132stringToJSValue ctx s = jsvaluemakestring ctx =<< jsstringcreatewithutf8cstring s

3233

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

42−toResponseType XMLHttpRequestResponseType = ""

43−toResponseType XMLHttpRequestResponseTypeArraybuffer = "arraybuffer"

44−toResponseType XMLHttpRequestResponseTypeBlob = "blob"

45−toResponseType XMLHttpRequestResponseTypeDocument = "document"

46−toResponseType XMLHttpRequestResponseTypeJson = "json"

47−toResponseType XMLHttpRequestResponseTypeText = "text"

34+toResponseType :: XhrResponseType -> String

35+toResponseType XhrResponseType_Default = ""

36+toResponseType XhrResponseType_ArrayBuffer = "arraybuffer"

37+toResponseType XhrResponseType_Blob = "blob"

38+toResponseType XhrResponseType_Document = "document"

39+toResponseType XhrResponseType_JSON = "json"

40+toResponseType XhrResponseType_Text = "text"

4841

4942xmlHttpRequestNew :: WebView -> IO XMLHttpRequest

5043xmlHttpRequestNew wv = do

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

8881 d <- jsvaluetonumber c rs nullPtr

8982 return $ truncate d

9083

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+

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

9295xmlHttpRequestGetResponseText xhr = do

9396 let c = xhrContext xhr

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

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

11{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI #-}

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

54 ) where

76import Control.Monad

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

98import GHCJS.DOM.Types

109import GHCJS.Types

1110

11+quitWebView :: WebView -> IO ()

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

13+

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

1315

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

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

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

33module Reflex.Dom.Xhr.Foreign (

44 XMLHttpRequest

5− , XMLHttpRequestResponseType

5+ , XMLHttpRequestResponseType(..)

66 , module Reflex.Dom.Xhr.Foreign

77) where

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

1515import Data.Maybe (fromMaybe)

1616import GHCJS.DOM.EventTarget (dispatchEvent)

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

18+import GHCJS.Types

19+import Reflex.Dom.Xhr.ResponseType

20+

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

1822

1923prepareWebView :: WebView -> IO ()

2024prepareWebView _ = return ()

2125

2226xmlHttpRequestNew :: a -> IO XMLHttpRequest

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

27+xmlHttpRequestNew _ = newXMLHttpRequest

2428

2529xmlHttpRequestOpen ::

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

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

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

106110xmlHttpRequestSetResponseType = setResponseType

107111

108−toResponseType :: a -> a

109−toResponseType = id

112+toResponseType :: XhrResponseType -> XMLHttpRequestResponseType

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

110119

111120xmlHttpRequestGetResponseType :: XMLHttpRequest -> IO XMLHttpRequestResponseType

112121xmlHttpRequestGetResponseType = getResponseType

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

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

121130xmlHttpRequestGetResponseURL = getResponseURL

122131

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

133+xmlHttpRequestGetResponse xhr = do

134+ mr <- getResponse xhr

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

136+

123137statusTextToText :: Text -> Text

124138statusTextToText = 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

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

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

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

330330 _ <- removeChild currentParent $ Just e

331331 return ()

332332

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+

333342--------------------------------------------------------------------------------

334343-- Adapters

335344--------------------------------------------------------------------------------

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

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

88import Control.Monad

99import Control.Monad.IO.Class

1010import Data.Monoid

11−import GHCJS.DOM.Element

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

1212import GHCJS.DOM.EventM (on)

1313

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

33module Reflex.Dom.Xhr

44 ( module Reflex.Dom.Xhr

55 , XMLHttpRequest

6+ , XhrResponseBody(..)

7+ , XhrResponseType(..)

68 , responseTextToText

79 , xmlHttpRequestGetReadyState

810 , xmlHttpRequestGetResponseText

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

3638import Reflex

3739import Reflex.Dom.Class

3840import Reflex.Dom.Xhr.Foreign

41+import Reflex.Dom.Xhr.ResponseType

3942import Data.Typeable

4043

4144data XhrRequest

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

4952 = XhrRequestConfig { _xhrRequestConfig_headers :: Map String String

5053 , _xhrRequestConfig_user :: Maybe String

5154 , _xhrRequestConfig_password :: Maybe String

52− , _xhrRequestConfig_responseType :: Maybe XMLHttpRequestResponseType

55+ , _xhrRequestConfig_responseType :: Maybe XhrResponseType

5356 , _xhrRequestConfig_sendData :: Maybe String

5457 }

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

5659

5760data XhrResponse

58− = XhrResponse { _xhrResponse_body :: Maybe Text

59− , _xhrResponse_status :: Word

61+ = XhrResponse { _xhrResponse_status :: Word

6062 , _xhrResponse_statusText :: Text

63+ , _xhrResponse_response :: Maybe XhrResponseBody

64+ , _xhrResponse_responseText :: Maybe Text

6165 }

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

6375

6476instance Default XhrRequestConfig where

6577 def = XhrRequestConfig { _xhrRequestConfig_headers = Map.empty

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

8092 liftIO $ do

8193 xhr <- xmlHttpRequestNew wv

8294 let c = _xhrRequest_config req

95+ rt = _xhrRequestConfig_responseType c

8396 xmlHttpRequestOpen

8497 xhr

8598 (_xhrRequest_method req)

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

88101 (fromMaybe "" $ _xhrRequestConfig_user c)

89102 (fromMaybe "" $ _xhrRequestConfig_password c)

90103 iforM_ (_xhrRequestConfig_headers c) $ xmlHttpRequestSetRequestHeader xhr

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

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

92105 _ <- xmlHttpRequestOnreadystatechange xhr $ do

93106 readyState <- liftIO $ xmlHttpRequestGetReadyState xhr

94107 status <- liftIO $ xmlHttpRequestGetStatus xhr

95108 statusText <- liftIO $ xmlHttpRequestGetStatusText xhr

96109 if readyState == 4

97110 then do

98− r <- liftIO $ xmlHttpRequestGetResponseText xhr

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

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

112+ then liftIO $ xmlHttpRequestGetResponseText xhr

113+ else return Nothing

114+ r <- liftIO $ xmlHttpRequestGetResponse xhr

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

116+ , _xhrResponse_statusText = statusTextToText statusText

117+ , _xhrResponse_response = r

118+ , _xhrResponse_responseText = responseTextToText t

119+ }

100120 return ()

101121 else return ()

102122 _ <- xmlHttpRequestSend xhr (_xhrRequestConfig_sendData c)

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

143163

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

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

146−decodeXhrResponse = join . fmap decodeText . _xhrResponse_body

166+decodeXhrResponse = join . fmap decodeText . _xhrResponse_responseText

147167

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

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

1+{-# LANGUAGE DeriveDataTypeable #-}

3+module Reflex.Dom.Xhr.ResponseType where

5+import Data.Typeable

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 #-}

3+module HaltSpec where

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 #-}

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)

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