FunctionCall.hs

{-# LANGUAGE LambdaCase      #-}
{-# LANGUAGE RecordWildCards #-}
{- |
Module      :  Neovim.RPC.FunctionCall
Description :  Functions for calling functions
Copyright   :  (c) Sebastian Witte
License     :  Apache-2.0

Maintainer  :  woozletoff@gmail.com
Stability   :  experimental

-}
module Neovim.RPC.FunctionCall (
    acall,
    acall',
    scall,
    scall',
    atomically',
    wait,
    wait',
    waitErr,
    waitErr',
    respond,
    ) where

import           Neovim.Classes
import           Neovim.Context
import qualified Neovim.Context.Internal    as Internal
import           Neovim.Plugin.Classes      (FunctionName)
import           Neovim.Plugin.IPC.Classes
import qualified Neovim.RPC.Classes         as MsgpackRPC

import           Control.Applicative
import           Control.Concurrent.STM
import           Control.Monad.Reader
import           Data.MessagePack
import           Data.Monoid

import           Prelude

unexpectedException :: String -> err -> a
unexpectedException fn _ = error $
    "Function threw an exception even though it was declared not to throw one: "
    <> fn


withIgnoredException :: (Functor f, NvimObject result)
                     => FunctionName -- ^ For better error messages
                     -> f (Either err result)
                     -> f result
withIgnoredException fn = fmap (either ((unexpectedException . show) fn) id)


-- | Helper function that concurrently puts a 'Message' in the event queue and returns an 'STM' action that returns the result.
acall :: (NvimObject result)
     => FunctionName
     -> [Object]
     -> Neovim r st (STM (Either Object result))
acall fn parameters = do
    q <- Internal.asks' Internal.eventQueue
    mv <- liftIO newEmptyTMVarIO
    timestamp <- liftIO getCurrentTime
    atomically' . writeTQueue q . SomeMessage $ FunctionCall fn parameters mv timestamp
    return $ convertObject <$> readTMVar mv
  where
    convertObject = \case
        Left e -> Left e
        Right o -> case fromObject o of
            Left e -> Left (toObject e)
            Right r -> Right r


acall' :: (NvimObject result)
       => FunctionName
       -> [Object]
       -> Neovim r st (STM result)
acall' fn parameters = withIgnoredException fn <$> acall fn parameters


-- | Call a neovim function synchronously. This function blocks until the
-- result is available.
scall :: (NvimObject result)
      => FunctionName
      -> [Object]      -- ^ Parameters in an 'Object' array
      -> Neovim r st (Either Object result)
      -- ^ result value of the call or the thrown exception
scall fn parameters = acall fn parameters >>= atomically'


scall' :: NvimObject result => FunctionName -> [Object] -> Neovim r st result
scall' fn = withIgnoredException fn . scall fn


-- | Lifted variant of 'atomically'.
atomically' :: (MonadIO io) => STM result -> io result
atomically' = liftIO . atomically


-- | Wait for the result of the STM action.
--
-- This action possibly blocks as it is an alias for
-- @ \ioSTM -> ioSTM >>= liftIO . atomically@.
wait :: Neovim r st (STM result) -> Neovim r st result
wait = (=<<) atomically'


-- | Variant of 'wait' that discards the result.
wait' :: Neovim r st (STM result) -> Neovim r st ()
wait' = void . wait


-- | Wait for the result of the 'STM' action and call @'err' . (loc++) . show@
-- if the action returned an error.
waitErr :: (Show e)
        => String                              -- ^ Prefix error message with this.
        -> Neovim r st (STM (Either e result)) -- ^ Function call to neovim
        -> Neovim r st result
waitErr loc act = wait act >>= either (err . (loc++) . show) return


-- | 'waitErr' that discards the result.
waitErr' :: (Show e)
         => String
         -> Neovim r st (STM (Either e result))
         -> Neovim r st ()
waitErr' loc = void . waitErr loc


-- | Send the result back to the neovim instance.
respond :: (NvimObject result) => Request -> Either String result -> Neovim r st ()
respond Request{..} result = do
    q <- Internal.asks' Internal.eventQueue
    atomically' . writeTQueue q . SomeMessage . MsgpackRPC.Response reqId $
        either (Left . toObject) (Right . toObject) result