module Ribosome.Host.RpcCall where

import Data.MessagePack (Object (ObjectArray, ObjectNil))
import Exon (exon)

import Ribosome.Host.Class.Msgpack.Decode (pattern Msgpack, MsgpackDecode (fromMsgpack))
import Ribosome.Host.Class.Msgpack.Encode (toMsgpack)
import Ribosome.Host.Data.Request (Request (Request))
import Ribosome.Host.Data.RpcCall (RpcCall (RpcAtomic, RpcCallRequest, RpcFmap, RpcPure))

decodeAtom ::
  MsgpackDecode a =>
  [Object] ->
  Either Text ([Object], a)
decodeAtom :: forall a. MsgpackDecode a => [Object] -> Either Text ([Object], a)
decodeAtom = \case
  Object
o : [Object]
rest ->
    ([Object]
rest,) (a -> ([Object], a)) -> Either Text a -> Either Text ([Object], a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> Either Text a
forall a. MsgpackDecode a => Object -> Either Text a
fromMsgpack Object
o
  [] ->
    Text -> Either Text ([Object], a)
forall a b. a -> Either a b
Left Text
"Too few results in atomic call response"

foldAtomic :: RpcCall a -> ([Request], [Object] -> Either Text ([Object], a))
foldAtomic :: forall a.
RpcCall a -> ([Request], [Object] -> Either Text ([Object], a))
foldAtomic = \case
  RpcCallRequest Request
req ->
    ([Request -> Request
coerce Request
req], [Object] -> Either Text ([Object], a)
forall a. MsgpackDecode a => [Object] -> Either Text ([Object], a)
decodeAtom)
  RpcPure a
a ->
    ([], ([Object], a) -> Either Text ([Object], a)
forall a b. b -> Either a b
Right (([Object], a) -> Either Text ([Object], a))
-> ([Object] -> ([Object], a))
-> [Object]
-> Either Text ([Object], a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,a
a))
  RpcFmap a1 -> a
f RpcCall a1
a ->
    (([Object] -> Either Text ([Object], a1))
 -> [Object] -> Either Text ([Object], a))
-> ([Request], [Object] -> Either Text ([Object], a1))
-> ([Request], [Object] -> Either Text ([Object], a))
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ((([Object], a1) -> ([Object], a))
-> Either Text ([Object], a1) -> Either Text ([Object], a)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ((a1 -> a) -> ([Object], a1) -> ([Object], a)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second a1 -> a
f) (Either Text ([Object], a1) -> Either Text ([Object], a))
-> ([Object] -> Either Text ([Object], a1))
-> [Object]
-> Either Text ([Object], a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) (RpcCall a1 -> ([Request], [Object] -> Either Text ([Object], a1))
forall a.
RpcCall a -> ([Request], [Object] -> Either Text ([Object], a))
foldAtomic RpcCall a1
a)
  RpcAtomic a1 -> b -> a
f RpcCall a1
aa RpcCall b
ab ->
    ([Request]
reqsA [Request] -> [Request] -> [Request]
forall a. Semigroup a => a -> a -> a
<> [Request]
reqsB, [Object] -> Either Text ([Object], a)
decode)
    where
      decode :: [Object] -> Either Text ([Object], a)
decode [Object]
o = do
        ([Object]
restA, a1
a) <- [Object] -> Either Text ([Object], a1)
decodeA [Object]
o
        (b -> a) -> ([Object], b) -> ([Object], a)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (a1 -> b -> a
f a1
a) (([Object], b) -> ([Object], a))
-> Either Text ([Object], b) -> Either Text ([Object], a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Object] -> Either Text ([Object], b)
decodeB [Object]
restA
      ([Request]
reqsB, [Object] -> Either Text ([Object], b)
decodeB) =
        RpcCall b -> ([Request], [Object] -> Either Text ([Object], b))
forall a.
RpcCall a -> ([Request], [Object] -> Either Text ([Object], a))
foldAtomic RpcCall b
ab
      ([Request]
reqsA, [Object] -> Either Text ([Object], a1)
decodeA) =
        RpcCall a1 -> ([Request], [Object] -> Either Text ([Object], a1))
forall a.
RpcCall a -> ([Request], [Object] -> Either Text ([Object], a))
foldAtomic RpcCall a1
aa

checkLeftovers :: ([Object], a) -> Either Text a
checkLeftovers :: forall a. ([Object], a) -> Either Text a
checkLeftovers = \case
  ([], a
a) -> a -> Either Text a
forall a b. b -> Either a b
Right a
a
  ([Object]
res, a
_) -> Text -> Either Text a
forall a b. a -> Either a b
Left [exon|Excess results in atomic call response: #{show res}|]

atomicRequest :: [Request] -> Request
atomicRequest :: [Request] -> Request
atomicRequest [Request]
reqs =
  RpcMethod -> [Object] -> Request
Request RpcMethod
"nvim_call_atomic" [[Request] -> Object
forall a. MsgpackEncode a => a -> Object
toMsgpack [Request]
reqs]

atomicResult ::
  ([Object] -> Either Text ([Object], a)) ->
  Object ->
  Either Text a
atomicResult :: forall a.
([Object] -> Either Text ([Object], a)) -> Object -> Either Text a
atomicResult [Object] -> Either Text ([Object], a)
decode = \case
  ObjectArray [Msgpack [Object]
res, Item [Object]
Object
ObjectNil] ->
    ([Object], a) -> Either Text a
forall a. ([Object], a) -> Either Text a
checkLeftovers (([Object], a) -> Either Text a)
-> Either Text ([Object], a) -> Either Text a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Object] -> Either Text ([Object], a)
decode [Object]
res
  ObjectArray [Item [Object]
_, Item [Object]
errs] ->
    Text -> Either Text a
forall a b. a -> Either a b
Left (Object -> Text
forall b a. (Show a, IsString b) => a -> b
show Item [Object]
Object
errs)
  Object
o ->
    Text -> Either Text a
forall a b. a -> Either a b
Left (Text
"Bad atomic result: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Object -> Text
forall b a. (Show a, IsString b) => a -> b
show Object
o)

cata :: RpcCall a -> Either a (Request, Object -> Either Text a)
cata :: forall a. RpcCall a -> Either a (Request, Object -> Either Text a)
cata = \case
  RpcCallRequest Request
req ->
    (Request, Object -> Either Text a)
-> Either a (Request, Object -> Either Text a)
forall a b. b -> Either a b
Right (Request
req, Object -> Either Text a
forall a. MsgpackDecode a => Object -> Either Text a
fromMsgpack)
  RpcPure a
a ->
    a -> Either a (Request, Object -> Either Text a)
forall a b. a -> Either a b
Left a
a
  RpcFmap a1 -> a
f RpcCall a1
a ->
    (a1 -> a)
-> ((Request, Object -> Either Text a1)
    -> (Request, Object -> Either Text a))
-> Either a1 (Request, Object -> Either Text a1)
-> Either a (Request, Object -> Either Text a)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap a1 -> a
f (((Object -> Either Text a1) -> Object -> Either Text a)
-> (Request, Object -> Either Text a1)
-> (Request, Object -> Either Text a)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ((a1 -> a) -> Either Text a1 -> Either Text a
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second a1 -> a
f (Either Text a1 -> Either Text a)
-> (Object -> Either Text a1) -> Object -> Either Text a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.)) (RpcCall a1 -> Either a1 (Request, Object -> Either Text a1)
forall a. RpcCall a -> Either a (Request, Object -> Either Text a)
cata RpcCall a1
a)
  a :: RpcCall a
a@RpcAtomic {} ->
    (Request, Object -> Either Text a)
-> Either a (Request, Object -> Either Text a)
forall a b. b -> Either a b
Right (([Request] -> Request)
-> (([Object] -> Either Text ([Object], a))
    -> Object -> Either Text a)
-> ([Request], [Object] -> Either Text ([Object], a))
-> (Request, Object -> Either Text a)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap [Request] -> Request
atomicRequest ([Object] -> Either Text ([Object], a)) -> Object -> Either Text a
forall a.
([Object] -> Either Text ([Object], a)) -> Object -> Either Text a
atomicResult (RpcCall a -> ([Request], [Object] -> Either Text ([Object], a))
forall a.
RpcCall a -> ([Request], [Object] -> Either Text ([Object], a))
foldAtomic RpcCall a
a))