mirror of
https://github.com/ilyakooo0/reflex-dom.git
synced 2024-09-11 06:35:30 +03:00
Update names.
This commit is contained in:
parent
3e7bde2672
commit
c8ed74cc8b
@ -1,50 +1,38 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecursiveDo #-}
|
||||
module Reflex.Dom.WebSocket.Query (runQuery, runWebSocketQuery) where
|
||||
module Reflex.Dom.WebSocket.Query (cropQueryT, runWebSocketQuery) where
|
||||
|
||||
import Data.Default
|
||||
import Control.Monad.Fix
|
||||
import qualified Data.ByteString.Lazy as LBS
|
||||
import Data.Text (Text)
|
||||
import Data.Text.Encoding
|
||||
import Data.Aeson
|
||||
import Reflex
|
||||
import Reflex.Dom.WebSocket
|
||||
import Reflex.Dom.WebSocket.Internal
|
||||
import Foreign.JavaScript.TH
|
||||
import Data.Maybe
|
||||
import Data.JSString.Text
|
||||
import Language.Javascript.JSaddle.Types (MonadJSM)
|
||||
|
||||
runWebSocketQuery :: (MonadJSM m, MonadJSM (Performable m), HasJSContext m, PostBuild t m, TriggerEvent t m, PerformEvent t m, MonadHold t m, Reflex t, ToJSON q, MonadFix m, Query q, FromJSON (QueryResult q), Additive q, Group q, Eq q)
|
||||
=> Text
|
||||
-> QueryT t q m a
|
||||
-> m a
|
||||
runWebSocketQuery url app = do
|
||||
rec ws <- textWebSocket url $ def { _webSocketConfig_send = pure . decodeUtf8 . LBS.toStrict . encode <$> reqE }
|
||||
let notifications = fromMaybe mempty . jsonDecode . textToJSString <$> _webSocket_recv ws
|
||||
(a, reqE) <- runQuery notifications app
|
||||
=> QueryT t q m a
|
||||
-> Text -- ^ WebSocket url
|
||||
-> m a
|
||||
runWebSocketQuery app url = do
|
||||
postBuild <- getPostBuild
|
||||
rec ws <- jsonWebSocket url $ def { _webSocketConfig_send = pure <$> updatedRequest }
|
||||
(a, request) <- cropQueryT app $ fromMaybe mempty <$> _webSocket_recv ws
|
||||
let updatedRequest = leftmost [updated request, tag (current request) postBuild]
|
||||
return a
|
||||
|
||||
runQuery :: (MonadHold t m, PostBuild t m, MonadFix m, Query q, Additive q, Group q, Eq q)
|
||||
=> Event t (QueryResult q)
|
||||
-> QueryT t q m a
|
||||
-> m (a, Event t q)
|
||||
runQuery notifications app = do
|
||||
postBuild <- getPostBuild
|
||||
rec (a, requestPatch) <- runQueryT app e
|
||||
cropQueryT :: (Reflex t, MonadHold t m, MonadFix m, Query q, Additive q, Group q, Eq q)
|
||||
=> QueryT t q m a
|
||||
-> Event t (QueryResult q)
|
||||
-> m (a, Dynamic t q)
|
||||
cropQueryT app result = do
|
||||
rec (a, requestPatch) <- runQueryT app croppedResult
|
||||
requestUniq <- holdUniqDyn $ incrementalToDynamic requestPatch
|
||||
e <- fromNotifications requestUniq notifications
|
||||
let request = leftmost
|
||||
[ updated requestUniq
|
||||
, tag (current requestUniq) postBuild
|
||||
]
|
||||
return (a, request)
|
||||
croppedResult <- cropDyn requestUniq result
|
||||
return (a, requestUniq)
|
||||
|
||||
fromNotifications :: (Query q, MonadHold t m, Reflex t, MonadFix m)
|
||||
=> Dynamic t q
|
||||
-> Event t (QueryResult q)
|
||||
-> m (Dynamic t (QueryResult q))
|
||||
fromNotifications q = foldDyn (\(q', qr) v -> crop q' (qr `mappend` v)) mempty . attach (current q)
|
||||
cropDyn :: (Query q, MonadHold t m, Reflex t, MonadFix m) => Dynamic t q -> Event t (QueryResult q) -> m (Dynamic t (QueryResult q))
|
||||
cropDyn q = foldDyn (\(q', qr) v -> crop q' (qr `mappend` v)) mempty . attach (current q)
|
||||
|
Loading…
Reference in New Issue
Block a user