module Ribosome.Api.Exists where

import Data.Text.Prettyprint.Doc (viaShow, (<+>))
import Neovim (AnsiStyle, Doc, Object(ObjectInt))

import Ribosome.Control.Monad.Ribo (NvimE)
import Ribosome.Msgpack.Decode (MsgpackDecode, fromMsgpack)
import Ribosome.Msgpack.Encode (toMsgpack)
import Ribosome.Nvim.Api.IO (vimCallFunction)
import Ribosome.System.Time (epochSeconds, sleep)

data Retry =
  Retry Int Double
  deriving Int -> Retry -> ShowS
[Retry] -> ShowS
Retry -> String
(Int -> Retry -> ShowS)
-> (Retry -> String) -> ([Retry] -> ShowS) -> Show Retry
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Retry] -> ShowS
$cshowList :: [Retry] -> ShowS
show :: Retry -> String
$cshow :: Retry -> String
showsPrec :: Int -> Retry -> ShowS
$cshowsPrec :: Int -> Retry -> ShowS
Show

instance Default Retry where
  def :: Retry
def = Int -> Double -> Retry
Retry Int
3 Double
0.1

retry ::
  MonadIO f =>
  f a ->
  (a -> f (Either c b)) ->
  Retry ->
  f (Either c b)
retry :: f a -> (a -> f (Either c b)) -> Retry -> f (Either c b)
retry f a
thunk a -> f (Either c b)
check (Retry Int
timeout Double
interval) = do
  Int
start <- f Int
forall (m :: * -> *). MonadIO m => m Int
epochSeconds
  Int -> f (Either c b)
step Int
start
  where
    step :: Int -> f (Either c b)
step Int
start = do
      a
result <- f a
thunk
      Either c b
checked <- a -> f (Either c b)
check a
result
      Int -> Either c b -> f (Either c b)
recurse Int
start Either c b
checked
    recurse :: Int -> Either c b -> f (Either c b)
recurse Int
_ (Right b
b) = Either c b -> f (Either c b)
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> Either c b
forall a b. b -> Either a b
Right b
b)
    recurse Int
start (Left c
e) = do
      Int
current <- f Int
forall (m :: * -> *). MonadIO m => m Int
epochSeconds
      if (Int
current Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
start) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
timeout
      then do
        Double -> f ()
forall (m :: * -> *). MonadIO m => Double -> m ()
sleep Double
interval
        Int -> f (Either c b)
step Int
start
      else Either c b -> f (Either c b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either c b -> f (Either c b)) -> Either c b -> f (Either c b)
forall a b. (a -> b) -> a -> b
$ c -> Either c b
forall a b. a -> Either a b
Left c
e

waitFor ::
  NvimE e m =>
  MonadIO m =>
  m Object ->
  (Object -> m (Either (Doc AnsiStyle) b)) ->
  Retry ->
  m (Either (Doc AnsiStyle) b)
waitFor :: m Object
-> (Object -> m (Either (Doc AnsiStyle) b))
-> Retry
-> m (Either (Doc AnsiStyle) b)
waitFor m Object
thunk Object -> m (Either (Doc AnsiStyle) b)
check' =
  m Object
-> (Object -> m (Either (Doc AnsiStyle) b))
-> Retry
-> m (Either (Doc AnsiStyle) b)
forall (f :: * -> *) a c b.
MonadIO f =>
f a -> (a -> f (Either c b)) -> Retry -> f (Either c b)
retry m Object
thunk Object -> m (Either (Doc AnsiStyle) b)
check
  where
    check :: Object -> m (Either (Doc AnsiStyle) b)
check Object
result =
      case Object -> Either (Doc AnsiStyle) Object
forall a. MsgpackDecode a => Object -> Either (Doc AnsiStyle) a
fromMsgpack Object
result of
        Right Object
a -> Object -> m (Either (Doc AnsiStyle) b)
check' Object
a
        Left Doc AnsiStyle
e -> Either (Doc AnsiStyle) b -> m (Either (Doc AnsiStyle) b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (Doc AnsiStyle) b -> m (Either (Doc AnsiStyle) b))
-> Either (Doc AnsiStyle) b -> m (Either (Doc AnsiStyle) b)
forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle -> Either (Doc AnsiStyle) b
forall a b. a -> Either a b
Left Doc AnsiStyle
e

existsResult :: Object -> Either (Doc AnsiStyle) ()
existsResult :: Object -> Either (Doc AnsiStyle) ()
existsResult (ObjectInt Int64
1) = () -> Either (Doc AnsiStyle) ()
forall a b. b -> Either a b
Right ()
existsResult Object
a =
  Doc AnsiStyle -> Either (Doc AnsiStyle) ()
forall a b. a -> Either a b
Left (Doc AnsiStyle -> Either (Doc AnsiStyle) ())
-> Doc AnsiStyle -> Either (Doc AnsiStyle) ()
forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle
"weird return type " Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Object -> Doc AnsiStyle
forall a ann. Show a => a -> Doc ann
viaShow Object
a

vimExists ::
  NvimE e m =>
  Text ->
  m Object
vimExists :: Text -> m Object
vimExists Text
entity =
  Text -> [Object] -> m Object
forall (m :: * -> *) e a.
(Nvim m, MonadDeepError e RpcError m, MsgpackDecode a) =>
Text -> [Object] -> m a
vimCallFunction Text
"exists" [Text -> Object
forall a. MsgpackEncode a => a -> Object
toMsgpack Text
entity]

vimDoesExist ::
  NvimE e m =>
  Text ->
  m Bool
vimDoesExist :: Text -> m Bool
vimDoesExist Text
entity =
  (Object -> Bool) -> m Object -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Either (Doc AnsiStyle) () -> Bool
