{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE UndecidableInstances #-}

module Web.Hyperbole.Effect.Hyperbole where

import Data.Aeson (Value)
import Data.Text (Text)
import Effectful
import Effectful.Dispatch.Dynamic
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


-- | The 'Hyperbole' 'Effect' allows you to access information in the 'Request', manually respond, and manipulate the Client 'session' and 'query'.
data Hyperbole :: Effect where
  GetRequest :: Hyperbole m Request
  RespondNow :: Response -> Hyperbole m a
  ModClient :: (Client -> Client) -> Hyperbole m ()
  GetClient :: Hyperbole m Client
  -- TODO: this should actually execute the other view, and send the response to the client
  TriggerAction :: TargetViewId -> Encoded -> Hyperbole m ()
  TriggerEvent :: Text -> Value -> Hyperbole m ()


type instance DispatchOf Hyperbole = 'Dynamic


data Remote
  = RemoteAction TargetViewId Encoded
  | RemoteEvent Text Value


-- | Run the 'Hyperbole' effect to get a response
runHyperbole
  :: Request
  -> Eff (Hyperbole : es) Response
  -> Eff es (Response, Client, [Remote])
runHyperbole :: forall (es :: [(* -> *) -> * -> *]).
Request
-> Eff (Hyperbole : es) Response
-> Eff es (Response, Client, [Remote])
runHyperbole Request
req = (Eff
   (Error Response : State Client : Writer [Remote] : es) Response
 -> Eff es (Response, Client, [Remote]))
-> (forall {a} {localEs :: [(* -> *) -> * -> *]}.
    (HasCallStack, Hyperbole :> localEs) =>
    LocalEnv
      localEs (Error Response : State Client : Writer [Remote] : es)
    -> Hyperbole (Eff localEs) a
    -> Eff (Error Response : State Client : Writer [Remote] : es) a)
-> Eff (Hyperbole : es) Response
-> Eff es (Response, Client, [Remote])
forall (e :: (* -> *) -> * -> *)
       (handlerEs :: [(* -> *) -> * -> *]) a (es :: [(* -> *) -> * -> *])
       b.
(HasCallStack, DispatchOf e ~ 'Dynamic) =>
(Eff handlerEs a -> Eff es b)
-> EffectHandler e handlerEs -> Eff (e : es) a -> Eff es b
reinterpret Eff (Error Response : State Client : Writer [Remote] : es) Response
-> Eff es (Response, Client, [Remote])
forall (es :: [(* -> *) -> * -> *]).
Eff (Error Response : State Client : Writer [Remote] : es) Response
-> Eff es (Response, Client, [Remote])
runLocal ((forall {a} {localEs :: [(* -> *) -> * -> *]}.
  (HasCallStack, Hyperbole :> localEs) =>
  LocalEnv
    localEs (Error Response : State Client : Writer [Remote] : es)
  -> Hyperbole (Eff localEs) a
  -> Eff (Error Response : State Client : Writer [Remote] : es) a)
 -> Eff (Hyperbole : es) Response
 -> Eff es (Response, Client, [Remote]))
-> (forall {a} {localEs :: [(* -> *) -> * -> *]}.
    (HasCallStack, Hyperbole :> localEs) =>
    LocalEnv
      localEs (Error Response : State Client : Writer [Remote] : es)
    -> Hyperbole (Eff localEs) a
    -> Eff (Error Response : State Client : Writer [Remote] : es) a)
-> Eff (Hyperbole : es) Response
-> Eff es (Response, Client, [Remote])
forall a b. (a -> b) -> a -> b
$ \LocalEnv
  localEs (Error Response : State Client : Writer [Remote] : es)
_ -> \case
  Hyperbole (Eff localEs) a
GetRequest -> do
    a -> Eff (Error Response : State Client : Writer [Remote] : es) a
forall a.
a -> Eff (Error Response : State Client : Writer [Remote] : es) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
Request
req
  RespondNow Response
r -> do
    Response
-> Eff (Error Response : State Client : Writer [Remote] : es) a
forall e (es :: [(* -> *) -> * -> *]) a.
(HasCallStack, Error e :> es) =>
e -> Eff es a
throwError_ Response
r
  Hyperbole (Eff localEs) a
GetClient -> do
    forall s (es :: [(* -> *) -> * -> *]).
(HasCallStack, State s :> es) =>
Eff es s
get @Client
  ModClient Client -> Client
f -> do
    forall s (es :: [(* -> *) -> * -> *]).
(HasCallStack, State s :> es) =>
(s -> s) -> Eff es ()
modify @Client Client -> Client
f
  TriggerAction TargetViewId
vid Encoded
act -> do
    [Remote]
-> Eff (Error Response : State Client : Writer [Remote] : es) ()
forall w (es :: [(* -> *) -> * -> *]).
(HasCallStack, Writer w :> es, Monoid w) =>
w -> Eff es ()
tell [TargetViewId -> Encoded -> Remote
RemoteAction TargetViewId
vid Encoded
act]
  TriggerEvent Text
name Value
dat -> do
    [Remote]
-> Eff (Error Response : State Client : Writer [Remote] : es) ()
forall w (es :: [(* -> *) -> * -> *]).
(HasCallStack, Writer w :> es, Monoid w) =>
w -> Eff es ()
tell [Text -> Value -> Remote
RemoteEvent Text
name Value
dat]
 where
  runLocal :: Eff (Error Response : State Client : Writer [Remote] : es) Response -> Eff es (Response, Client, [Remote])
  runLocal :: forall (es :: [(* -> *) -> * -> *]).
Eff (Error Response : State Client : Writer [Remote] : es) Response
-> Eff es (Response, Client, [Remote])
runLocal 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)

  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
      }