{- |
Module      :  Neovim.Test
Description :  Testing functions
Copyright   :  (c) Sebastian Witte
License     :  Apache-2.0

Maintainer  :  woozletoff@gmail.com
Stability   :  experimental
Portability :  GHC

-}
module Neovim.Test (
    testWithEmbeddedNeovim,
    Seconds(..),
    ) where

import           Neovim
import           Neovim.API.Text
import qualified Neovim.Context.Internal as Internal
import           Neovim.RPC.Common       (RPCConfig, newRPCConfig)
import           Neovim.RPC.EventHandler (runEventHandler)
import           Neovim.RPC.SocketReader (runSocketReader)

import Control.Monad.Reader                      (runReaderT)
import Control.Monad.Trans.Resource              (runResourceT)
import Data.Text.Prettyprint.Doc                 (annotate, vsep)
import Data.Text.Prettyprint.Doc.Render.Terminal (Color (..), color)
import GHC.IO.Exception                          (ioe_filename)
import Path
import Path.IO
import System.Exit                               (ExitCode (..))
import System.IO                                 (Handle)
import System.Process.Typed
import UnliftIO.Async                            (async, cancel)
import UnliftIO.Concurrent                       (threadDelay)
import UnliftIO.Exception
import UnliftIO.STM                              (atomically, putTMVar)

-- | Type synonym for 'Word'.
newtype Seconds = Seconds Word


-- | Run the given 'Neovim' action according to the given parameters.
-- The embedded neovim instance is started without a config (i.e. it is passed
-- @-u NONE@).
--
-- If you want to run your tests purely from haskell, you have to setup
-- the desired state of neovim with the help of the functions in
-- "Neovim.API.String".
testWithEmbeddedNeovim
    :: Maybe (Path b File) -- ^ Optional path to a file that should be opened
    -> Seconds             -- ^ Maximum time (in seconds) that a test is allowed to run
    -> env                 -- ^ Read-only configuration
    -> Neovim env a        -- ^ Test case
    -> IO ()
testWithEmbeddedNeovim :: Maybe (Path b File) -> Seconds -> env -> Neovim env a -> IO ()
testWithEmbeddedNeovim Maybe (Path b File)
file Seconds
timeout env
r (Internal.Neovim ResourceT (ReaderT (Config env) IO) a
a) =
    IO ()
