Update names.

reflex-dom-core/src/Reflex/Dom/WebSocket/Query.hs

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