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.Class.Msgpack.Error (DecodeError (DecodeError), FieldError (FieldError))
import Ribosome.Host.Data.Request (Request (Request))
import Ribosome.Host.Data.RpcCall (RpcCall (RpcAtomic, RpcCallRequest, RpcFmap, RpcPure))

atomicError ::
  Text ->
  Either DecodeError a
atomicError :: forall a. Text -> Either DecodeError a
atomicError Text
msg =
  DecodeError -> Either DecodeError a
forall a b. a -> Either a b
Left (Text -> FieldError -> DecodeError
DecodeError Text
"atomic call response" (Text -> FieldError
FieldError Text
msg))

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

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

checkLeftovers :: ([Object], a) -> Either DecodeError a
checkLeftovers :: forall a. ([Object], a) -> Either DecodeError a
checkLeftovers = \case
  ([], a
a) ->
    a -> Either DecodeError a
forall a b. b -> Either a b
Right a
a
  ([Object]
res, a
_) ->
    Text -> Either DecodeError a
forall a. Text -> Either DecodeError a
atomicError [exon|Excess results: #{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 DecodeError ([Object], a)) ->
  Object ->
  Either DecodeError a
atomicResult :: forall a.
([Object] -> Either DecodeError ([Object], a))
-> Object -> Either DecodeError a
atomicResult [Object] -> Either DecodeError ([Object], a)
decode = \case
  ObjectArray [Msgpack [Object]
res, Item [Object]
Object
ObjectNil] ->
    ([Object], a) -> Either DecodeError a
forall a. ([Object], a) -> Either DecodeError a
checkLeftovers (([Object], a) -> Either DecodeError a)
-> Either DecodeError ([Object], a) -> Either DecodeError a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Object] -> Either DecodeError ([Object], a)
decode [Object]
res
  ObjectArray [Item [Object]
_, Item [Object]
errs] ->
    Text -> Either DecodeError a
forall a. Text -> Either DecodeError a
atomicError (Object -> Text
forall b a. (Show a, IsString b) => a -> b
show Item [Object]
Object
errs)
  Object
o ->
    Text -> Either DecodeError a
forall a. Text -> Either DecodeError a
atomicError [exon|Not an array: #{show o}|]

cata :: RpcCall a -> Either a (Request, Object -> Either DecodeError a)
cata :: forall a.
RpcCall a -> Either a (Request, Object -> Either DecodeError a)
cata = \case
  RpcCallRequest Request
req ->
    (Request, Object -> Either DecodeError a)
-> Either a (Request, Object -> Either DecodeError a)
forall a b. b -> Either a b
Right (Request
req, Object -> Either DecodeError a
forall a. MsgpackDecode a => Object -> Either DecodeError a
fromMsgpack)
  RpcPure a
a ->
    a -> Either a (Request, Object -> Either DecodeError a)
forall a b. a -> Either a b
Left a
a
  RpcFmap a1 -> a
f RpcCall a1
a ->
    (a1 -> a)
-> ((Request, Object -> Either DecodeError a1)
    -> (Request, Object -> Either DecodeError a))
-> Either a1 (Request, Object -> Either DecodeError a1)
-> Either a (Request, Object -> Either DecodeError 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 DecodeError a1)
 -> Object -> Either DecodeError a)
-> (Request, Object -> Either DecodeError a1)
-> (Request, Object -> Either DecodeError a)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ((a1 -> a) -> Either DecodeError a1 -> Either DecodeError a
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second a1 -> a
f (Either DecodeError a1 -> Either DecodeError a)
-> (Object -> Either DecodeError a1)
-> Object
-> Either DecodeError a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.)) (RpcCall a1 -> Either a1 (Request, Object -> Either DecodeError a1)
forall a.
RpcCall a -> Either a (Request, Object -> Either DecodeError a)
cata RpcCall a1
a)
  a :: RpcCall a
a@RpcAtomic {} ->
    (Request, Object -> Either DecodeError a)
-> Either a (Request, Object -> Either DecodeError a)
forall a b. b -> Either a b
Right (([Request] -> Request)
-> (([Object] -> Either DecodeError ([Object], a))
    -> Object -> Either DecodeError a)
-> ([Request], [Object] -> Either DecodeError ([Object], a))
-> (Request, Object -> Either DecodeError 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 DecodeError ([Object], a))
-> Object -> Either DecodeError a
forall a.
([Object] -> Either DecodeError ([Object], a))
-> Object -> Either DecodeError a
atomicResult (RpcCall a
-> ([Request], [Object] -> Either DecodeError ([Object], a))
forall a.
RpcCall a
-> ([Request], [Object] -> Either DecodeError ([Object], a))
foldAtomic RpcCall a
a))