c43a99d · reflex-dom · git.iko.soy

git.iko.soy/reflex-dom

on develop help sign in

Merge remote-tracking branch 'origin/primmonad-instances-for-all-builders' into placeholder-refactor

c43a99dRyan Trinkle10 years ago

src-ghc/Reflex/Dom/WebSocket/Foreign.hs+7−2

compare with develop

unifiedsplit

@@ -67,7 +67,7 @@ instance IsWebSocketMessage ByteString where

67instance IsWebSocketMessage Text where

68 webSocketSend jws t = sendWSTextData jws (T.unpack t)

70−newWebSocket :: WebView -> Text -> (ByteString -> IO ()) -> IO () -> IO () -> IO JSWebSocket

70+newWebSocket :: WebView -> Text -> (Either ByteString a -> IO ()) -> IO () -> IO () -> IO JSWebSocket

71newWebSocket wv url onMessage onOpen onClose = withWebViewContext wv $ \c -> do

72 url' <- jsvaluemakestring c =<< jsstringcreatewithutf8cstring (T.unpack url)

73 newWSArgs <- toJSObject c [url']

@@ -80,7 +80,7 @@ newWebSocket wv url onMessage onOpen onClose = withWebViewContext wv $ \c -> do

80 msg' <- fromJSStringMaybe c msg

81 case msg' of

82 Nothing -> return ()

83− Just m -> onMessage $ encodeUtf8 m

83+ Just m -> onMessage $ Left $ encodeUtf8 m

84 jsvaluemakeundefined c

85 onMessageCb <- jsobjectmakefunctionwithcallback c nullPtr onMessage'

86 onOpen' <- wrapper $ \_ _ _ _ _ _ -> do

@@ -95,3 +95,8 @@ newWebSocket wv url onMessage onOpen onClose = withWebViewContext wv $ \c -> do

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

96 _ <- jsevaluatescript c addCbs o nullPtr 1 nullPtr

97 return $ JSWebSocket ws c

98+

99+onBSMessage :: Either ByteString b -> ByteString

100+onBSMessage = either id (error "onBSMessage: ghc env expects ByteString.")

101+

102+type JSVal = ()

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

@@ -1,7 +1,10 @@

1{-# LANGUAGE ForeignFunctionInterface #-}

2{-# LANGUAGE JavaScriptFFI #-}

4−module Reflex.Dom.WebSocket.Foreign where

4+module Reflex.Dom.WebSocket.Foreign

5+ ( module Reflex.Dom.WebSocket.Foreign

6+ , JSVal

7+ ) where

6import Prelude hiding (all, concat, concatMap, div, mapM, mapM_, sequence, span)

9import Prelude hiding (all, concat, concatMap, div, mapM, mapM_, sequence, span)

@@ -42,7 +45,7 @@ instance IsWebSocketMessage ByteString where

42instance IsWebSocketMessage Text where

45instance IsWebSocketMessage Text where

43 webSocketSend (JSWebSocket ws) = GD.sendString ws . T.unpack

46 webSocketSend (JSWebSocket ws) = GD.sendString ws . T.unpack

45−newWebSocket :: a -> Text -> (ByteString -> IO ()) -> IO () -> IO () -> IO JSWebSocket

48+newWebSocket :: a -> Text -> (Either ByteString JSVal -> IO ()) -> IO () -> IO () -> IO JSWebSocket

46newWebSocket _ url onMessage onOpen onClose = do

49newWebSocket _ url onMessage onOpen onClose = do

47 ws <- GD.newWebSocket url (Just [] :: Maybe [Text])

50 ws <- GD.newWebSocket url (Just [] :: Maybe [Text])

48 _ <- on ws open $ liftIO onOpen

51 _ <- on ws open $ liftIO onOpen

@@ -51,11 +54,14 @@ newWebSocket _ url onMessage onOpen onClose = do

51 e <- ask

54 e <- ask

52 d <- getData e

55 d <- getData e

53 liftIO $ case jsTypeOf d of

56 liftIO $ case jsTypeOf d of

54− String -> onMessage $ encodeUtf8 $ pFromJSVal d

57+ String -> onMessage $ Right d

55 _ -> do

58 _ -> do

56 ab <- unsafeFreeze $ pFromJSVal d

59 ab <- unsafeFreeze $ pFromJSVal d

57− onMessage $ toByteString 0 Nothing $ createFromArrayBuffer ab

60+ onMessage $ Left $ toByteString 0 Nothing $ createFromArrayBuffer ab

58 _ <- on ws closeEvent $ liftIO onClose

61 _ <- on ws closeEvent $ liftIO onClose

59 return $ JSWebSocket ws

62 return $ JSWebSocket ws

61foreign import javascript safe "new DataView($3,$1,$2)" js_dataView :: Int -> Int -> JSVal -> JSVal

64foreign import javascript safe "new DataView($3,$1,$2)" js_dataView :: Int -> Int -> JSVal -> JSVal

65+

66+onBSMessage :: Either ByteString JSVal -> ByteString

67+onBSMessage = either id (encodeUtf8 . pFromJSVal)

src/Reflex/Dom/Builder/InputDisabled.hs+5

@@ -8,6 +8,7 @@

8module Reflex.Dom.Builder.InputDisabled where

10import Control.Monad.Fix

11+import Control.Monad.Primitive

11import Control.Monad.Ref

12import Control.Monad.Ref

12import Control.Monad.Trans

13import Control.Monad.Trans

13import Control.Monad.Trans.Control

14import Control.Monad.Trans.Control

@@ -46,6 +47,10 @@ instance PerformEvent t m => PerformEvent t (InputDisabledT m) where

46 performEvent_ = lift . performEvent_

47 performEvent_ = lift . performEvent_

47 performEvent = lift . performEvent

48 performEvent = lift . performEvent

50+instance PrimMonad m => PrimMonad (InputDisabledT m) where

51+ type PrimState (InputDisabledT m) = PrimState m

52+ primitive = lift . primitive

53+

49disableElementConfig :: Reflex t => ElementConfig er t m -> ElementConfig er t m

54disableElementConfig :: Reflex t => ElementConfig er t m -> ElementConfig er t m

50disableElementConfig cfg = cfg

55disableElementConfig cfg = cfg

51 { _elementConfig_initialAttributes = Map.insert "disabled" "disabled" $ _elementConfig_initialAttributes cfg

56 { _elementConfig_initialAttributes = Map.insert "disabled" "disabled" $ _elementConfig_initialAttributes cfg

src/Reflex/Dom/Builder/Static.hs+5

@@ -20,6 +20,7 @@ import Blaze.ByteString.Builder.Html.Utf8

20import Control.Lens hiding (element)

21import Control.Monad.Exception

22import Control.Monad.Identity

23+import Control.Monad.Primitive

23import Control.Monad.Ref

24import Control.Monad.Ref

24import Control.Monad.State.Strict

25import Control.Monad.State.Strict

25import Control.Monad.Trans.Control

26import Control.Monad.Trans.Control

@@ -55,6 +56,10 @@ newtype StaticDomBuilderT t m a = StaticDomBuilderT

55 }

56 }

56 deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)

57 deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)

59+instance PrimMonad m => PrimMonad (StaticDomBuilderT x m) where

60+ type PrimState (StaticDomBuilderT x m) = PrimState m

61+ primitive = lift . primitive

62+

58instance MonadTransControl (StaticDomBuilderT t) where

63instance MonadTransControl (StaticDomBuilderT t) where

59 type StT (StaticDomBuilderT t) a = StT (StateT [Behavior t ByteString]) a

64 type StT (StaticDomBuilderT t) a = StT (StateT [Behavior t ByteString]) a

60 liftWith = defaultLiftWith StaticDomBuilderT unStaticDomBuilderT

65 liftWith = defaultLiftWith StaticDomBuilderT unStaticDomBuilderT

src/Reflex/Dom/Internal.hs+38−13

@@ -15,6 +15,7 @@ module Reflex.Dom.Internal where

16import Prelude hiding (concat, mapM, mapM_, sequence, sequence_)

18+import qualified Reflex as R

18import Reflex.Dom.Builder.Immediate

19import Reflex.Dom.Builder.Immediate

19import Reflex.Dom.Class

20import Reflex.Dom.Class

20import Reflex.Dom.Internal.Foreign

21import Reflex.Dom.Internal.Foreign

@@ -74,23 +75,49 @@ type Widget x = PostBuildT Spider (ImmediateDomBuilderT Spider (WithWebView x (P

74attachWidget :: DOM.IsElement e => e -> WebViewSingleton x -> Widget x a -> IO a

75attachWidget :: DOM.IsElement e => e -> WebViewSingleton x -> Widget x a -> IO a

75attachWidget rootElement wv w = fst <$> attachWidget' rootElement wv w

76attachWidget rootElement wv w = fst <$> attachWidget' rootElement wv w

77−{-# INLINABLE attachWidget' #-}

78+mainWidgetWithHead' :: (forall x. (a -> Widget x b, b -> Widget x a)) -> IO ()

79+mainWidgetWithHead' widgets = runWebGUI $ \webView -> withWebViewSingleton webView $ \wv -> fmap fst $ attachWidget'' $ \events -> do

80+ let (headWidget, bodyWidget) = widgets

81+ Just doc <- liftIO $ fmap DOM.castToHTMLDocument <$> webViewGetDomDocument webView

82+ Just headElement <- getHead doc

83+ Just bodyElement <- getBody doc

84+ (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef

85+ rec b <- unsafeReplaceElementContentsWithWidget events postBuild headElement wv $ headWidget a

86+ a <- unsafeReplaceElementContentsWithWidget events postBuild bodyElement wv $ bodyWidget b

87+ return ((), postBuildTriggerRef)

88+

78−attachWidget' :: DOM.IsElement e => e -> WebViewSingleton x -> Widget x a -> IO (a, FireCommand Spider (SpiderHost Global))

89+unsafeReplaceElementContentsWithWidget :: DOM.IsElement e => EventChannel -> R.Event Spider () -> e -> WebViewSingleton x -> Widget x a -> PerformEventT Spider (SpiderHost Global) a

79−attachWidget' rootElement wv w = do

90+unsafeReplaceElementContentsWithWidget events postBuild rootElement wv w = do

80 Just doc <- getOwnerDocument rootElement

91 Just doc <- getOwnerDocument rootElement

81 Just df <- createDocumentFragment doc

92 Just df <- createDocumentFragment doc

93+ let builderEnv = ImmediateDomBuilderEnv

94+ { _immediateDomBuilderEnv_document = doc

95+ , _immediateDomBuilderEnv_parent = toNode df

96+ , _immediateDomBuilderEnv_events = events

97+ }

98+ result <- runWithWebView (runImmediateDomBuilderT (runPostBuildT w postBuild) builderEnv) wv

99+ setInnerHTML rootElement $ Just ("" :: String)

100+ _ <- appendChild rootElement $ Just df

101+ return result

102+

103+{-# INLINABLE attachWidget' #-}

104+attachWidget' :: DOM.IsElement e => e -> WebViewSingleton x -> Widget x a -> IO (a, FireCommand Spider (SpiderHost Global))

105+attachWidget' rootElement wv w = attachWidget'' $ \events -> do

106+ (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef

107+ result <- unsafeReplaceElementContentsWithWidget events postBuild rootElement wv w

108+ return (result, postBuildTriggerRef)

109+

110+type EventChannel = Chan [DSum (TriggerRef Spider) TriggerInvocation]

111+

112+{-# INLINABLE attachWidget'' #-}

113+attachWidget'' :: (EventChannel -> PerformEventT Spider (SpiderHost Global) (a, IORef (Maybe (EventTrigger Spider ())))) -> IO (a, FireCommand Spider (SpiderHost Global))

114+attachWidget'' w = do

82 events <- newChan

115 events <- newChan

83 (result, fc@(FireCommand fire)) <- runSpiderHost $ do

116 (result, fc@(FireCommand fire)) <- runSpiderHost $ do

84− (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef

117+ ((result, postBuildTriggerRef), fc@(FireCommand fire)) <- hostPerformEventT $ w events

85− let builderEnv = ImmediateDomBuilderEnv

86− { _immediateDomBuilderEnv_document = doc

87− , _immediateDomBuilderEnv_parent = toNode df

88− , _immediateDomBuilderEnv_events = events

89− }

90− results@(_, FireCommand fire) <- hostPerformEventT $ runWithWebView (runImmediateDomBuilderT (runPostBuildT w postBuild) builderEnv) wv

91 mPostBuildTrigger <- readRef postBuildTriggerRef

118 mPostBuildTrigger <- readRef postBuildTriggerRef

92 forM_ mPostBuildTrigger $ \postBuildTrigger -> fire [postBuildTrigger :=> Identity ()] $ return ()

119 forM_ mPostBuildTrigger $ \postBuildTrigger -> fire [postBuildTrigger :=> Identity ()] $ return ()

93− return results

120+ return (result, fc)

94 void $ forkIO $ forever $ do

121 void $ forkIO $ forever $ do

95 ers <- readChan events

122 ers <- readChan events

96 _ <- postGUISync $ runSpiderHost $ do

123 _ <- postGUISync $ runSpiderHost $ do

@@ -100,8 +127,6 @@ attachWidget' rootElement wv w = do

100 _ <- fire (catMaybes mes) $ return ()

127 _ <- fire (catMaybes mes) $ return ()

101 liftIO $ forM_ ers $ \(_ :=> TriggerInvocation _ cb) -> cb

128 liftIO $ forM_ ers $ \(_ :=> TriggerInvocation _ cb) -> cb

102 return ()

129 return ()

103− setInnerHTML rootElement $ Just (""::String)

104− _ <- appendChild rootElement $ Just df

105 return (result, fc)

130 return (result, fc)

106

131

107-- | Run a reflex-dom application inside of an existing DOM element with the given ID

132-- | Run a reflex-dom application inside of an existing DOM element with the given ID

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

@@ -49,10 +49,12 @@ data WebSocketConfig t a

49instance Reflex t => Default (WebSocketConfig t a) where

50 def = WebSocketConfig never

52−data WebSocket t

52+type WebSocket t = RawWebSocket t ByteString

53+

54+data RawWebSocket t a

53− = WebSocket { _webSocket_recv :: Event t ByteString

55+ = RawWebSocket { _webSocket_recv :: Event t a

54− , _webSocket_open :: Event t ()

56+ , _webSocket_open :: Event t ()

55− }

57+ }

57-- This can be used to send either binary or text messages for the same websocket connection

59-- This can be used to send either binary or text messages for the same websocket connection

58instance (IsWebSocketMessage a, IsWebSocketMessage b) => IsWebSocketMessage (Either a b) where

60instance (IsWebSocketMessage a, IsWebSocketMessage b) => IsWebSocketMessage (Either a b) where

@@ -61,7 +63,10 @@ instance (IsWebSocketMessage a, IsWebSocketMessage b) => IsWebSocketMessage (Eit

63webSocket :: (MonadIO m, MonadIO (Performable m), HasWebView m, PerformEvent t m, TriggerEvent t m, PostBuild t m, IsWebSocketMessage a) => Text -> WebSocketConfig t a -> m (WebSocket t)

65webSocket :: (MonadIO m, MonadIO (Performable m), HasWebView m, PerformEvent t m, TriggerEvent t m, PostBuild t m, IsWebSocketMessage a) => Text -> WebSocketConfig t a -> m (WebSocket t)

64−webSocket url config = do

66+webSocket url config = webSocket' url config onBSMessage

67+

68+webSocket' :: (MonadIO m, MonadIO (Performable m), HasWebView m, PerformEvent t m, TriggerEvent t m, PostBuild t m, IsWebSocketMessage a) => Text -> WebSocketConfig t a -> (Either ByteString JSVal -> b) -> m (RawWebSocket t b)

69+webSocket' url config onRawMessage = do

65 wv <- fmap unWebViewSingleton askWebView

70 wv <- fmap unWebViewSingleton askWebView

66 (eRecv, onMessage) <- newTriggerEvent

71 (eRecv, onMessage) <- newTriggerEvent

67 currentSocketRef <- liftIO $ newIORef Nothing

72 currentSocketRef <- liftIO $ newIORef Nothing

@@ -78,7 +83,7 @@ webSocket url config = do

78 liftIO $ threadDelay 1000000

83 liftIO $ threadDelay 1000000

79 start

84 start

80 start = do

85 start = do

81− ws <- liftIO $ newWebSocket wv url onMessage onOpen onClose

86+ ws <- liftIO $ newWebSocket wv url (onMessage . onRawMessage) onOpen onClose

82 liftIO $ writeIORef currentSocketRef $ Just ws

87 liftIO $ writeIORef currentSocketRef $ Just ws

83 return ()

88 return ()

84 performEvent_ . (liftIO start <$) =<< getPostBuild

89 performEvent_ . (liftIO start <$) =<< getPostBuild

@@ -98,6 +103,6 @@ webSocket url config = do

98 `catch`

103 `catch`

99 (\(_ :: SomeException) -> return False))

104 (\(_ :: SomeException) -> return False))

100 unless success $ atomically $ unGetTQueue payloadQueue payload

105 unless success $ atomically $ unGetTQueue payloadQueue payload

101− return $ WebSocket eRecv eOpen

106+ return $ RawWebSocket eRecv eOpen

102

107

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

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