forall a b. Either a b -> Bool
isRight (Either (Doc AnsiStyle) () -> Bool)
-> (Object -> Either (Doc AnsiStyle) ()) -> Object -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Object -> Either (Doc AnsiStyle) ()
existsResult) (Text -> m Object
forall e (m :: * -> *). NvimE e m => Text -> m Object
vimExists Text
entity)

function ::
  NvimE e m =>
  Text ->
  m Bool
function :: Text -> m Bool
function Text
name =
  Text -> m Bool
forall e (m :: * -> *). NvimE e m => Text -> m Bool
vimDoesExist (Text
"*" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name)

waitForFunction ::
  NvimE e m =>
  MonadIO m =>
  Text ->
  Retry ->
  m (Either (Doc AnsiStyle) ())
waitForFunction :: Text -> Retry -> m (Either (Doc AnsiStyle) ())
waitForFunction Text
name =
  m Object
-> (Object -> m (Either (Doc AnsiStyle) ()))
-> Retry
-> m (Either (Doc AnsiStyle) ())
forall e (m :: * -> *) b.
(NvimE e m, MonadIO m) =>
m Object
-> (Object -> m (Either (Doc AnsiStyle) b))
-> Retry
-> m (Either (Doc AnsiStyle) b)
waitFor m Object
thunk (Either (Doc AnsiStyle) () -> m (Either (Doc AnsiStyle) ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (Doc AnsiStyle) () -> m (Either (Doc AnsiStyle) ()))
-> (Object -> Either (Doc AnsiStyle) ())
-> Object
-> m (Either (Doc AnsiStyle) ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Object -> Either (Doc AnsiStyle) ()
existsResult)
  where
    thunk :: m Object
thunk = Text -> m Object
forall e (m :: * -> *). NvimE e m => Text -> m Object
vimExists (Text
"*" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name)

waitForFunctionResult ::
  NvimE e m =>
  MonadIO m =>
  Eq a =>
  Show a =>
  MsgpackDecode a =>
  Text ->
  a ->
  Retry ->
  m (Either (Doc AnsiStyle) ())
waitForFunctionResult :: Text -> a -> Retry -> m (Either (Doc AnsiStyle) ())
waitForFunctionResult Text
name a
a Retry
retry' =
  Text -> Retry -> m (Either (Doc AnsiStyle) ())
forall e (m :: * -> *).
(NvimE e m, MonadIO m) =>
Text -> Retry -> m (Either (Doc AnsiStyle) ())
waitForFunction Text
name Retry
retry' m (Either (Doc AnsiStyle) ())
-> (Either (Doc AnsiStyle) () -> m (Either (Doc AnsiStyle) ()))
-> m (Either (Doc AnsiStyle) ())
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Right ()
_ -> m Object
-> (Object -> m (Either (Doc AnsiStyle) ()))
-> Retry
-> m (Either (Doc AnsiStyle) ())
forall e (m :: * -> *) b.
(NvimE e m, MonadIO m) =>
m Object
-> (Object -> m (Either (Doc AnsiStyle) b))
-> Retry
-> m (Either (Doc AnsiStyle) b)
waitFor m Object
thunk (Either (Doc AnsiStyle) () -> m (Either (Doc AnsiStyle) ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (Doc AnsiStyle) () -> m (Either (Doc AnsiStyle) ()))
-> (Object -> Either (Doc AnsiStyle) ())
-> Object
-> m (Either (Doc AnsiStyle) ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either (Doc AnsiStyle) a -> Either (Doc AnsiStyle) ()
check (Either (Doc AnsiStyle) a -> Either (Doc AnsiStyle) ())
-> (Object -> Either (Doc AnsiStyle) a)
-> Object
-> Either (Doc AnsiStyle) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Object -> Either (Doc AnsiStyle) a
forall a. MsgpackDecode a => Object -> Either (Doc AnsiStyle) a
fromMsgpack) Retry
retry'
    Left Doc AnsiStyle
e -> Either (Doc AnsiStyle) () -> m (Either (Doc AnsiStyle) ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc AnsiStyle -> Either (Doc AnsiStyle) ()
forall a b. a -> Either a b
Left Doc AnsiStyle
e)
  where
    thunk :: m Object
thunk = Text -> [Object] -> m Object
forall (m :: * -> *) e a.
(Nvim m, MonadDeepError e RpcError m, MsgpackDecode a) =>
Text -> [Object] -> m a
vimCallFunction Text
name []
    check :: Either (Doc AnsiStyle) a -> Either (Doc AnsiStyle) ()
check (Right a
a') | a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
a' =
      () -> Either (Doc AnsiStyle) ()
forall a b. b -> Either a b
Right ()
    check (Right a
a') =
      Doc AnsiStyle -> Either (Doc AnsiStyle) ()
forall a b. a -> Either a b
Left (Doc AnsiStyle -> Either (Doc AnsiStyle) ())
-> Doc AnsiStyle -> Either (Doc AnsiStyle) ()
forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle
"results differ:" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> a -> Doc AnsiStyle
forall b a. (Show a, IsString b) => a -> b
show a
a Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"/" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> a -> Doc AnsiStyle
forall b a. (Show a, IsString b) => a -> b
show a
a'
    check (Left Doc AnsiStyle
e) =
      Doc AnsiStyle -> Either (Doc AnsiStyle) ()
forall a b. a -> Either a b
Left (Doc AnsiStyle -> Either (Doc AnsiStyle) ())
-> Doc AnsiStyle -> Either (Doc AnsiStyle) ()
forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle
"weird return type: " Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
e