module Ribosome.Host.Interpreter.Rpc where

import Data.MessagePack (Object)
import Exon (exon)
import qualified Polysemy.Log as Log
import qualified Polysemy.Process as Process
import Polysemy.Process (Process)

import Ribosome.Host.Data.ChannelId (ChannelId)
import Ribosome.Host.Data.Request (
  Request (Request, method),
  RequestId,
  TrackedRequest (TrackedRequest),
  arguments,
  formatReq,
  formatTrackedReq,
  )
import qualified Ribosome.Host.Data.Response as Response
import Ribosome.Host.Data.Response (Response)
import Ribosome.Host.Data.RpcCall (RpcCall (RpcCallRequest))
import qualified Ribosome.Host.Data.RpcError as RpcError
import Ribosome.Host.Data.RpcError (RpcError)
import qualified Ribosome.Host.Data.RpcMessage as RpcMessage
import Ribosome.Host.Data.RpcMessage (RpcMessage)
import qualified Ribosome.Host.Effect.Responses as Responses
import Ribosome.Host.Effect.Responses (Responses)
import qualified Ribosome.Host.Effect.Rpc as Rpc
import Ribosome.Host.Effect.Rpc (Rpc)
import qualified Ribosome.Host.RpcCall as RpcCall

request ::
  ∀ a o r .
  Members [Process RpcMessage o, Responses RequestId Response !! RpcError, Log, Stop RpcError] r =>
  Text ->
  Request ->
  (Object -> Either Text a) ->
  Sem r a
request :: forall a o (r :: EffectRow).
Members
  '[Process RpcMessage o, Responses RequestId Response !! RpcError,
    Log, Stop RpcError]
  r =>
Text -> Request -> (Object -> Either Text a) -> Sem r a
request Text
exec req :: Request
req@Request {RpcMethod
method :: RpcMethod
$sel:method:Request :: Request -> RpcMethod
method, [Object]
arguments :: [Object]
$sel:arguments:Request :: Request -> [Object]
arguments} Object -> Either Text a
decode = do
  RequestId
reqId <- Sem (Responses RequestId Response : r) RequestId -> Sem r RequestId
forall err (eff :: (* -> *) -> * -> *) (r :: EffectRow).
Members '[Resumable err eff, Stop err] r =>
InterpreterFor eff r
restop Sem (Responses RequestId Response : r) RequestId
forall k v (r :: EffectRow). Member (Responses k v) r => Sem r k
Responses.add
  let treq :: TrackedRequest
treq = RequestId -> Request -> TrackedRequest
TrackedRequest RequestId
reqId (Request -> Request
coerce Request
req)
  Text -> Sem r ()
