6ce4728 · 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/WebSocket/Foreign.hs

commit6ce47284bb4c9472f002f98437318a1ee6650ac4 authorRyan Trinkle <ryan.trinkle@gmail.com> dateSun 6 Dec 2015, 19:35 (11 years ago) parentf4dbdd7 a10ddfd

9 files changed+61−27

compare with develop

unifiedsplit

reflex-dom.cabal+1 src-ghc/Reflex/Dom/Internal/Foreign.hs+17 src-ghc/Reflex/Dom/WebSocket/Foreign.hs+8−20 src-ghcjs/Reflex/Dom/Internal/Foreign.hs+18−1 src-ghcjs/Reflex/Dom/WebSocket/Foreign.hs+4−3 src/Reflex/Dom.hs+2 src/Reflex/Dom/Location.hs+3 src/Reflex/Dom/WebSocket.hs+7−2 src/Reflex/Dom/Widget/Basic.hs+1−1

reflex-dom.cabal+1

@@ -66,6 +66,7 @@ library

6666 Reflex.Dom.Widget.Lazy

6767 Reflex.Dom.Widget.Resize

6868 Reflex.Dom.Xhr

69+ Reflex.Dom.Location

6970 other-modules:

7071 Reflex.Dom.Internal.Foreign

7172 Reflex.Dom.WebSocket.Foreign

src-ghc/Reflex/Dom/Internal/Foreign.hs+17

@@ -13,6 +13,7 @@ import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSBase

1313import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSObjectRef

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

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

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

1617import Graphics.UI.Gtk.WebKit.WebView

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

1819import Graphics.UI.Gtk.WebKit.WebSettings

@@ -99,3 +100,19 @@ fromJSStringMaybe c t = do

99100 peekCString ps

100101 return $ Just s

101102

103+getLocationHost :: WebView -> IO String

104+getLocationHost wv = do

105+ c <- webFrameGetGlobalContext =<< webViewGetMainFrame wv

106+ script <- jsstringcreatewithutf8cstring "location.host"

107+ lh <- jsevaluatescript c script nullPtr nullPtr 1 nullPtr

108+ lh' <- fromJSStringMaybe c lh

109+ return $ maybe "" id lh'

110+

111+getLocationProtocol :: WebView -> IO String

112+getLocationProtocol wv = do

113+ c <- webFrameGetGlobalContext =<< webViewGetMainFrame wv

114+ script <- jsstringcreatewithutf8cstring "location.protocol"

115+ lp <- jsevaluatescript c script nullPtr nullPtr 1 nullPtr

116+ lp' <- fromJSStringMaybe c lp

117+ return $ maybe "" id lp'

118+

src-ghc/Reflex/Dom/WebSocket/Foreign.hs+8−20

@@ -26,24 +26,8 @@ data JSWebSocket = JSWebSocket { wsValue :: JSValueRef

2626 , wsContext :: JSContextRef

2727 }

2828

29−getLocationHost :: WebView -> IO String

30−getLocationHost wv = do

31− c <- webFrameGetGlobalContext =<< webViewGetMainFrame wv

32− script <- jsstringcreatewithutf8cstring "location.host"

33− lh <- jsevaluatescript c script nullPtr nullPtr 1 nullPtr

34− lh' <- fromJSStringMaybe c lh

35− return $ maybe "" id lh'

36−

37−getLocationProtocol :: WebView -> IO String

38−getLocationProtocol wv = do

39− c <- webFrameGetGlobalContext =<< webViewGetMainFrame wv

40− script <- jsstringcreatewithutf8cstring "location.protocol"

41− lp <- jsevaluatescript c script nullPtr nullPtr 1 nullPtr

42− lp' <- fromJSStringMaybe c lp

43− return $ maybe "" id lp'

44−

45−newWebSocket :: WebView -> String -> (ByteString -> IO ()) -> IO () -> IO JSWebSocket

46−newWebSocket wv url onMessage onClose = do

29+newWebSocket :: WebView -> String -> (ByteString -> IO ()) -> IO () -> IO () -> IO JSWebSocket

30+newWebSocket wv url onMessage onOpen onClose = do

4731 c <- webFrameGetGlobalContext =<< webViewGetMainFrame wv

4832 url' <- jsvaluemakestring c =<< jsstringcreatewithutf8cstring url

