{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RecursiveDo #-}
module Reflex.Dom.WebSocket.Query (cropQueryT, runWebSocketQuery) where

import Data.Default
import Control.Monad.Fix
import Data.Text (Text)
import Data.Aeson
import Reflex
import Reflex.Dom.WebSocket
import Foreign.JavaScript.TH
import Data.Maybe
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)
                  => QueryT t q m a
                  -> Text -- ^ WebSocket url
                  -> m a
runWebSocketQuery :: QueryT t q m a -> Text -> m a
runWebSocketQuery app :: QueryT t q m a
app url :: Text
url = do
  Event t ()
postBuild <- m (Event t ())
forall t (m :: * -> *). PostBuild t m => m (Event t ())
getPostBuild
  rec RawWebSocket t (Maybe (QueryResult q))
ws <- Text
-> WebSocketConfig t q
-> m (RawWebSocket t (Maybe (QueryResult q)))
forall a b (m :: * -> *) t.
(ToJSON a, FromJSON b, MonadJSM m, MonadJSM (Performable m),
 HasJSContext m, PostBuild t m, TriggerEvent t m, PerformEvent t m,
 MonadHold t m, Reflex t) =>
Text -> WebSocketConfig t a -> m (RawWebSocket t (Maybe b))
jsonWebSocket Text
url (WebSocketConfig t q -> m (RawWebSocket t (Maybe (QueryResult q))))
-> WebSocketConfig t q
-> m (RawWebSocket t (Maybe (QueryResult q)))
forall a b. (a -> b) -> a -> b
$ WebSocketConfig t Any
forall a. Default a => a
def { _webSocketConfig_send :: Event t [q]
_webSocketConfig_send = q -> [q]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (q -> [q]) -> Event t q -> Event t [q]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Event t q
updatedRequest }
      (a :: a
a, request :: Dynamic t q
request) <- QueryT t q m a -> Event t (QueryResult q) -> m (a, Dynamic t q)
forall t (m :: * -> *) q a.
(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 QueryT t q m a
app (Event t (QueryResult q) -> m (a, Dynamic t q))
-> Event t (QueryResult q) -> m (a, Dynamic t q)
forall a b. (a -> b) -> a -> b
$ QueryResult q -> Maybe (QueryResult q) -> QueryResult q
forall a. a -> Maybe a -> a
fromMaybe QueryResult q
forall a. Monoid a => a
mempty (Maybe (QueryResult q) -> QueryResult q)
-> Event t (Maybe (QueryResult q)) -> Event t (QueryResult q)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RawWebSocket t (Maybe (QueryResult q))
-> Event t (Maybe (QueryResult q))
forall k (t :: k) a. RawWebSocket t a -> Event t a
_webSocket_recv RawWebSocket t (Maybe (QueryResult q))
ws
      let updatedRequest :: Event t q
updatedRequest = [Event t q] -> Event t q
forall k (t :: k) a. Reflex t => [Event t a] -> Event t a
leftmost [Dynamic t q -> Event t q
forall k (t :: k) a. Reflex t => Dynamic t a -> Event t a
updated Dynamic t q
request, Behavior t q -> Event t () -> Event t q
forall k (t :: k) b a.
Reflex t =>
Behavior t b -> Event t a -> Event t b
tag (Dynamic t q -> Behavior t q
forall k (t :: k) a. Reflex t => Dynamic t a -> Behavior t a
current Dynamic t q
request) Event t ()
postBuild]
  a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a

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 :: QueryT t q m a -> Event t (QueryResult q) -> m (a, Dynamic t q)
cropQueryT app :: QueryT t q m a
app result :: Event t (QueryResult q)
result = do
  rec (a :: a
a, requestPatch :: Incremental t (AdditivePatch q)
requestPatch) <- QueryT t q m a
-> Dynamic t (QueryResult q)
-> m (a, Incremental t (AdditivePatch q))
forall (m :: * -> *) q t a.
(MonadFix m, Additive q, Group q, Reflex t) =>
QueryT t q m a
-> Dynamic t (QueryResult q)
-> m (a, Incremental t (AdditivePatch q))
runQueryT QueryT t q m a
app Dynamic t (QueryResult q)
croppedResult
      Dynamic t q
requestUniq <- Dynamic t q -> m (Dynamic t q)
forall k (t :: k) (m :: * -> *) a.
(Reflex t, MonadHold t m, MonadFix m, Eq a) =>
Dynamic t a -> m (Dynamic t a)
holdUniqDyn (Dynamic t q -> m (Dynamic t q)) -> Dynamic t q -> m (Dynamic t q)
forall a b. (a -> b) -> a -> b
$ Incremental t (AdditivePatch q)
-> Dynamic t (PatchTarget (AdditivePatch q))
forall k (t :: k) p.
(Reflex t, Patch p) =>
Incremental t p -> Dynamic t (PatchTarget p)
incrementalToDynamic Incremental t (AdditivePatch q)
requestPatch
      Dynamic t (QueryResult q)
croppedResult <- Dynamic t q
-> Event t (QueryResult q) -> m (Dynamic t (QueryResult q))
forall q t (m :: * -> *).
(Query q, MonadHold t m, Reflex t, MonadFix m) =>
Dynamic t q
-> Event t (QueryResult q) -> m (Dynamic t (QueryResult q))
cropDyn Dynamic t q
requestUniq Event t (QueryResult q)
result
  (a, Dynamic t q) -> m (a, Dynamic t q)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, Dynamic t q
requestUniq)

cropDyn :: (Query q, MonadHold t m, Reflex t, MonadFix m) => Dynamic t q -> Event t (QueryResult q) -> m (Dynamic t (QueryResult q))
cropDyn :: Dynamic t q
-> Event t (QueryResult q) -> m (Dynamic t (QueryResult q))
cropDyn q :: Dynamic t q
q = ((q, QueryResult q) -> QueryResult q -> QueryResult q)
-> QueryResult q
-> Event t (q, QueryResult q)
-> m (Dynamic t (QueryResult q))
forall k (t :: k) (m :: * -> *) a b.
(Reflex t, MonadHold t m, MonadFix m) =>
(a -> b -> b) -> b -> Event t a -> m (Dynamic t b)
foldDyn (\(q' :: q
q', qr :: QueryResult q
qr) v :: QueryResult q
v -> q -> QueryResult q -> QueryResult q
forall a. Query a => a -> QueryResult a -> QueryResult a
crop q
q' (QueryResult q
qr QueryResult q -> QueryResult q -> QueryResult q
forall a. Monoid a => a -> a -> a
`mappend` QueryResult q
v)) QueryResult q
forall a. Monoid a => a
mempty (Event t (q, QueryResult q) -> m (Dynamic t (QueryResult q)))
-> (Event t (QueryResult q) -> Event t (q, QueryResult q))
-> Event t (QueryResult q)
-> m (Dynamic t (QueryResult q))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Behavior t q
-> Event t (QueryResult q) -> Event t (q, QueryResult q)
forall k (t :: k) a b.
Reflex t =>
Behavior t a -> Event t b -> Event t (a, b)
attach (Dynamic t q -> Behavior t q
forall k (t :: k) a. Reflex t => Dynamic t a -> Behavior t a
current Dynamic t q
q)