forall (r :: EffectRow).
(HasCallStack, Member Log r) =>
Text -> Sem r ()
Log.trace [exon|#{exec} rpc: #{formatTrackedReq treq}|]
  RpcMessage -> Sem r ()
forall i o (r :: EffectRow).
Member (Process i o) r =>
i -> Sem r ()
Process.send (TrackedRequest -> RpcMessage
RpcMessage.Request TrackedRequest
treq)
  Sem (Responses RequestId Response : r) Response -> Sem r Response
forall err (eff :: (* -> *) -> * -> *) (r :: EffectRow).
Members '[Resumable err eff, Stop err] r =>
InterpreterFor eff r
restop (RequestId -> Sem (Responses RequestId Response : r) Response
forall k v (r :: EffectRow).
Member (Responses k v) r =>
k -> Sem r v
Responses.wait RequestId
reqId) Sem r Response -> (Response -> Sem r a) -> Sem r a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Response.Success Object
a ->
      (Text -> RpcError) -> Either Text a -> Sem r a
forall err' (r :: EffectRow) err a.
Member (Stop err') r =>
(err -> err') -> Either err a -> Sem r a
stopEitherWith Text -> RpcError
RpcError.Decode (Object -> Either Text a
decode Object
a)
    Response.Error Text
e ->
      RpcError -> Sem r a
forall e (r :: EffectRow) a. Member (Stop e) r => e -> Sem r a
stop (RpcMethod -> [Object] -> Text -> RpcError
RpcError.Api RpcMethod
method [Object]
arguments Text
e)

handleCall ::
  RpcCall a ->
  (Request -> (Object -> Either Text a) -> Sem r a) ->
  Sem r a
handleCall :: forall a (r :: EffectRow).
RpcCall a
-> (Request -> (Object -> Either Text a) -> Sem r a) -> Sem r a
handleCall RpcCall a
call Request -> (Object -> Either Text a) -> Sem r a
handle =
  RpcCall a -> Either a (Request, Object -> Either Text a)
forall a. RpcCall a -> Either a (Request, Object -> Either Text a)
RpcCall.cata RpcCall a
call Either a (Request, Object -> Either Text a)
-> (Either a (Request, Object -> Either Text a) -> Sem r a)
-> Sem r a
forall a b. a -> (a -> b) -> b
& \case
    Right (Request
req, Object -> Either Text a
decode) -> do
      Request -> (Object -> Either Text a) -> Sem r a
handle Request
req Object -> Either Text a
decode
    Left a
a ->
      a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a

fetchChannelId ::
  Member (AtomicState (Maybe ChannelId)) r =>
  Members [Process RpcMessage o, Responses RequestId Response !! RpcError, Log, Stop RpcError] r =>
  Sem r ChannelId
fetchChannelId :: forall (r :: EffectRow) o.
(Member (AtomicState (Maybe ChannelId)) r,
 Members
   '[Process RpcMessage o, Responses RequestId Response !! RpcError,
     Log, Stop RpcError]
   r) =>
Sem r ChannelId
fetchChannelId = do
  (ChannelId
cid, ()) <- RpcCall (ChannelId, ())
-> (Request
    -> (Object -> Either Text (ChannelId, ()))
    -> Sem r (ChannelId, ()))
-> Sem r (ChannelId, ())
forall a (r :: EffectRow).
RpcCall a
-> (Request -> (Object -> Either Text a) -> Sem r a) -> Sem r a
handleCall (Request -> RpcCall (ChannelId, ())
forall a. MsgpackDecode a => Request -> RpcCall a
RpcCallRequest (RpcMethod -> [Object] -> Request
Request RpcMethod
"nvim_get_api_info" [])) (Text
-> Request
-> (Object -> Either Text (ChannelId, ()))
-> Sem r (ChannelId, ())
forall a o (r :: EffectRow).
Members
  '[Process RpcMessage o, Responses RequestId Response !! RpcError,
    Log, Stop RpcError]
  r =>
Text -> Request -> (Object -> Either Text a) -> Sem r a
request Text
"sync")
  ChannelId
cid ChannelId -> Sem r () -> Sem r ChannelId
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Maybe ChannelId -> Sem r ()
forall s (r :: EffectRow).
Member (AtomicState s) r =>
s -> Sem r ()
atomicPut (ChannelId -> Maybe ChannelId
forall a. a -> Maybe a
Just ChannelId
cid)

cachedChannelId ::
  Member (AtomicState (Maybe ChannelId)) r =>
  Members [Process RpcMessage o, Responses RequestId Response !! RpcError, Log, Stop RpcError] r =>
  Sem r ChannelId
cachedChannelId :: forall (r :: EffectRow) o.
(Member (AtomicState (Maybe ChannelId)) r,
 Members
   '[Process RpcMessage o, Responses RequestId Response !! RpcError,
     Log, Stop RpcError]
   r) =>
Sem r ChannelId
cachedChannelId =
  Sem r ChannelId
-> (ChannelId -> Sem r ChannelId)
-> Maybe ChannelId
-> Sem r ChannelId
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Sem r ChannelId
forall (r :: EffectRow) o.
(Member (AtomicState (Maybe ChannelId)) r,
 Members
   '[Process RpcMessage o, Responses RequestId Response !! RpcError,
     Log, Stop RpcError]
   r) =>
Sem r ChannelId
fetchChannelId ChannelId -> Sem r ChannelId
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ChannelId -> Sem r ChannelId)
-> Sem r (Maybe ChannelId) -> Sem r ChannelId
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Sem r (Maybe ChannelId)
forall s (r :: EffectRow). Member (AtomicState s) r => Sem r s
atomicGet

interpretRpc ::
  ∀ o r .
  Member (AtomicState (Maybe ChannelId)) r =>
  Members [Responses RequestId Response !! RpcError, Process RpcMessage o, Log, Async] r =>
  InterpreterFor (Rpc !! RpcError) r
