c43a99d · reflex-dom · git.iko.soy

git.iko.soy/reflex-dom

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

commitc43a99dbaab18e23838b05fc607d8266539a2b42 authorRyan Trinkle <ryan.trinkle@gmail.com> dateTue 25 Oct 2016, 12:58 (10 years ago) parent1ab18f3 89ebec2

6 files changed+77−26

compare with develop

unifiedsplit

src-ghc/Reflex/Dom/WebSocket/Foreign.hs+7−2 src-ghcjs/Reflex/Dom/WebSocket/Foreign.hs+10−4 src/Reflex/Dom/Builder/InputDisabled.hs+5 src/Reflex/Dom/Builder/Static.hs+5 src/Reflex/Dom/Internal.hs+38−13 src/Reflex/Dom/WebSocket.hs+12−7

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

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

6767instance IsWebSocketMessage Text where

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

6969

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

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

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

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

7373 newWSArgs <- toJSObject c [url']

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

8080 msg' <- fromJSStringMaybe c msg

8181 case msg' of

8282 Nothing -> return ()

83− Just m -> onMessage $ encodeUtf8 m

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

8484 jsvaluemakeundefined c

8585 onMessageCb <- jsobjectmakefunctionwithcallback c nullPtr onMessage'

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

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

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

9696 _ <- jsevaluatescript c addCbs o nullPtr 1 nullPtr

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

11{-# LANGUAGE ForeignFunctionInterface #-}

22{-# 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

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

710

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

4245instance IsWebSocketMessage Text where

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

4447

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

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

4649newWebSocket _ url onMessage onOpen onClose = do

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

4851 _ <- on ws open $ liftIO onOpen

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

5154 e <- ask

5255 d <- getData e

5356 liftIO $ case jsTypeOf d of

54− String -> onMessage $ encodeUtf8 $ pFromJSVal d

57+ String -> onMessage $ Right d

5558 _ -> do

5659 ab <- unsafeFreeze $ pFromJSVal d

57− onMessage $ toByteString 0 Nothing $ createFromArrayBuffer ab

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

5861 _ <- on ws closeEvent $ liftIO onClose

5962 return $ JSWebSocket ws

6063

6164foreign 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 @@

88module Reflex.Dom.Builder.InputDisabled where

1010import Control.Monad.Fix

11+import Control.Monad.Primitive

1112import Control.Monad.Ref

1213import Control.Monad.Trans

1314import Control.Monad.Trans.Control

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

4647 performEvent_ = lift . performEvent_

4748 performEvent = lift . performEvent

4849

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

51+ type PrimState (InputDisabledT m) = PrimState m

52+ primitive = lift . primitive

53+

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

5055disableElementConfig cfg = cfg

5156 { _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

2020import Control.Lens hiding (element)

2121import Control.Monad.Exception

2222import Control.Monad.Identity

23+import Control.Monad.Primitive

2324import Control.Monad.Ref

2425import Control.Monad.State.Strict

2526import Control.Monad.Trans.Control

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

5556 }

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

5758

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

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

61+ primitive = lift . primitive

62+

5863instance MonadTransControl (StaticDomBuilderT t) where

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

6065 liftWith = defaultLiftWith StaticDomBuilderT unStaticDomBuilderT

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

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

1515

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

1717

18+import qualified Reflex as R

1819import Reflex.Dom.Builder.Immediate

1920import Reflex.Dom.Class

2021import Reflex.Dom.Internal.Foreign

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

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

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

7677

77−{-# INLINABLE attachWidget' #-}

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

79−attachWidget' rootElement wv w = do

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+

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

90+unsafeReplaceElementContentsWithWidget events postBuild rootElement wv w = do

8091 Just doc <- getOwnerDocument rootElement

8192 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

82115 events <- newChan

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

84− (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef

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

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

91118 mPostBuildTrigger <- readRef postBuildTriggerRef

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

93− return results

120+ return (result, fc)

94121 void $ forkIO $ forever $ do

95122 ers <- readChan events

96123 _ <- postGUISync $ runSpiderHost $ do

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

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

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

102129 return ()

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

104− _ <- appendChild rootElement $ Just df

105130 return (result, fc)

106131

107132-- | 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

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

5050 def = WebSocketConfig never

5151

52−data WebSocket t

53− = WebSocket { _webSocket_recv :: Event t ByteString

54− , _webSocket_open :: Event t ()

55− }

52+type WebSocket t = RawWebSocket t ByteString

53+

54+data RawWebSocket t a

55+ = RawWebSocket { _webSocket_recv :: Event t a

56+ , _webSocket_open :: Event t ()

57+ }

5658

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

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

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

6163

6264

6365webSocket :: (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

6570 wv <- fmap unWebViewSingleton askWebView

6671 (eRecv, onMessage) <- newTriggerEvent

6772 currentSocketRef <- liftIO $ newIORef Nothing

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

7883 liftIO $ threadDelay 1000000

7984 start

8085 start = do

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

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

8287 liftIO $ writeIORef currentSocketRef $ Just ws

8388 return ()

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

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

98103 `catch`

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

100105 unless success $ atomically $ unGetTQueue payloadQueue payload

101− return $ WebSocket eRecv eOpen

106+ return $ RawWebSocket eRecv eOpen

102107

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