module Ribosome.Api.Atomic where

import Data.MessagePack (Object(ObjectNil, ObjectArray, ObjectString))
import Neovim.Plugin.Classes (FunctionName(F))
import qualified Ribosome.Nvim.Api.RpcCall as RpcError (RpcError(Atomic))

import Ribosome.Control.Monad.Ribo (NvimE)
import Ribosome.Msgpack.Decode (MsgpackDecode(..), fromMsgpack')
import Ribosome.Msgpack.Encode (MsgpackEncode(toMsgpack))
import Ribosome.Msgpack.Error (DecodeError)
import qualified Ribosome.Msgpack.Util as Util (illegalType)
import Ribosome.Nvim.Api.IO (nvimCallAtomic)
import Ribosome.Nvim.Api.RpcCall (RpcCall(RpcCall))

data AtomicStatus =
  Failure Text
  |
  Success
  deriving (AtomicStatus -> AtomicStatus -> Bool
(AtomicStatus -> AtomicStatus -> Bool)
-> (AtomicStatus -> AtomicStatus -> Bool) -> Eq AtomicStatus
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AtomicStatus -> AtomicStatus -> Bool
$c/= :: AtomicStatus -> AtomicStatus -> Bool
== :: AtomicStatus -> AtomicStatus -> Bool
$c== :: AtomicStatus -> AtomicStatus -> Bool
Eq, Int -> AtomicStatus -> ShowS
[AtomicStatus] -> ShowS
AtomicStatus -> String
(Int -> AtomicStatus -> ShowS)
-> (AtomicStatus -> String)
-> ([AtomicStatus] -> ShowS)
-> Show AtomicStatus
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AtomicStatus] -> ShowS
$cshowList :: [AtomicStatus] -> ShowS
show :: AtomicStatus -> String
$cshow :: AtomicStatus -> String
showsPrec :: Int -> AtomicStatus -> ShowS
$cshowsPrec :: Int -> AtomicStatus -> ShowS
Show)

instance MsgpackDecode AtomicStatus where
  fromMsgpack :: Object -> Either Err AtomicStatus
fromMsgpack Object
ObjectNil =
    AtomicStatus -> Either Err AtomicStatus
forall a b. b -> Either a b
Right AtomicStatus
Success
  fromMsgpack (ObjectArray [Item [Object]
_, Item [Object]
_, ObjectString msg]) =
    AtomicStatus -> Either Err AtomicStatus
forall a b. b -> Either a b
Right (Text -> AtomicStatus
Failure (ByteString -> Text
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 ByteString
msg))
  fromMsgpack Object
o =
    Text -> Object -> Either Err AtomicStatus
forall a. Text -> Object -> Either Err a
Util.illegalType Text
"AtomicStatus" Object
o

-- |Bundle a list of 'RpcCall's into a single call to nvim_call_atomic.
-- The result is checked for an error message, and if it is present, the call will fail.
atomic ::
  MonadDeepError e DecodeError m =>
  NvimE e m =>
  [RpcCall] ->
  m [Object]
atomic :: [RpcCall] -> m [Object]
atomic [RpcCall]
calls = do
  ([Object]
results, Object
statusObject) <- [Object] -> m ([Object], Object)
forall a (m :: * -> *) e.
(IsList a, MonadError e m, DeepPrisms e RpcError, Show a,
 Item a ~ Object) =>
a -> m ([Object], Object)
unpack ([Object] -> m ([Object], Object))
-> m [Object] -> m ([Object], Object)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Object] -> m [Object]
forall (m :: * -> *) e.
(Nvim m, MonadDeepError e RpcError m) =>
[Object] -> m [Object]
nvimCallAtomic (RpcCall -> Object
call (RpcCall -> Object) -> [RpcCall] -> [Object]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [RpcCall]
calls)
  AtomicStatus
status <- Object -> m AtomicStatus
forall a e (m :: * -> *).
(MonadDeepError e DecodeError m, MsgpackDecode a) =>
Object -> m a
fromMsgpack' Object
statusObject
  [Object] -> AtomicStatus -> m [Object]
forall e (m :: * -> *) a.
(MonadError e m, DeepPrisms e RpcError) =>
a -> AtomicStatus -> m a
check [Object]
results AtomicStatus
status
  where
    call :: RpcCall -> Object
call (RpcCall (F ByteString
name) [Object]
args) =
      [Object] -> Object
forall a. MsgpackEncode a => a -> Object
toMsgpack @[Object] [ByteString -> Object
forall a. MsgpackEncode a => a -> Object
toMsgpack ByteString
name, [Object] -> Object
forall a. MsgpackEncode a => a -> Object
toMsgpack [Object]
args]
    unpack :: a -> m ([Object], Object)
unpack [ObjectArray results, Item a
status] =
      ([Object], Object) -> m ([Object], Object)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Object]
results, Item a
Object
status)
    unpack a
o =
      RpcError -> m ([Object], Object)
forall e e' (m :: * -> *) a. MonadDeepError e e' m => e' -> m a
throwHoist (Text -> RpcError
RpcError.Atomic (Text
"unexpected result structure: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> a -> Text
forall b a. (Show a, IsString b) => a -> b
show a
o))
    check :: a -> AtomicStatus -> m a
check a
_ (Failure Text
err) =
      RpcError -> m a
forall e e' (m :: * -> *) a. MonadDeepError e e' m => e' -> m a
throwHoist (Text -> RpcError
RpcError.Atomic Text
err)
    check a
results AtomicStatus
Success =
      a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
results

-- |Bundle calls into one and decode all results to the same type.
atomicAs ::
  MonadDeepError e DecodeError m =>
  MsgpackDecode a =>
  NvimE e m =>
  [RpcCall] ->
  m [a]
atomicAs :: [RpcCall] -> m [a]
atomicAs =
  (Object -> m a) -> [Object] -> m [a]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Object -> m a
forall a e (m :: * -> *).
(MonadDeepError e DecodeError m, MsgpackDecode a) =>
Object -> m a
fromMsgpack' ([Object] -> m [a])
-> ([RpcCall] -> m [Object]) -> [RpcCall] -> m [a]
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< [RpcCall] -> m [Object]
forall e (m :: * -> *).
(MonadDeepError e DecodeError m, NvimE e m) =>
[RpcCall] -> m [Object]
atomic