runTest IO () -> (IOException -> IO ()) -> IO ()
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` IOException -> IO ()
catchIfNvimIsNotOnPath
  where
    runTest :: IO ()
runTest = do
        (Process Handle Handle ()
nvimProcess, Config RPCConfig
cfg, IO ()
cleanUp) <- Maybe (Path b File)
-> Seconds
-> IO (Process Handle Handle (), Config RPCConfig, IO ())
forall b.
Maybe (Path b File)
-> Seconds
-> IO (Process Handle Handle (), Config RPCConfig, IO ())
startEmbeddedNvim Maybe (Path b File)
file Seconds
timeout

        let testCfg :: Config env
testCfg = env -> Config RPCConfig -> Config env
forall env anotherEnv. env -> Config anotherEnv -> Config env
Internal.retypeConfig env
r Config RPCConfig
cfg

        IO a -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO a -> IO ()) -> IO a -> IO ()
forall a b. (a -> b) -> a -> b
$ ReaderT (Config env) IO a -> Config env -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (ResourceT (ReaderT (Config env) IO) a -> ReaderT (Config env) IO a
forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
runResourceT ResourceT (ReaderT (Config env) IO) a
a) Config env
testCfg

        -- vim_command isn't asynchronous, so we need to avoid waiting for the
        -- result of the operation since neovim cannot send a result if it
        -- has quit.
        let Internal.Neovim ResourceT (ReaderT (Config env) IO) ()
q = Text -> forall env. Neovim env ()
vim_command Text
"qa!"
        Async ()
testRunner <- IO () -> IO (Async ())
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a)
async (IO () -> IO (Async ()))
-> (IO () -> IO ()) -> IO () -> IO (Async ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ ReaderT (Config env) IO () -> Config env -> IO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (ResourceT (ReaderT (Config env) IO) ()
-> ReaderT (Config env) IO ()
forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
runResourceT ResourceT (ReaderT (Config env) IO) ()
forall env. ResourceT (ReaderT (Config env) IO) ()
q) Config env
testCfg

        Process Handle Handle () -> IO ExitCode
forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
Process stdin stdout stderr -> m ExitCode
waitExitCode Process Handle Handle ()
nvimProcess IO ExitCode -> (ExitCode -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            ExitFailure Int
i ->
                String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Neovim returned with an exit status of: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i

            ExitCode
ExitSuccess ->
                () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Async () -> IO ()
forall (m :: * -> *) a. MonadIO m => Async a -> m ()
cancel Async ()
testRunner
        IO ()
cleanUp


catchIfNvimIsNotOnPath :: IOException -> IO ()
catchIfNvimIsNotOnPath :: IOException -> IO ()
catchIfNvimIsNotOnPath IOException
e = case IOException -> Maybe String
ioe_filename IOException
e of
    Just String
"nvim" ->
        Doc AnsiStyle -> IO ()
putDoc (Doc AnsiStyle -> IO ())
-> (Doc AnsiStyle -> Doc AnsiStyle) -> Doc AnsiStyle -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
Red) (Doc AnsiStyle -> IO ()) -> Doc AnsiStyle -> IO ()
forall a b. (a -> b) -> a -> b
$ [Doc AnsiStyle] -> Doc AnsiStyle
forall ann. [Doc ann] -> Doc ann
vsep
            [ Doc AnsiStyle
"The neovim executable 'nvim' is not on the PATH."
            , Doc AnsiStyle
"You may not be testing fully!"
            ]

    Maybe String
_           ->
        IOException -> IO ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO IOException
e

startEmbeddedNvim
    :: Maybe (Path b File)
    -> Seconds
    -> IO (Process Handle Handle (), Internal.Config RPCConfig, IO ())
startEmbeddedNvim :: Maybe (Path b File)
-> Seconds
-> IO (Process Handle Handle (), Config RPCConfig, IO ())
startEmbeddedNvim Maybe (Path b File)
file (Seconds Word
timeout) = do
    [String]
args <- case Maybe (Path b File)
file of
                Maybe (Path b File)
Nothing ->
                    [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return []

                Just Path b File
f -> do
                    -- 'fail' should work with most testing frameworks
                    IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (Path b File -> IO Bool
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path b File
f) (IO () -> IO ()) -> (String -> IO ()) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"File not found: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Path b File -> String
forall a. Show a => a -> String
show Path b File
f
                    [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [Path b File -> String
forall b t. Path b t -> String
toFilePath Path b File
f]

    Process Handle Handle ()
nvimProcess <- ProcessConfig Handle Handle () -> IO (Process Handle Handle ())
forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
ProcessConfig stdin stdout stderr
-> m (Process stdin stdout stderr)
startProcess
        (ProcessConfig Handle Handle () -> IO (Process Handle Handle ()))
-> ProcessConfig Handle Handle () -> IO (Process Handle Handle ())
forall a b. (a -> b) -> a -> b
$ StreamSpec 'STInput Handle
-> ProcessConfig () Handle () -> ProcessConfig Handle Handle ()
forall stdin stdin0 stdout stderr.
StreamSpec 'STInput stdin
-> ProcessConfig stdin0 stdout stderr
-> ProcessConfig stdin stdout stderr
setStdin StreamSpec 'STInput Handle
forall (anyStreamType :: StreamType).
StreamSpec anyStreamType Handle
createPipe
        (ProcessConfig () Handle () -> ProcessConfig Handle Handle ())
-> ProcessConfig () Handle () -> ProcessConfig Handle Handle ()
forall a b. (a -> b) -> a -> b
$ StreamSpec 'STOutput Handle
-> ProcessConfig () () () -> ProcessConfig () Handle ()
forall stdout stdin stdout0 stderr.
StreamSpec 'STOutput stdout
-> ProcessConfig stdin stdout0 stderr
-> ProcessConfig stdin stdout stderr
setStdout StreamSpec 'STOutput Handle
forall (anyStreamType :: StreamType).
StreamSpec anyStreamType Handle
createPipe
        (ProcessConfig () () () -> ProcessConfig () Handle ())
-> ProcessConfig () () () -> ProcessConfig () Handle ()
forall a b. (a -> b) -> a -> b
$ String -> [String] -> ProcessConfig () () ()
proc String
"nvim" ([String
"-n",String
"-u",String
"NONE",String
"--embed"] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
args)

    Config RPCConfig
cfg <- IO (Maybe String) -> IO RPCConfig -> IO (Config RPCConfig)
forall env. IO (Maybe String) -> IO env -> IO (Config env)
Internal.newConfig (Maybe String -> IO (Maybe String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
forall a. Maybe a
Nothing) IO RPCConfig
forall (io :: * -> *). (Applicative io, MonadIO io) => io RPCConfig
newRPCConfig

    Async ()
socketReader <- IO () -> IO (Async ())
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a)
async (IO () -> IO (Async ()))
-> (IO () -> IO ()) -> IO () -> IO (Async ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ Handle -> Config RPCConfig -> IO ()
runSocketReader
                    (Process Handle Handle () -> Handle
forall stdin stdout stderr. Process stdin stdout stderr -> stdout
getStdout Process Handle Handle ()
nvimProcess)
                    (Config RPCConfig
cfg { pluginSettings :: Maybe (PluginSettings RPCConfig)
Internal.pluginSettings = Maybe (PluginSettings RPCConfig)
forall a. Maybe a
Nothing })

    Async ()
eventHandler <- IO () -> IO (Async ())
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a)
async (IO () -> IO (Async ()))
-> (IO () -> IO ()) -> IO () -> IO (Async ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ Handle -> Config RPCConfig -> IO ()
runEventHandler
                    (Process Handle Handle () -> Handle
forall stdin stdout stderr. Process stdin stdout stderr -> stdin
getStdin Process Handle Handle ()
nvimProcess)
                    (Config RPCConfig
cfg { pluginSettings :: Maybe (PluginSettings RPCConfig)
Internal.pluginSettings = Maybe (PluginSettings RPCConfig)
forall a. Maybe a
Nothing })

    STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TMVar FunctionMap -> FunctionMap -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar
                    (Config RPCConfig -> TMVar FunctionMap
forall env. Config env -> TMVar FunctionMap
Internal.globalFunctionMap Config RPCConfig
cfg)
                    ([FunctionMapEntry] -> FunctionMap
Internal.mkFunctionMap [])

    Async ()
timeoutAsync <- IO () -> IO (Async ())
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a)
async (IO () -> IO (Async ()))
-> (IO () -> IO ()) -> IO () -> IO (Async ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ do
        Int -> IO ()
forall (m :: * -> *). MonadIO m => Int -> m ()
threadDelay (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ (Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
timeout) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000
        Process Handle Handle () -> IO (Maybe ExitCode)
forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
Process stdin stdout stderr -> m (Maybe ExitCode)
getExitCode Process Handle Handle ()
nvimProcess IO (Maybe ExitCode) -> (Maybe ExitCode -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO () -> (ExitCode -> IO ()) -> Maybe ExitCode -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Process Handle Handle () -> IO ()
forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
Process stdin stdout stderr -> m ()
stopProcess Process Handle Handle ()
nvimProcess) (\ExitCode
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())

    let cleanUp :: IO ()
cleanUp = (Async () -> IO ()) -> [Async ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Async () -> IO ()
forall (m :: * -> *) a. MonadIO m => Async a -> m ()
cancel [Async ()
socketReader, Async ()
eventHandler, Async ()
timeoutAsync]

    (Process Handle Handle (), Config RPCConfig, IO ())
-> IO (Process Handle Handle (), Config RPCConfig, IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Process Handle Handle ()
nvimProcess, Config RPCConfig
cfg, IO ()
cleanUp)