interpretRpc :: forall o (r :: EffectRow).
(Member (AtomicState (Maybe ChannelId)) r,
 Members
   '[Responses RequestId Response !! RpcError, Process RpcMessage o,
     Log, Async]
   r) =>
InterpreterFor (Rpc !! RpcError) r
interpretRpc =
  (forall x (r0 :: EffectRow).
 Rpc (Sem r0) x
 -> Tactical (Rpc !! RpcError) (Sem r0) (Stop RpcError : r) x)
-> InterpreterFor (Rpc !! RpcError) r
forall err (eff :: (* -> *) -> * -> *) (r :: EffectRow).
(forall x (r0 :: EffectRow).
 eff (Sem r0) x
 -> Tactical (Resumable err eff) (Sem r0) (Stop err : r) x)
-> InterpreterFor (Resumable err eff) r
interpretResumableH \case
    Rpc.Sync RpcCall x
call ->
      x
-> Sem
     (WithTactics (Rpc !! RpcError) f (Sem r0) (Stop RpcError : r))
     (f x)
forall (f :: * -> *) a (e :: (* -> *) -> * -> *) (m :: * -> *)
       (r :: EffectRow).
Functor f =>
a -> Sem (WithTactics e f m r) (f a)
pureT (x
 -> Sem
      (WithTactics (Rpc !! RpcError) f (Sem r0) (Stop RpcError : r))
      (f x))
-> Sem
     (WithTactics (Rpc !! RpcError) f (Sem r0) (Stop RpcError : r)) x
-> Sem
     (WithTactics (Rpc !! RpcError) f (Sem r0) (Stop RpcError : r))
     (f x)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< RpcCall x
-> (Request
    -> (Object -> Either Text x)
    -> Sem
         (WithTactics (Rpc !! RpcError) f (Sem r0) (Stop RpcError : r)) x)
-> Sem
     (WithTactics (Rpc !! RpcError) f (Sem r0) (Stop RpcError : r)) x
forall a (r :: EffectRow).
RpcCall a
-> (Request -> (Object -> Either Text a) -> Sem r a) -> Sem r a
handleCall RpcCall x
call (Text
-> Request
-> (Object -> Either Text x)
-> Sem
     (WithTactics (Rpc !! RpcError) f (Sem r0) (Stop RpcError : r)) x
forall a o (r :: EffectRow).
Members
  '[Process RpcMessage o, Responses RequestId Response !! RpcError,
    Log, Stop RpcError]
  r =>
Text -> Request -> (Object -> Either Text a) -> Sem r a
request Text
"sync")
    Rpc.Async RpcCall a1
call Either RpcError a1 -> Sem r0 ()
use -> do
      Sem
  (WithTactics (Rpc !! RpcError) f (Sem r0) (Stop RpcError : r))
  (Async (Maybe (f ())))
-> Sem
     (WithTactics (Rpc !! RpcError) f (Sem r0) (Stop RpcError : r)) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Sem
   (WithTactics (Rpc !! RpcError) f (Sem r0) (Stop RpcError : r))
   (Async (Maybe (f ())))
 -> Sem
      (WithTactics (Rpc !! RpcError) f (Sem r0) (Stop RpcError : r)) ())
-> Sem
     (WithTactics (Rpc !! RpcError) f (Sem r0) (Stop RpcError : r))
     (Async (Maybe (f ())))
-> Sem
     (WithTactics (Rpc !! RpcError) f (Sem r0) (Stop RpcError : r)) ()
forall a b. (a -> b) -> a -> b
$ Sem
  (WithTactics (Rpc !! RpcError) f (Sem r0) (Stop RpcError : r))
  (f ())
-> Sem
     (WithTactics (Rpc !! RpcError) f (Sem r0) (Stop RpcError : r))
     (Async (Maybe (f ())))
forall (r :: EffectRow) a.
Member Async r =>
Sem r a -> Sem r (Async (Maybe a))
async do
        Either RpcError a1
