{-# LANGUAGE UndecidableInstances #-}
module Web.Hyperbole.Effect.Hyperbole where
import Data.Aeson (Value)
import Data.Text (Text)
import Effectful
import Effectful.Error.Static
import Effectful.State.Static.Local
import Effectful.Writer.Static.Local
import Web.Hyperbole.Data.Encoded
import Web.Hyperbole.Types.Client
import Web.Hyperbole.Types.Event
import Web.Hyperbole.Types.Request
import Web.Hyperbole.Types.Response
data Hyperbole :: Effect where
GetRequest :: Hyperbole m Request
RespondNow :: Response -> Hyperbole m a
PushUpdate :: ViewUpdate -> Hyperbole m ()
ModClient :: (Client -> Client) -> Hyperbole m ()
GetClient :: Hyperbole m Client
TriggerAction :: TargetViewId -> Encoded -> Hyperbole m ()
TriggerEvent :: Text -> Value -> Hyperbole m ()
type instance DispatchOf Hyperbole = 'Dynamic
data Remote
= RemoteAction TargetViewId Encoded
| RemoteEvent Text Value
runHyperboleLocal :: Request -> Eff (Error Response : State Client : Writer [Remote] : es) Response -> Eff es (Response, Client, [Remote])
runHyperboleLocal :: forall (es :: [(* -> *) -> * -> *]).
Request
-> Eff
(Error Response : State Client : Writer [Remote] : es) Response
-> Eff es (Response, Client, [Remote])
runHyperboleLocal Request
req Eff (Error Response : State Client : Writer [Remote] : es) Response
eff = do
((Either Response Response
eresp, Client
client'), [Remote]
rmts) <- forall w (es :: [(* -> *) -> * -> *]) a.
(HasCallStack, Monoid w) =>
Eff (Writer w : es) a -> Eff es (a, w)
runWriter @[Remote] (Eff (Writer [Remote] : es) (Either Response Response, Client)
-> Eff es ((Either Response Response, Client), [Remote]))
-> (Eff
(Error Response : State Client : Writer [Remote] : es) Response
-> Eff (Writer [Remote] : es) (Either Response Response, Client))
-> Eff
(Error Response : State Client : Writer [Remote] : es) Response
-> Eff es ((Either Response Response, Client), [Remote])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Client
-> Eff
(State Client : Writer [Remote] : es) (Either Response Response)
-> Eff (Writer [Remote] : es) (Either Response Response, Client)
forall s (es :: [(* -> *) -> * -> *]) a.
HasCallStack =>
s -> Eff (State s : es) a -> Eff es (a, s)
runState (RequestId -> Client
emptyClient Request
req.requestId) (Eff
(State Client : Writer [Remote] : es) (Either Response Response)
-> Eff (Writer [Remote] : es) (Either Response Response, Client))
-> (Eff
(Error Response : State Client : Writer [Remote] : es) Response
-> Eff
(State Client : Writer [Remote] : es) (Either Response Response))
-> Eff
(Error Response : State Client : Writer [Remote] : es) Response
-> Eff (Writer [Remote] : es) (Either Response Response, Client)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (es :: [(* -> *) -> * -> *]) a.
HasCallStack =>
Eff (Error e : es) a -> Eff es (Either e a)
runErrorNoCallStack @Response (Eff
(Error Response : State Client : Writer [Remote] : es) Response
-> Eff es ((Either Response Response, Client), [Remote]))
-> Eff
(Error Response : State Client : Writer [Remote] : es) Response
-> Eff es ((Either Response Response, Client), [Remote])
forall a b. (a -> b) -> a -> b
$ Eff (Error Response : State Client : Writer [Remote] : es) Response
eff
(Response, Client, [Remote]) -> Eff es (Response, Client, [Remote])
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Response -> Response)
-> (Response -> Response) -> Either Response Response -> Response
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Response -> Response
forall a. a -> a
id Response -> Response
forall a. a -> a
id Either Response Response
eresp, Client
client', [Remote]
rmts)
where
emptyClient :: RequestId -> Client
emptyClient :: RequestId -> Client
emptyClient RequestId
requestId =
Client
{ RequestId
requestId :: RequestId
$sel:requestId:Client :: RequestId
requestId
, $sel:session:Client :: Cookies
session = Cookies
forall a. Monoid a => a
mempty
, $sel:query:Client :: Maybe QueryData
query = Maybe QueryData
forall a. Monoid a => a
mempty
, $sel:pageTitle:Client :: Maybe Text
pageTitle = Maybe Text
forall a. Maybe a
Nothing
}