Hyperbole.hs

{-# 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 req = reinterpret runLocal $ \_ -> \case
  GetRequest -> do
    pure req
  RespondNow r -> do
    throwError_ r
  GetClient -> do
    get @Client
  ModClient f -> do
    modify @Client f
  TriggerAction vid act -> do
    tell [RemoteAction vid act]
  TriggerEvent name dat -> do
    tell [RemoteEvent name dat]
 where
  runLocal :: Eff (Error Response : State Client : Writer [Remote] : es) Response -> Eff es (Response, Client, [Remote])
  runLocal eff = do
    ((eresp, client'), rmts) <- runWriter @[Remote] . runState (emptyClient req.requestId) . runErrorNoCallStack @Response $ eff
    pure (either id id eresp, client', rmts)

  emptyClient :: RequestId -> Client
  emptyClient requestId =
    Client
      { requestId
      , session = mempty
      , query = mempty
      , pageTitle = Nothing
      }