a <- forall e (r :: EffectRow) a.
Sem (Stop e : r) a -> Sem r (Either e a)
runStop @RpcError (RpcCall a1
-> (Request
    -> (Object -> Either Text a1)
    -> Sem
         (Stop RpcError
            : WithTactics (Rpc !! RpcError) f (Sem r0) (Stop RpcError : r))
         a1)
-> Sem
     (Stop RpcError
        : WithTactics (Rpc !! RpcError) f (Sem r0) (Stop RpcError : r))
     a1
forall a (r :: EffectRow).
RpcCall a
-> (Request -> (Object -> Either Text a) -> Sem r a) -> Sem r a
handleCall RpcCall a1
call (Text
-> Request
-> (Object -> Either Text a1)
-> Sem
     (Stop RpcError
        : WithTactics (Rpc !! RpcError) f (Sem r0) (Stop RpcError : r))
     a1
forall a o (r :: EffectRow).
Members
  '[Process RpcMessage o, Responses RequestId Response !! RpcError,
    Log, Stop RpcError]
  r =>
Text -> Request -> (Object -> Either Text a) -> Sem r a
request Text
"async"))
        Sem r0 ()
-> Tactical (Rpc !! RpcError) (Sem r0) (Stop RpcError : r) ()
forall (m :: * -> *) a (e :: (* -> *) -> * -> *) (r :: EffectRow).
m a -> Tactical e m r a
runTSimple (Either RpcError a1 -> Sem r0 ()
use Either RpcError a1
a)
      Sem
  (WithTactics (Rpc !! RpcError) f (Sem r0) (Stop RpcError : r))
  (f x)
forall (f :: * -> *) (e :: (* -> *) -> * -> *) (m :: * -> *)
       (r :: EffectRow).
Functor f =>
Sem (WithTactics e f m r) (f ())
unitT
    Rpc.Notify RpcCall a1
call -> do
      RpcCall ()
-> (Request
    -> (Object -> Either Text ())
    -> Sem
         (WithTactics (Rpc !! RpcError) f (Sem r0) (Stop RpcError : r)) ())
-> Sem
     (WithTactics (Rpc !! RpcError) f (Sem r0) (Stop RpcError : r)) ()
forall a (r :: EffectRow).
RpcCall a
-> (Request -> (Object -> Either Text a) -> Sem r a) -> Sem r a
handleCall (RpcCall a1 -> RpcCall ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void RpcCall a1
call) \ Request
req Object -> Either Text ()
_ -> do
        Text
-> Sem
     (WithTactics (Rpc !! RpcError) f (Sem r0) (Stop RpcError : r)) ()
forall (r :: EffectRow).
(HasCallStack, Member Log r) =>
Text -> Sem r ()
Log.trace [exon|notify rpc: #{formatReq req}|]
        RpcMessage
-> Sem
     (WithTactics (Rpc !! RpcError) f (Sem r0) (Stop RpcError : r)) ()
forall i o (r :: EffectRow).
Member (Process i o) r =>
i -> Sem r ()
Process.send (Request -> RpcMessage
RpcMessage.Notification Request
req)
      Sem
  (WithTactics (Rpc !! RpcError) f (Sem r0) (Stop RpcError : r))
  (f x)
forall (f :: * -> *) (e :: (* -> *) -> * -> *) (m :: * -> *)
       (r :: EffectRow).
Functor f =>
Sem (WithTactics e f m r) (f ())
unitT
    Rpc (Sem r0) x
Rpc.ChannelId ->
      ChannelId
-> Sem
     (WithTactics (Rpc !! RpcError) f (Sem r0) (Stop RpcError : r))
     (f ChannelId)
forall (f :: * -> *) a (e :: (* -> *) -> * -> *) (m :: * -> *)
       (r :: EffectRow).
Functor f =>
a -> Sem (WithTactics e f m r) (f a)
pureT (ChannelId
 -> Sem
      (WithTactics (Rpc !! RpcError) f (Sem r0) (Stop RpcError : r))
      (f ChannelId))
-> Sem
     (WithTactics (Rpc !! RpcError) f (Sem r0) (Stop RpcError : r))
     ChannelId
-> Sem
     (WithTactics (Rpc !! RpcError) f (Sem r0) (Stop RpcError : r))
     (f ChannelId)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Sem
  (WithTactics (Rpc !! RpcError) f (Sem r0) (Stop RpcError : r))
  ChannelId
forall (r :: EffectRow) o.
(Member (AtomicState (Maybe ChannelId)) r,
 Members
   '[Process RpcMessage o, Responses RequestId Response !! RpcError,
     Log, Stop RpcError]
   r) =>
Sem r ChannelId
cachedChannelId