git.iko.soy/reflex-dom
on develop help sign in
Update names.
c8ed74cLuigy Leon
reflex-dom-core/src/Reflex/Dom/WebSocket/Query.hs+19−31
compare with develop
unifiedsplit
@@ -1,50 +1,38 @@
1−{-# LANGUAGE CPP #-}
2{-# LANGUAGE FlexibleContexts #-}
1{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE RecursiveDo #-}
3{-# LANGUAGE RecursiveDo #-}
5−module Reflex.Dom.WebSocket.Query (runQuery, runWebSocketQuery) where
4+module Reflex.Dom.WebSocket.Query (cropQueryT, runWebSocketQuery) where
6
5
7import Data.Default
6import Data.Default
8import Control.Monad.Fix
7import Control.Monad.Fix
9−import qualified Data.ByteString.Lazy as LBS
10import Data.Text (Text)
8import Data.Text (Text)
11−import Data.Text.Encoding
12import Data.Aeson
9import Data.Aeson
13import Reflex
10import Reflex
14import Reflex.Dom.WebSocket
11import Reflex.Dom.WebSocket
15−import Reflex.Dom.WebSocket.Internal
16import Foreign.JavaScript.TH
12import Foreign.JavaScript.TH
17import Data.Maybe
13import Data.Maybe
18−import Data.JSString.Text
19import Language.Javascript.JSaddle.Types (MonadJSM)
14import Language.Javascript.JSaddle.Types (MonadJSM)
20
15
21runWebSocketQuery :: (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)
16runWebSocketQuery :: (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)
22− => Text
23− -> QueryT t q m a
17+ => QueryT t q m a
18+ -> Text -- ^ WebSocket url
24− -> m a
19+ -> m a
25−runWebSocketQuery url app = do
20+runWebSocketQuery app url = do
21+ postBuild <- getPostBuild
26− rec ws <- textWebSocket url $ def { _webSocketConfig_send = pure . decodeUtf8 . LBS.toStrict . encode <$> reqE }
22+ rec ws <- jsonWebSocket url $ def { _webSocketConfig_send = pure <$> updatedRequest }
27− let notifications = fromMaybe mempty . jsonDecode . textToJSString <$> _webSocket_recv ws
23+ (a, request) <- cropQueryT app $ fromMaybe mempty <$> _webSocket_recv ws
28− (a, reqE) <- runQuery notifications app
24+ let updatedRequest = leftmost [updated request, tag (current request) postBuild]
29 return a
25 return a
30
26
31−runQuery :: (MonadHold t m, PostBuild t m, MonadFix m, Query q, Additive q, Group q, Eq q)
27+cropQueryT :: (Reflex t, MonadHold t m, MonadFix m, Query q, Additive q, Group q, Eq q)
32− => Event t (QueryResult q)
33− -> QueryT t q m a
28+ => QueryT t q m a
29+ -> Event t (QueryResult q)
34− -> m (a, Event t q)
30+ -> m (a, Dynamic t q)
35−runQuery notifications app = do
31+cropQueryT app result = do
36− postBuild <- getPostBuild
37− rec (a, requestPatch) <- runQueryT app e
32+ rec (a, requestPatch) <- runQueryT app croppedResult
38 requestUniq <- holdUniqDyn $ incrementalToDynamic requestPatch
33 requestUniq <- holdUniqDyn $ incrementalToDynamic requestPatch
39− e <- fromNotifications requestUniq notifications
34+ croppedResult <- cropDyn requestUniq result
40− let request = leftmost
41− [ updated requestUniq
42− , tag (current requestUniq) postBuild
43− ]
44− return (a, request)
35+ return (a, requestUniq)
45
36
46−fromNotifications :: (Query q, MonadHold t m, Reflex t, MonadFix m)
37+cropDyn :: (Query q, MonadHold t m, Reflex t, MonadFix m) => Dynamic t q -> Event t (QueryResult q) -> m (Dynamic t (QueryResult q))
47− => Dynamic t q
48− -> Event t (QueryResult q)
49− -> m (Dynamic t (QueryResult q))
50−fromNotifications q = foldDyn (\(q', qr) v -> crop q' (qr `mappend` v)) mempty . attach (current q)
38+cropDyn q = foldDyn (\(q', qr) v -> crop q' (qr `mappend` v)) mempty . attach (current q)