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

import Data.Default
import Control.Monad.Fix
import Data.Semigroup.Commutative
import Data.Text (Text)
import Data.Aeson
import Reflex
import Reflex.Dom.WebSocket
import Data.Maybe
import Language.Javascript.JSaddle.Types (MonadJSM)

runWebSocketQuery :: (MonadJSM m, MonadJSM (Performable m), PostBuild t m, TriggerEvent t m, PerformEvent t m, MonadHold t m, Reflex t, ToJSON q, MonadFix m, Query q, FromJSON (QueryResult q), Commutative q, Group q, Eq q)
                  => QueryT t q m a
                  -> Text -- ^ WebSocket url
                  -> m a
runWebSocketQuery :: forall (m :: * -> *) t q a.
(MonadJSM m, MonadJSM (Performable m), PostBuild t m,
 TriggerEvent t m, PerformEvent t m, MonadHold t m, Reflex t,
 ToJSON q, MonadFix m, Query q, FromJSON (QueryResult q),
 Commutative q, Group q, Eq q) =>
QueryT t q m a -> Text -> m a
runWebSocketQuery QueryT t q m a
app Text
url = do
  postBuild <- m (Event t ())
forall t (m :: * -> *). PostBuild t m => m (Event t ())
getPostBuild
  rec ws <- jsonWebSocket url $ def { _webSocketConfig_send = pure <$> updatedRequest }
      (a, request) <- cropQueryT app $ fromMaybe mempty <$> _webSocket_recv ws
      let 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 a. Dynamic t a -> Event t a
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 a. Dynamic t a -> Behavior t a
forall {k} (t :: k) a. Reflex t => Dynamic t a -> Behavior t a
current Dynamic t q
request) Event t ()
postBuild]
  return a

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

cropDyn :: (Query q, MonadHold t m, Reflex t, MonadFix m) => Dynamic t q -> Event t (QueryResult q) -> m (Dynamic t (QueryResult q))
cropDyn :: 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
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', QueryResult q
qr) 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 a. Dynamic t a -> Behavior t a
forall {k} (t :: k) a. Reflex t => Dynamic t a -> Behavior t a
current Dynamic t q
q)