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.Class.Msgpack.Error (DecodeError)
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 DecodeError 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 DecodeError 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 DecodeError 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 ->
      (DecodeError -> RpcError) -> Either DecodeError a -> Sem r a
forall err' (r :: EffectRow) err a.
Member (Stop err') r =>
(err -> err') -> Either err a -> Sem r a
stopEitherWith DecodeError -> RpcError
RpcError.Decode (Object -> Either DecodeError 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 DecodeError a) -> Sem r a) ->
  Sem r a
handleCall :: forall a (r :: EffectRow).
RpcCall a
-> (Request -> (Object -> Either DecodeError a) -> Sem r a)
-> Sem r a
handleCall RpcCall a
call Request -> (Object -> Either DecodeError a) -> Sem r a
handle =
  RpcCall a -> Either a (Request, Object -> Either DecodeError a)
forall a.
RpcCall a -> Either a (Request, Object -> Either DecodeError a)
RpcCall.cata RpcCall a
call Either a (Request, Object -> Either DecodeError a)
-> (Either a (Request, Object -> Either DecodeError a) -> Sem r a)
-> Sem r a
forall a b. a -> (a -> b) -> b
& \case
    Right (Request
req, Object -> Either DecodeError a
decode) -> do
      Request -> (Object -> Either DecodeError a) -> Sem r a
handle Request
req Object -> Either DecodeError 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 DecodeError (ChannelId, ()))
    -> Sem r (ChannelId, ()))
-> Sem r (ChannelId, ())
forall a (r :: EffectRow).
RpcCall a
-> (Request -> (Object -> Either DecodeError 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 DecodeError (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 DecodeError 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 DecodeError 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 DecodeError a) -> Sem r a)
-> Sem r a
handleCall RpcCall x
call (Text
-> Request
-> (Object -> Either DecodeError 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 DecodeError 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 DecodeError 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 DecodeError a) -> Sem r a)
-> Sem r a
handleCall RpcCall a1
call (Text
-> Request
-> (Object -> Either DecodeError 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 DecodeError 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 DecodeError ())
    -> 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 DecodeError 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 DecodeError ()
_ -> 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