4933 newWSArgs <- toJSObject c [url']

@@ -59,12 +43,16 @@ newWebSocket wv url onMessage onClose = do

5943 Just m -> onMessage $ encodeUtf8 $ T.pack m

6044 jsvaluemakeundefined c

6145 onMessageCb <- jsobjectmakefunctionwithcallback c nullPtr onMessage'

46+ onOpen' <- wrapper $ \_ _ _ _ _ _ -> do

47+ onOpen

48+ jsvaluemakeundefined c

49+ onOpenCb <- jsobjectmakefunctionwithcallback c nullPtr onOpen'

6250 onClose' <- wrapper $ \_ _ _ _ _ _ -> do

6351 onClose

6452 jsvaluemakeundefined c

6553 onCloseCb <- jsobjectmakefunctionwithcallback c nullPtr onClose'

66− o <- toJSObject c [ws, onMessageCb, onCloseCb]

67− addCbs <- jsstringcreatewithutf8cstring "this[0]['onmessage'] = this[1]; this[0]['onclose'] = this[2];"

54+ o <- toJSObject c [ws, onMessageCb, onOpenCb, onCloseCb]

55+ addCbs <- jsstringcreatewithutf8cstring "this[0]['onmessage'] = this[1]; this[0]['onopen'] = this[2]; this[0]['onclose'] = this[3];"

6856 _ <- jsevaluatescript c addCbs o nullPtr 1 nullPtr

6957 return $ JSWebSocket ws c

7058

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

@@ -1,3 +1,20 @@

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

1+{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI #-}

3+module Reflex.Dom.Internal.Foreign ( runWebGUI

4+ , module Reflex.Dom.Internal.Foreign

5+ ) where

7+import Control.Monad

38import GHCJS.DOM

9+import GHCJS.DOM.Types

10+import GHCJS.Types

11+

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

13+

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

15+getLocationHost _ = liftM fromJSString getLocationHost_

16+

17+foreign import javascript unsafe "location['protocol']" getLocationProtocol_ :: IO JSString

18+

19+getLocationProtocol :: FromJSString r => a -> IO r

20+getLocationProtocol _ = liftM fromJSString getLocationProtocol_

src-ghcjs/Reflex/Dom/WebSocket/Foreign.hs+4−3

@@ -7,7 +7,7 @@ import Prelude hiding (div, span, mapM, mapM_, concat, concatMap, all, sequence)

77import Data.ByteString (ByteString)

88import qualified Data.ByteString as BS

99import GHCJS.Types

10−import GHCJS.DOM.WebSocket (message, closeEvent)

10+import GHCJS.DOM.WebSocket (message, open, closeEvent)

1111import qualified GHCJS.DOM.WebSocket as GD

1212import GHCJS.DOM.MessageEvent

1313import GHCJS.DOM.EventM (on)

@@ -20,9 +20,10 @@ import GHCJS.Marshal.Pure

2020

2121data JSWebSocket = JSWebSocket { unWebSocket :: WebSocket }

2222

23−newWebSocket :: a -> String -> (ByteString -> IO ()) -> IO () -> IO JSWebSocket

24−newWebSocket _ url onMessage onClose = do

23+newWebSocket :: a -> String -> (ByteString -> IO ()) -> IO () -> IO () -> IO JSWebSocket

24+newWebSocket _ url onMessage onOpen onClose = do

2525 ws <- GD.newWebSocket url (Just [] :: Maybe [String])

26+ _ <- on ws open $ liftIO onOpen

2627 GD.setBinaryType ws "arraybuffer"

2728 _ <- on ws message $ do

2829 e <- ask

src/Reflex/Dom.hs+2

@@ -5,6 +5,7 @@ module Reflex.Dom ( module Reflex

55 , module Reflex.Dom.Xhr

66 , module Reflex.Dom.Time

77 , module Reflex.Dom.WebSocket

8+ , module Reflex.Dom.Location

89 ) where

910

1011import Reflex

@@ -14,3 +15,4 @@ import Reflex.Dom.Widget

1415import Reflex.Dom.Xhr

1516import Reflex.Dom.Time

1617import Reflex.Dom.WebSocket

18+import Reflex.Dom.Location

src/Reflex/Dom/Location.hsnew file+3

@@ -0,0 +1,3 @@

1+module Reflex.Dom.Location (getLocationHost, getLocationProtocol) where

3+import Reflex.Dom.Internal.Foreign

src/Reflex/Dom/WebSocket.hs+7−2

@@ -29,6 +29,7 @@ instance Reflex t => Default (WebSocketConfig t) where

2929

3030data WebSocket t

3131 = WebSocket { _webSocket_recv :: Event t ByteString

32+ , _webSocket_open :: Event t ()

3233 }

3334

3435webSocket :: forall t m. (HasWebView m, MonadWidget t m) => String -> WebSocketConfig t -> m (WebSocket t)

@@ -39,12 +40,16 @@ webSocket url config = do

3940 (eRecv, eRecvTriggerRef) <- newEventWithTriggerRef

4041 currentSocketRef <- liftIO $ newIORef Nothing

4142 --TODO: Disconnect if value no longer needed

43+ (eOpen, eOpenTriggerRef) <- newEventWithTriggerRef

4244 let onMessage :: ByteString -> IO ()

4345 onMessage m = postGui $ do

4446 mt <- readRef eRecvTriggerRef

4547 forM_ mt $ \t -> runWithActions [t :=> m]

48+ onOpen = postGui $ do

49+ mt <- readRef eOpenTriggerRef

50+ forM_ mt $ \t -> runWithActions [t :=> ()]

4651 start = do

47− ws <- liftIO $ newWebSocket wv url onMessage $ do

52+ ws <- liftIO $ newWebSocket wv url onMessage onOpen $ do

4853 void $ forkIO $ do --TODO: Is the fork necessary, or do event handlers run in their own threads automatically?

4954 liftIO $ writeIORef currentSocketRef Nothing

5055 liftIO $ threadDelay 1000000

@@ -58,6 +63,6 @@ webSocket url config = do

5863 Nothing -> return () -- Discard --TODO: should we do something better here? probably buffer it, since we handle reconnection logic; how do we verify that the server has received things?

5964 Just ws -> do

6065 liftIO $ webSocketSend ws payload

61− return $ WebSocket eRecv

66+ return $ WebSocket eRecv eOpen

6267

6368makeLensesWith (lensRules & simpleLenses .~ True) ''WebSocketConfig

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

@@ -797,7 +797,7 @@ link s = linkClass s ""

797797

798798button :: MonadWidget t m => String -> m (Event t ())

799799button s = do

800− (e, _) <- el' "button" $ text s

800+ (e, _) <- elAttr' "button" (Map.singleton "type" "button") $ text s

801801 return $ domEvent Click e

802802

803803newtype Workflow t m a = Workflow { unWorkflow :: m (a, Event t (Workflow t m a)) }