nvim-hs 2.3.2.0 → 2.3.2.1
raw patch · 75 files changed
+5574/−5475 lines, 75 filesdep −HUnitdep −pathdep −path-iodep ~basedep ~cereal-conduitdep ~conduit
Dependencies removed: HUnit, path, path-io, resourcet, stm, transformers, transformers-base
Dependency ranges changed: base, cereal-conduit, conduit, megaparsec, messagepack, mtl, prettyprinter, template-haskell-compat-v0208, typed-process, unliftio, unliftio-core
Files
- library/Neovim.hs +0/−476
- library/Neovim/API/ByteString.hs +0/−21
- library/Neovim/API/Parser.hs +0/−170
- library/Neovim/API/String.hs +0/−25
- library/Neovim/API/TH.hs +0/−580
- library/Neovim/API/Text.hs +0/−21
- library/Neovim/Classes.hs +0/−450
- library/Neovim/Compat/Megaparsec.hs +0/−30
- library/Neovim/Config.hs +0/−31
- library/Neovim/Context.hs +0/−85
- library/Neovim/Context/Internal.hs +0/−316
- library/Neovim/Debug.hs +0/−227
- library/Neovim/Exceptions.hs +0/−51
- library/Neovim/Log.hs +0/−58
- library/Neovim/Main.hs +0/−215
- library/Neovim/Plugin.hs +0/−336
- library/Neovim/Plugin/Classes.hs +0/−451
- library/Neovim/Plugin/IPC.hs +0/−18
- library/Neovim/Plugin/IPC/Classes.hs +0/−167
- library/Neovim/Plugin/Internal.hs +0/−63
- library/Neovim/Quickfix.hs +0/−205
- library/Neovim/RPC/Classes.hs +0/−101
- library/Neovim/RPC/Common.hs +0/−141
- library/Neovim/RPC/EventHandler.hs +0/−104
- library/Neovim/RPC/FunctionCall.hs +0/−108
- library/Neovim/RPC/SocketReader.hs +0/−202
- library/Neovim/Test.hs +0/−214
- library/Neovim/Util.hs +0/−32
- nvim-hs.cabal +53/−92
- src/Neovim.hs +476/−0
- src/Neovim/API/ByteString.hs +21/−0
- src/Neovim/API/Parser.hs +171/−0
- src/Neovim/API/String.hs +25/−0
- src/Neovim/API/TH.hs +579/−0
- src/Neovim/API/Text.hs +21/−0
- src/Neovim/Classes.hs +451/−0
- src/Neovim/Compat/Megaparsec.hs +30/−0
- src/Neovim/Config.hs +31/−0
- src/Neovim/Context.hs +86/−0
- src/Neovim/Context/Internal.hs +347/−0
- src/Neovim/Debug.hs +229/−0
- src/Neovim/Exceptions.hs +53/−0
- src/Neovim/Log.hs +58/−0
- src/Neovim/Main.hs +242/−0
- src/Neovim/Plugin.hs +381/−0
- src/Neovim/Plugin/Classes.hs +453/−0
- src/Neovim/Plugin/IPC.hs +18/−0
- src/Neovim/Plugin/IPC/Classes.hs +168/−0
- src/Neovim/Plugin/Internal.hs +63/−0
- src/Neovim/Quickfix.hs +212/−0
- src/Neovim/RPC/Classes.hs +103/−0
- src/Neovim/RPC/Common.hs +142/−0
- src/Neovim/RPC/EventHandler.hs +127/−0
- src/Neovim/RPC/FunctionCall.hs +108/−0
- src/Neovim/RPC/SocketReader.hs +210/−0
- src/Neovim/Test.hs +214/−0
- src/Neovim/Util.hs +32/−0
- test-suite/AsyncFunctionSpec.hs +0/−34
- test-suite/Neovim/API/THSpec.hs +0/−117
- test-suite/Neovim/API/THSpecFunctions.hs +0/−21
- test-suite/Neovim/EmbeddedRPCSpec.hs +0/−88
- test-suite/Neovim/EventSubscriptionSpec.hs +0/−63
- test-suite/Neovim/Plugin/ClassesSpec.hs +0/−64
- test-suite/Neovim/RPC/CommonSpec.hs +0/−20
- test-suite/Neovim/RPC/SocketReaderSpec.hs +0/−77
- test-suite/Spec.hs +0/−1
- tests/API/THSpec.hs +118/−0
- tests/API/THSpecFunctions.hs +21/−0
- tests/AsyncFunctionSpec.hs +32/−0
- tests/EmbeddedRPCSpec.hs +72/−0
- tests/EventSubscriptionSpec.hs +65/−0
- tests/Plugin/ClassesSpec.hs +64/−0
- tests/RPC/CommonSpec.hs +20/−0
- tests/RPC/SocketReaderSpec.hs +77/−0
- tests/Spec.hs +1/−0
− library/Neovim.hs
@@ -1,476 +0,0 @@-{- |-Module : Neovim-Description : API for the neovim plugin provider /nvim-hs/-Copyright : (c) Sebastian Witte-License : Apache-2.0--Maintainer : woozletoff@gmail.com-Stability : experimental-Portability : GHC (due to Template Haskell)--This module should contain all the things you need to write neovim plugins in-your favorite language! @:-)@--The documentation in this module should provide every information you need to start-writing plugins.--}-module Neovim (- -- * Installation- -- $installation-- -- * Tutorial- -- ** Motivation- -- $overview- -- ** Combining existing plugins- -- $existingplugins- Neovim,- neovim,- NeovimConfig(..),- defaultConfig,- def,--- -- ** Creating a plugin- -- $creatingplugins- NeovimPlugin(..),- Plugin(..),- NvimObject(..),- (+:),- Dictionary,- Object(..),- wrapPlugin,- function,- function',- command,- command',- autocmd,- Synchronous(..),- CommandOption(..),- RangeSpecification(..),- CommandArguments(..),- AutocmdOptions(..),- addAutocmd,-- ask,- asks,-- -- ** Subscribing to notifications or events- Subscription,- subscribe,- unsubscribe,- NeovimEventId(..),-- -- ** Creating a stateful plugin- -- $statefulplugin-- -- ** Calling remote functions- -- $remote- wait,- wait',- err,- errOnInvalidResult,- catchNeovimException,- NeovimException(..),-- -- * Unsorted exports- -- This section contains just a bunch of more or less useful functions which- -- were not introduced in any of the previous sections.- liftIO,- whenM,- unlessM,- docToObject,- docFromObject,- Doc,- AnsiStyle,- Pretty(..),- putDoc,- exceptionToDoc,- Priority(..),- module Control.Monad,- module Control.Applicative,- module Data.Monoid,- module Data.Int,- module Data.Word,-- ) where--import Control.Applicative-import Control.Monad (void)-import Control.Monad.IO.Class (liftIO)-import Data.Default (def)-import Data.Int (Int16, Int32, Int64, Int8)-import Data.MessagePack (Object (..))-import Data.Monoid-import Data.Word (Word, Word16, Word32, Word8)-import Neovim.API.TH (autocmd, command, command',- function, function')-import Neovim.Classes (Dictionary, NvimObject (..),- Doc, AnsiStyle, Pretty(..),- docFromObject, docToObject, (+:))-import Neovim.Config (NeovimConfig (..))-import Neovim.Context (Neovim,- NeovimException(..),- exceptionToDoc,- ask, asks, err,- errOnInvalidResult, subscribe, unsubscribe)-import Neovim.Main (neovim)-import Neovim.Exceptions (catchNeovimException)-import Neovim.Plugin (addAutocmd)-import Neovim.Plugin.Classes (AutocmdOptions (..),- CommandArguments (..),- CommandOption (CmdBang, CmdCount, CmdRange, CmdRegister, CmdSync),- RangeSpecification (..),- Synchronous (..),- Subscription, NeovimEventId(..))-import Neovim.Plugin.Internal (NeovimPlugin (..), Plugin (..),- wrapPlugin)-import Neovim.RPC.FunctionCall (wait, wait')-import Neovim.Util (unlessM, whenM)-import System.Log.Logger (Priority (..))-import Prettyprinter.Render.Terminal (putDoc)--- Installation-{- $installation--Installation instructions are in the README.md file that comes with the source-of this package. It is also on the repositories front page.---}---- Tutorial--- Overview-{- $overview-An @nvim-hs@ plugin is just a collection of haskell functions that can be-called from neovim.--As a user of plugins, you basically have two choices. You can start every-plugin in a separate process and use normal vim plugin management strategies-such as <https://github.com/junegunn/vim-plug vim-plug>-or <https://github.com/tpope/vim-pathogen pathogen>.-Alternatively, you can create a haskell project and depend on the plugins-you want to use and plumb them together. This plumbing is equivalent to-writing a plugin.--Since you are reading haddock documentation, you probably want the latter, so-just keep reading. @:-)@---}----- Combining Existing Plugins-{- $existingplugins-The easiest way to start is to use the stack template as described in the-@README.md@ of this package. If you initialize it in your neovim configuration-directory (@~\/.config\/nvim@ on linux-based systems), it should automatically be-compiled and run with two simple example plugins.--You have to define a haskell project that depends on this package and-contains an executable secion within a main file that looks something like this:--@-import TestPlugin.ExamplePlugin (examplePlugin)--main = 'neovim' 'def'- { 'plugins' = [ examplePlugin ] ++ 'plugins' 'defaultConfig'- }-@---/nvim-hs/ is all about importing and creating plugins. This is done following a-concise API. Let's start by making a given plugin available inside-our plugin provider. Assuming that we have installed a cabal package that exports-an @examplePlugin@ from the module @TestPlugin.ExamplePlugin@, a minimal-main file would look something like this:--That's all you have to do! Multiple plugins are simply imported and put in a-list.---}---- | Default configuration options for /nvim-hs/. If you want to keep the--- default plugins enabled, you can define your config like this:------ @--- main = 'neovim' 'defaultConfig'--- { plugins = plugins defaultConfig ++ myPlugins--- }--- @----defaultConfig :: NeovimConfig-defaultConfig = Config- { plugins = []- , logOptions = Nothing- }----- Creating a plugin-{- $creatingplugins-Creating plugins isn't difficult either. You just have to follow and survive the-compile time errors of seemingly valid code. This may sound scary, but it is not-so bad. We will cover most pitfalls in the following paragraphs and if there-isn't a solution for your error, you can always ask any friendly Haskeller in-\#haskell on @irc.freenode.net@!--Enough scary stuff said for now, let's write a plugin!-Due to a stage restriction in GHC when using Template Haskell-(i.e. code generation), we must define-our functions in a different module than @\$XDG_CONFIG_HOME\/nvim\/nvim.hs@.-(I'm assuming here, that you use @\$XDG_CONFIG_HOME\/nvim\/@ as the base-directory for historical reasons and because it might be an appropriate place.)-This is a bit unfortunate, but it will save you a lot of boring boilerplate and-it will present you with helpful error messages if your plugin's functions do-not work together with neovim.--So, let\'s write a plugin that calculates the @n@th Fibonacci number. Don\'t we all-love those!--File @\~\/.config\/nvim\/lib\/Fibonacci\/Plugin.hs@:--@-module Fibonacci.Plugin (fibonacci) where--import "Neovim"--\-\- \| Neovim is not really good with big numbers, so we return a 'String' here.-fibonacci :: 'Int' -> 'Neovim' env 'String'-fibonacci n = 'return' . 'show' \$ fibs !! n- where- fibs :: [Integer]- fibs = 0:1:'scanl1' (+) fibs-@--File @\~\/.config\/nvim\/lib\/Fibonacci.hs@:--@-\{\-\# LANGUAGE TemplateHaskell \#\-\}-module Fibonacci (plugin) where--import "Neovim"-import Fibonacci.Plugin (fibonacci)--plugin :: 'Neovim' () 'NeovimPlugin'-plugin = 'wrapPlugin' Plugin- { 'environment' = ()- , 'exports' = [ $('function'' 'fibonacci) 'Sync' ]- }-@--File @~\/.config\/nvim\/nvim.hs@:--@-import "Neovim"--import qualified Fibonacci as Fibonacci--main :: 'IO' ()-main = 'neovim' 'defaultConfig'- { 'plugins' = 'plugins' 'defaultConfig' ++ [ Fibonacci.plugin ]- }-@--Let's analyze how it works. The module @Fibonacci.Plugin@ simply defines a function-that takes the @n@th element of the infinite list of Fibonacci numbers. Even though-the definition is very concise and asthetically pleasing, the important part is the-type signature for @fibonacci@. Similarly how @main :: IO ()@ works in normal Haskell-programs, 'Neovim' is the environment we need for plugins. Internally, it stores a-few things that are needed to communicate with neovim, but that shouldn't bother you-too much. Simply remember that every plugin function must have a function signature-whose last element is of type @'Neovim' env something@. The result of @fibonacci@-is 'String' because neovim cannot handle big numbers so well. :-)-You can use any argument or result type as long as it is an instance of 'NvimObject'.--The second part of of the puzzle, which is the definition of @plugin@-in @~\/.config\/nvim\/lib\/Fibonacci.hs@, shows what a plugin is. It is essentially-an empty environment and a list of functions, commands or autocommands in the context of vim-terminology. In the end, all of those things map to a function at the side-of /nvim-hs/. If you really want to know what the distinction between those is, you-have to consult the @:help@ pages of neovim (e.g. @:help :function@, @:help :command@-and @:help :autocmd@). What's relevant from the side of /nvim-hs/ is the environment.-The environment is a data type that is avaiable to all exported functions of your-plugin. This example does not make use of anything of that environment, so-we used '()', also known as unit, as our environment. The definition of-@fibonacci@ uses a type variable @env@ as it does not access the environment and-can handle any environment. If you want to access the environment, you can call-'ask' or 'asks' if you are inside a 'Neovim' environment. An example that shows-you how to use it can be found in a later chapter.--Now to the magical part: @\$('function'' 'fibonacci)@. This is a so called-Template Haskell splice and this is why you need-@\{\-\# LANGUAGE TemplateHaskell \#\-\}@ at the top of your Haskell file. This-splice simply generates Haskell code that, in this case, still needs a value-of type 'Synchronous' which indicates whether calling the function will make-neovim wait for its result or not. Internally, the expression-@\$('function'' 'fibonacci) 'Sync'@ creates a value that contains all the-necessary information to properly register the function with neovim. Note the-prime symbol before the function name! This would have probably caused you-some trouble if I haven't mentioned it here! Template Haskell simply requires-you to put that in front of function names that are passed in a splice.--If you compile this and restart the plugin, you can calculate the 2000th Fibonacci-number like as if it were a normal vim-script function:--@-:echo Fibonacci(2000)-@--You can also directly insert the result inside any text file opened with neovim-by using the evaluation register by pressing the following key sequence in insert-mode:--@-\<C-r\>=Fibonacci(2000)-@--The haddock documentation will now list all the things we have used up until now.-Afterwards, there is a plugin with state which uses the environment.---}--- Creating a stateful plugin-{- $statefulplugin-Now that we are a little bit comfortable with the interface provided by /nvim-hs/,-we can start to write a more complicated plugin. Let's create a random number-generator!--File @~\/.config\/nvim\/lib\/Random\/Plugin.hs@:--@-module Random.Plugin (nextRandom, setNextRandom) where--import "Neovim"--import System.Random (newStdGen, randoms)-import UnliftIO.STM (TVar, atomically, readTVar, modifyTVar, newTVarIO)---- You may want to define a type alias for your plugin, so that if you change--- your environment, you don't have to change all type signatures.------ If I were to write a real plugin, I would probably also create a data type--- instead of directly using a TVar here.----type MyNeovim a = Neovim ('TVar' ['Int16']) a---- This function will create an initial environment for our random number--- generator. Note that the return type is the type of our environment.-randomNumbers :: Neovim startupEnv (TVar [Int16])-randomNumbers = do- g <- liftIO newStdGen -- Create a new seed for a pseudo random number generator- newTVarIO (randoms g) -- Put an infinite list of random numbers into a TVar---- | Get the next random number and update the state of the list.-nextRandom :: MyNeovim 'Int16'-nextRandom = do- tVarWithRandomNumbers <- 'ask'- atomically $ do- -- pick the head of our list of random numbers- r \<- 'head' <$> 'readTVar' tVarWithRandomNumbers-- -- Since we do not want to return the same number all over the place- -- remove the head of our list of random numbers- modifyTVar tVarWithRandomNumbers 'tail'-- 'return' r----- | You probably don't want this in a random number generator, but this shows--- hoy you can edit the state of a stateful plugin.-setNextRandom :: 'Int16' -> MyNeovim ()-setNextRandom n = do- tVarWithRandomNumbers <- 'ask'-- -- cons n to the front of the infinite list- atomically $ modifyTVar tVarWithRandomNumbers (n:)-@--File @~\/.config\/nvim\/lib\/Random.hs@:--@-\{\-\# LANGUAGE TemplateHaskell \#\-\}-module Random (plugin) where--import "Neovim"-import Random.Plugin (nextRandom, setNextRandom)-import "System.Random" ('newStdGen', 'randoms')--plugin :: 'Neovim' ('StartupConfig' 'NeovimConfig') () 'NeovimPlugin'-plugin = do- env <- randomNumbers- 'wrapPlugin' 'Plugin'- { environment = env- , 'exports' =- [ $('function'' 'nextRandom) 'Sync'- , $('function' \"SetNextRandom\" 'setNextRandom) 'Async'- ]- }-@--File @~\/.config\/nvim\/nvim.hs@:--@-import "Neovim"--import qualified Fibonacci as Fibonacci-import qualified Random as Random--main :: 'IO' ()-main = 'neovim' 'defaultConfig'- { 'plugins' = 'plugins' 'defaultConfig' ++ [ Fibonacci.plugin, Random.plugin ]- }-@---That wasn't too hard, was it? The definition is very similar to the previous-example, we just were able to mutate our state and share that with other-functions. Another noteworthy detail, in case you-are not familiar with it, is the use of 'liftIO' in front of 'newStdGen'. You-have to do this, because 'newStdGen' has type @'IO' 'StdGen'@ but the actions-inside the startup code are of type-@'Neovim' () something@. 'liftIO' lifts an-'IO' function so that it can be run inside the 'Neovim' context (or more-generally, any monad that implements the 'MonadIO' type class).--After you have saved these files (and removed any typos @:-)@), you can restart-/nvim-hs/ with @:RestartNvimhs@ and insert random numbers in your text files!--@-\<C-r\>=NextRandom()-@--You can also cheat and pretend you know the next number:--@-:call SetNextRandom(42)-@---}--- Calling remote functions-{- $remote-Calling remote functions is only possible inside a 'Neovim' context. There are-a few patterns of return values for the available functions. Let's start with-getting some abstract 'Buffer' object, test whether it is valid and then try-to rename it.--@-inspectBuffer :: 'Neovim' env ()-inspectBuffer = do- cb <- 'vim_get_current_buffer'- isValid <- 'buffer_is_valid' cb- when isValid $ do- let newName = "magic"- cbName \<- 'wait'' $ 'buffer_set_name' cb newName- case () of- _ | cbName == newName -> 'return' ()- _ -> 'err' $ "Renaming the current buffer failed!"-@--You may have noticed the 'wait'' function in there. Some functions have a return-type with 'STM' in it. This means that the function call is asynchronous. We can-'wait' (or 'wait'') for the result at the point at which we actually need it. In-this short example, we put the 'wait'' directly in front of the remote function-call because we want to inspect the result immediately, though. The other-functions either returned a result directly or they returned-@'Either' 'Object' something@ whose result we inspected ourselves. The 'err'-function directly terminates the current thread and sends the given error-message to neovim which the user immediately notices.--That's pretty much all there is to it.--}-
− library/Neovim/API/ByteString.hs
@@ -1,21 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE NoOverloadedStrings #-}--{- |-Module : Neovim.API.ByteString-Description : ByteString based API-Copyright : (c) Sebastian Witte-License : Apache-2.0--Maintainer : woozletoff@gmail.com-Stability : experimental-Portability : GHC--}-module Neovim.API.ByteString where--import Neovim.API.TH--$(generateAPI bytestringVectorTypeMap)
− library/Neovim/API/Parser.hs
@@ -1,170 +0,0 @@-{- |-Module : Neovim.API.Parser-Description : P.Parser for the msgpack output stram API-Copyright : (c) Sebastian Witte-License : Apache-2.0--Maintainer : woozletoff@gmail.com-Stability : experimental--}-module Neovim.API.Parser (- NeovimAPI (..),- NeovimFunction (..),- NeovimType (..),- parseAPI,-) where--import Neovim.Classes-import Neovim.OS (isWindows)--import Control.Applicative (optional)-import Control.Monad.Except (MonadError (throwError), forM)-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as LB-import Data.Map (Map)-import qualified Data.Map as Map-import Data.MessagePack (Object)-import Data.Serialize (decode)-import Neovim.Compat.Megaparsec as P (- MonadParsec (eof, try),- Parser,- char,- noneOf,- oneOf,- parse,- some,- space,- string,- (<|>),- )-import System.Process.Typed (proc, readProcessStdout_)-import UnliftIO.Exception (- SomeException,- catch,- )--import Prelude--data NeovimType- = SimpleType String- | NestedType NeovimType (Maybe Int)- | Void- deriving (Show, Eq)--{- | This data type contains simple information about a function as received- throudh the @nvim --api-info@ command.--}-data NeovimFunction = NeovimFunction- { -- | function name- name :: String- , -- | A list of type name and variable name.- parameters :: [(NeovimType, String)]- , -- | Indicator whether the function can fail/throws exceptions.- canFail :: Bool- , -- | Indicator whether the this function is asynchronous.- async :: Bool- , -- | Functions return type.- returnType :: NeovimType- }- deriving (Show)--{- | This data type represents the top-level structure of the @nvim --api-info@- output.--}-data NeovimAPI = NeovimAPI- { -- | The error types are defined by a name and an identifier.- errorTypes :: [(String, Int64)]- , -- | Extension types defined by neovim.- customTypes :: [(String, Int64)]- , -- | The remotely executable functions provided by the neovim api.- functions :: [NeovimFunction]- }- deriving (Show)---- | Run @nvim --api-info@ and parse its output.-parseAPI :: IO (Either (Doc AnsiStyle) NeovimAPI)-parseAPI = either (Left . pretty) extractAPI <$> go- where- go- | isWindows = readFromAPIFile- | otherwise = decodeAPI `catch` \(_ignored :: SomeException) -> readFromAPIFile--decodeAPI :: IO (Either String Object)-decodeAPI =- decode . LB.toStrict <$> readProcessStdout_ (proc "nvim" ["--api-info"])--extractAPI :: Object -> Either (Doc AnsiStyle) NeovimAPI-extractAPI apiObj =- fromObject apiObj >>= \apiMap ->- NeovimAPI- <$> extractErrorTypes apiMap- <*> extractCustomTypes apiMap- <*> extractFunctions apiMap--readFromAPIFile :: IO (Either String Object)-readFromAPIFile = (decode <$> B.readFile "api") `catch` returnNoApiForCodegeneratorErrorMessage- where- returnNoApiForCodegeneratorErrorMessage :: SomeException -> IO (Either String Object)- returnNoApiForCodegeneratorErrorMessage _ =- return . Left $- "The 'nvim' process could not be started and there is no file named 'api' in the working directory as a substitute."--oLookup :: (NvimObject o) => String -> Map String Object -> Either (Doc AnsiStyle) o-oLookup qry = maybe throwErrorMessage fromObject . Map.lookup qry- where- throwErrorMessage = throwError $ "No entry for:" <+> pretty qry--oLookupDefault :: (NvimObject o) => o -> String -> Map String Object -> Either (Doc AnsiStyle) o-oLookupDefault d qry m = maybe (return d) fromObject $ Map.lookup qry m--extractErrorTypes :: Map String Object -> Either (Doc AnsiStyle) [(String, Int64)]-extractErrorTypes objAPI = extractTypeNameAndID =<< oLookup "error_types" objAPI--extractTypeNameAndID :: Object -> Either (Doc AnsiStyle) [(String, Int64)]-extractTypeNameAndID m = do- types <- Map.toList <$> fromObject m- forM types $ \(errName, idMap) -> do- i <- oLookup "id" idMap- return (errName, i)--extractCustomTypes :: Map String Object -> Either (Doc AnsiStyle) [(String, Int64)]-extractCustomTypes objAPI = extractTypeNameAndID =<< oLookup "types" objAPI--extractFunctions :: Map String Object -> Either (Doc AnsiStyle) [NeovimFunction]-extractFunctions objAPI = mapM extractFunction =<< oLookup "functions" objAPI--toParameterlist :: [(String, String)] -> Either (Doc AnsiStyle) [(NeovimType, String)]-toParameterlist ps = forM ps $ \(t, n) -> do- t' <- parseType t- return (t', n)--extractFunction :: Map String Object -> Either (Doc AnsiStyle) NeovimFunction-extractFunction funDefMap =- NeovimFunction- <$> oLookup "name" funDefMap- <*> (oLookup "parameters" funDefMap >>= toParameterlist)- <*> oLookupDefault True "can_fail" funDefMap- <*> oLookupDefault False "async" funDefMap- <*> (oLookup "return_type" funDefMap >>= parseType)--parseType :: String -> Either (Doc AnsiStyle) NeovimType-parseType s = either (throwError . pretty . show) return $ parse (pType <* eof) s s--pType :: P.Parser NeovimType-pType = pArray P.<|> pVoid P.<|> pSimple--pVoid :: P.Parser NeovimType-pVoid = Void <$ (P.try (string "void") <* eof)--pSimple :: P.Parser NeovimType-pSimple = SimpleType <$> P.some (noneOf [',', ')'])--pArray :: P.Parser NeovimType-pArray =- NestedType- <$> (P.try (string "ArrayOf(") *> pType)- <*> optional pNum- <* char ')'--pNum :: P.Parser Int-pNum = read <$> (P.try (char ',') *> space *> P.some (oneOf ['0' .. '9']))
− library/Neovim/API/String.hs
@@ -1,25 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE NoOverloadedStrings #-}--{- |-Module : Neovim.API.String-Description : String based API-Copyright : (c) Sebastian Witte-License : Apache-2.0--Maintainer : woozletoff@gmail.com-Stability : experimental--Note that this module is completely generated. If you're reading this on-hackage, the actual functions of this module may be different from what is-available to you. All the functions in this module depend on the neovim version-that was used when this package was compiled.--}-module Neovim.API.String where--import Neovim.API.TH--$(generateAPI stringListTypeMap)
− library/Neovim/API/TH.hs
@@ -1,580 +0,0 @@-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE TemplateHaskell #-}--{- |-Module : Neovim.API.TH-Description : Template Haskell API generation module-Copyright : (c) Sebastian Witte-License : Apache-2.0--Maintainer : woozletoff@gmail.com-Stability : experimental--}-module Neovim.API.TH (- generateAPI,- function,- function',- command,- command',- autocmd,- stringListTypeMap,- textVectorTypeMap,- bytestringVectorTypeMap,- createFunction,- module UnliftIO.Exception,- module Neovim.Classes,- module Data.Data,- module Data.MessagePack,-) where--import Neovim.API.Parser-import Neovim.Classes-import Neovim.Context-import Neovim.Plugin.Classes (- CommandArguments (..),- CommandOption (..),- FunctionName (..),- FunctionalityDescription (..),- mkCommandOptions,- )-import Neovim.Plugin.Internal (ExportedFunctionality (..))-import Neovim.RPC.FunctionCall--import Language.Haskell.TH hiding (conP, dataD, instanceD)-import TemplateHaskell.Compat.V0208--import Control.Applicative-import Control.Arrow (first)-import Control.Concurrent.STM (STM)-import Control.Exception-import Control.Monad-import Data.ByteString (ByteString)-import Data.Char (isUpper, toUpper)-import Data.Data (Data, Typeable)-import Data.Map (Map)-import qualified Data.Map as Map-import Data.Maybe-import Data.MessagePack-import Data.Monoid-import qualified Data.Set as Set-import Data.Text (Text)-import Data.Vector (Vector)-import Prettyprinter (viaShow)-import UnliftIO.Exception--import Prelude-import qualified Data.Text as T--{- | Generate the API types and functions provided by @nvim --api-info@.-- The provided map allows the use of different Haskell types for the types- defined in the API. The types must be an instance of 'NvimObject' and they- must form an isomorphism with the sent messages types. Currently, it- provides a Convenient way to replace the /String/ type with 'Text',- 'ByteString' or 'String'.--}-generateAPI :: TypeMap -> Q [Dec]-generateAPI typeMap = do- api <- either (fail . show) return =<< runIO parseAPI- let exceptionName = mkName "NeovimExceptionGen"- exceptions = (\(n, i) -> (mkName ("Neovim" <> n), i)) `map` errorTypes api- customTypesN = first mkName `map` customTypes api- join- <$> sequence- [ join . pure <$> createDataTypeWithByteStringComponent exceptionName (map fst exceptions)- , exceptionInstance exceptionName- , customTypeInstance exceptionName exceptions- , fmap join (mapM ((\n -> createDataTypeWithByteStringComponent n [n]) . fst) customTypesN)- , join <$> mapM (\(n, i) -> customTypeInstance n [(n, i)]) customTypesN- , fmap join . mapM (createFunction typeMap) $ functions api- ]---- | Maps type identifiers from the neovim API to Haskell types.-data TypeMap = TypeMap- { typesOfAPI :: Map String (Q Type)- , list :: Q Type- }--stringListTypeMap :: TypeMap-stringListTypeMap =- TypeMap- { typesOfAPI =- Map.fromList- [ ("Boolean", [t|Bool|])- , ("Integer", [t|Int64|])- , ("LuaRef", [t|Int64|])- , ("Float", [t|Double|])- , ("String", [t|String|])- , ("Array", [t|[Object]|])- , ("Dictionary", [t|Map String Object|])- , ("void", [t|()|])- ]- , list = listT- }--textVectorTypeMap :: TypeMap-textVectorTypeMap =- stringListTypeMap- { typesOfAPI = adjustTypeMapForText $ typesOfAPI stringListTypeMap- , list = [t|Vector|]- }- where- adjustTypeMapForText =- Map.insert "String" [t|Text|]- . Map.insert "Array" [t|Vector Object|]- . Map.insert "Dictionary" [t|Map Text Object|]--bytestringVectorTypeMap :: TypeMap-bytestringVectorTypeMap =- textVectorTypeMap- { typesOfAPI = adjustTypeMapForByteString $ typesOfAPI textVectorTypeMap- }- where- adjustTypeMapForByteString =- Map.insert "String" [t|ByteString|]- . Map.insert "Array" [t|Vector Object|]- . Map.insert "Dictionary" [t|Map ByteString Object|]--apiTypeToHaskellType :: TypeMap -> NeovimType -> Q Type-apiTypeToHaskellType typeMap@TypeMap{typesOfAPI, list} at = case at of- Void -> [t|()|]- NestedType t Nothing ->- appT list $ apiTypeToHaskellType typeMap t- NestedType t (Just n) ->- foldl appT (tupleT n) . replicate n $ apiTypeToHaskellType typeMap t- SimpleType t ->- fromMaybe ((conT . mkName) t) $ Map.lookup t typesOfAPI--{- | This function will create a wrapper function with neovim's function name- as its name.-- Synchronous function:- @- buffer_get_number :: Buffer -> Neovim Int64- buffer_get_number buffer = scall "buffer_get_number" [toObject buffer]- @-- Asynchronous function:- @- vim_eval :: String -> Neovim (TMVar Object)- vim_eval str = acall "vim_eval" [toObject str]- @-- Asynchronous function without a return value:- @- vim_feed_keys :: String -> String -> Bool -> Neovim ()- vim_feed_keys keys mode escape_csi =- acallVoid "vim_feed_keys" [ toObject keys- , toObject mode- , toObject escape_csi- ]- @--}-createFunction :: TypeMap -> NeovimFunction -> Q [Dec]-createFunction typeMap nf = do- let withDeferred- | async nf = appT [t|STM|] . appT [t|Either NeovimException|]- | otherwise = id-- callFn- | async nf = [|acall|]- | otherwise = [|scall'|]-- functionName = mkName $ name nf- toObjVar v = [|toObject $(varE v)|]-- retType <-- let env = mkName "env"- in forallT [specifiedPlainTV env] (return [])- . appT [t|Neovim $(varT env)|]- . withDeferred- . apiTypeToHaskellType typeMap- $ returnType nf-- -- prefix with arg0_, arg1_ etc. to prevent generated code from crashing due- -- to keywords being used.- -- see https://github.com/neovimhaskell/nvim-hs/issues/65- let prefixWithNumber i n = "arg" ++ show i ++ "_" ++ n- applyPrefixWithNumber =- zipWith- (\i (t, n) -> (t, prefixWithNumber i n))- [0 :: Int ..]- . parameters- vars <-- mapM- ( \(t, n) ->- (,)- <$> apiTypeToHaskellType typeMap t- <*> newName n- )- $ applyPrefixWithNumber nf-- sequence- [ (sigD functionName . return) (foldr ((AppT . AppT ArrowT) . fst) retType vars)- , funD- functionName- [ clause- (map (varP . snd) vars)- ( normalB- ( callFn- `appE` ([|(F . T.pack)|] `appE` (litE . stringL . name) nf)- `appE` listE (map (toObjVar . snd) vars)- )- )- []- ]- ]--{- | @ createDataTypeWithObjectComponent SomeName [Foo,Bar]@- will create this:- @- data SomeName = Foo !Object- | Bar !Object- deriving (Typeable, Eq, Show)- @--}-createDataTypeWithByteStringComponent :: Name -> [Name] -> Q [Dec]-createDataTypeWithByteStringComponent nme cs = do- tObject <- [t|ByteString|]-- let strictNess = (Bang NoSourceUnpackedness SourceStrict, tObject)-- pure- [ dataD- []- nme- []- (map (\n -> NormalC n [strictNess]) cs)- (mkName <$> ["Typeable", "Eq", "Show", "Generic"])- , instanceD [] (AppT (ConT (mkName "NFData")) (ConT nme)) []- ]--{- | If the first parameter is @mkName NeovimException@, this function will- generate @instance Exception NeovimException@.--}-exceptionInstance :: Name -> Q [Dec]-exceptionInstance exceptionName = do- tException <- [t|Exception|]- pure [instanceD [] (tException `AppT` ConT exceptionName) []]--{- | @customTypeInstance Foo [(Bar, 1), (Quz, 2)]@- will create this:- @- instance Serializable Foo where- toObject (Bar bs) = ObjectExt 1 bs- toObject (Quz bs) = ObjectExt 2 bs- fromObject (ObjectExt 1 bs) = return $ Bar bs- fromObject (ObjectExt 2 bs) = return $ Quz bs- fromObject o = Left $ "Object is not convertible to: Foo Received: " <> show o- @--}-customTypeInstance :: Name -> [(Name, Int64)] -> Q [Dec]-customTypeInstance typeName nis = do- let fromObjectClause :: Name -> Int64 -> Q Clause- fromObjectClause n i = do- bs <- newName "bs"- let objectExtMatch =- conP- (mkName "ObjectExt")- [(LitP . integerL . fromIntegral) i, VarP bs]- clause- [pure objectExtMatch]- (normalB [|return $ $(conE n) $(varE bs)|])- []- fromObjectErrorClause :: Q Clause- fromObjectErrorClause = do- o <- newName "o"- let n = nameBase typeName- clause- [varP o]- ( normalB- [|- throwError $- pretty "Object is not convertible to:"- <+> viaShow n- <+> pretty "Received:"- <+> viaShow $(varE o)- |]- )- []-- toObjectClause :: Name -> Int64 -> Q Clause- toObjectClause n i = do- bs <- newName "bs"- clause- [pure (conP n [VarP bs])]- (normalB [|ObjectExt $((litE . integerL . fromIntegral) i) $(varE bs)|])- []-- tNvimObject <- [t|NvimObject|]- fToObject <- funD (mkName "toObject") $ map (uncurry toObjectClause) nis- fFromObject <- funD (mkName "fromObject") $ map (uncurry fromObjectClause) nis <> [fromObjectErrorClause]- pure [instanceD [] (tNvimObject `AppT` ConT typeName) [fToObject, fFromObject]]--{- | Define an exported function by providing a custom name and referencing the- function you want to export.-- Note that the name must start with an upper case letter.-- Example: @ $(function \"MyExportedFunction\" 'myDefinedFunction) 'Sync' @--}-function :: String -> Name -> Q Exp-function [] _ = fail "Empty names are not allowed for exported functions."-function customName@(c : _) functionName- | (not . isUpper) c = error $ "Custom function name must start with a capital letter: " <> show customName- | otherwise = do- (_, fun) <- functionImplementation functionName- [|\funOpts -> EF (Function (F (T.pack $(litE (StringL customName)))) funOpts, $(return fun))|]--uppercaseFirstCharacter :: Name -> String-uppercaseFirstCharacter name = case nameBase name of- "" -> ""- (c : cs) -> toUpper c : cs--{- | Define an exported function. This function works exactly like 'function',- but it generates the exported name automatically by converting the first- letter to upper case.--}-function' :: Name -> Q Exp-function' functionName = function (uppercaseFirstCharacter functionName) functionName--{- | Simply data type used to identify a string-ish type (e.g. 'String', 'Text',- 'ByteString' for a value of type.--}-data ArgType- = StringyType- | ListOfStringyTypes- | Optional ArgType- | CommandArgumentsType- | OtherType- deriving (Eq, Ord, Show, Read)--{- | Given a value of type 'Type', test whether it can be classified according- to the constructors of "ArgType".--}-classifyArgType :: Type -> Q ArgType-classifyArgType t = do- set <- genStringTypesSet- maybeType <- [t|Maybe|]- cmdArgsType <- [t|CommandArguments|]- case t of- AppT ListT (ConT str)- | str `Set.member` set ->- return ListOfStringyTypes- AppT m mt@(ConT _)- | m == maybeType ->- Optional <$> classifyArgType mt- ConT str- | str `Set.member` set ->- return StringyType- cmd- | cmd == cmdArgsType ->- return CommandArgumentsType- _ -> return OtherType- where- genStringTypesSet = do- types <- sequence [[t|String|], [t|ByteString|], [t|Text|]]- return $ Set.fromList [n | ConT n <- types]--{- | Similarly to 'function', this function is used to export a command with a- custom name.-- Note that commands must start with an upper case letter.-- Due to limitations on the side of (neo)vim, commands can only have one of the- following five signatures, where you can replace 'String' with 'ByteString'- or 'Text' if you wish:-- * 'CommandArguments' -> 'Neovim' env ()-- * 'CommandArguments' -> 'Maybe' 'String' -> 'Neovim' env ()-- * 'CommandArguments' -> 'String' -> 'Neovim' env ()-- * 'CommandArguments' -> ['String'] -> 'Neovim' env ()-- * 'CommandArguments' -> 'String' -> ['String'] -> 'Neovim' env ()-- Example: @ $(command \"RememberThePrime\" 'someFunction) ['CmdBang'] @-- Note that the list of command options (i.e. the last argument) removes- duplicate options by means of some internally convenient sorting. You should- simply not define the same option twice.--}-command :: String -> Name -> Q Exp-command [] _ = error "Empty names are not allowed for exported commands."-command customFunctionName@(c : _) functionName- | (not . isUpper) c = error $ "Custom command name must start with a capital letter: " <> show customFunctionName- | otherwise = do- (argTypes, fun) <- functionImplementation functionName- -- See :help :command-nargs for what the result strings mean- case argTypes of- (CommandArgumentsType : _) -> return ()- _ -> error "First argument for a function exported as a command must be CommandArguments!"- let nargs = case tail argTypes of- [] -> [|CmdNargs "0"|]- [StringyType] -> [|CmdNargs "1"|]- [Optional StringyType] -> [|CmdNargs "?"|]- [ListOfStringyTypes] -> [|CmdNargs "*"|]- [StringyType, ListOfStringyTypes] -> [|CmdNargs "+"|]- _ ->- error $- unlines- [ "Trying to generate a command without compatible types."- , "Due to a limitation burdened on us by vimL, we can only"- , "use a limited amount type signatures for commands. See"- , "the documentation for 'command' for a more thorough"- , "explanation."- ]- [|- \copts ->- EF- ( Command- (F (T.pack $(litE (StringL customFunctionName))))- (mkCommandOptions ($(nargs) : copts))- , $(return fun)- )- |]--{- | Define an exported command. This function works exactly like 'command', but- it generates the command name by converting the first letter to upper case.--}-command' :: Name -> Q Exp-command' functionName = command (uppercaseFirstCharacter functionName) functionName--{- | This function generates an export for autocmd. Since this is a static- registration, arguments are not allowed here. You can, of course, define a- fully applied function and pass it as an argument. If you have to add- autocmds dynamically, it can be done with 'addAutocmd'.-- Example:-- @- someFunction :: a -> b -> c -> d -> Neovim r st res- someFunction = ...-- theFunction :: Neovim r st res- theFunction = someFunction 1 2 3 4--}--{- $(autocmd 'theFunction) def- @-- @def@ is of type 'AutocmdOptions'.-- Note that you have to define @theFunction@ in a different module due to- the use of Template Haskell.--}--autocmd :: Name -> Q Exp-autocmd functionName =- let ~(c : cs) = nameBase functionName- in do- (as, fun) <- functionImplementation functionName- case as of- [] ->- [|\t sync acmdOpts -> EF (Autocmd t (F (T.pack $(litE (StringL (toUpper c : cs))))) sync acmdOpts, $(return fun))|]- _ ->- error "Autocmd functions have to be fully applied (i.e. they should not take any arguments)."--{- | Generate a function of type @[Object] -> Neovim' Object@ from the argument- function.-- The function- @- add :: Int -> Int -> Int- add = (+)- @- will be converted to- @- \args -> case args of- [x,y] -> case pure add <*> fromObject x <*> fromObject y of- Left e -> err $ "Wrong type of arguments for add: " ++ e- Right action -> toObject <$> action- _ -> err $ "Wrong number of arguments for add: " ++ show xs- @--}-functionImplementation :: Name -> Q ([ArgType], Exp)-functionImplementation functionName = do- fInfo <- reify functionName- nargs <- mapM classifyArgType $ case fInfo of- VarI _ functionType _ ->- determineNumberOfArguments functionType- x ->- error $ "Value given to function is (likely) not the name of a function.\n" <> show x-- e <- topLevelCase nargs- return (nargs, e)- where- determineNumberOfArguments :: Type -> [Type]- determineNumberOfArguments ft = case ft of- ForallT _ _ t -> determineNumberOfArguments t- AppT (AppT ArrowT t) r -> t : determineNumberOfArguments r- _ -> []- -- \args -> case args of ...- topLevelCase :: [ArgType] -> Q Exp- topLevelCase ts = do- let n = length ts- minLength = length [() | Optional _ <- reverse ts]- args <- newName "args"- lamE- [varP args]- ( caseE- (varE args)- (zipWith matchingCase [n, n - 1 ..] [0 .. minLength] ++ [errorCase])- )-- -- _ -> err "Wrong number of arguments"- errorCase :: Q Match- errorCase =- match- wildP- ( normalB- [|- throw . ErrorMessage . pretty $- "Wrong number of arguments for function: "- ++ $(litE (StringL (nameBase functionName)))- |]- )- []-- -- [x,y] -> case pure add <*> fromObject x <*> fromObject y of ...- matchingCase :: Int -> Int -> Q Match- matchingCase n x = do- vars <- mapM (\_ -> Just <$> newName "x") [1 .. n]- let optVars = replicate x (Nothing :: Maybe Name)- match- ((listP . map varP . catMaybes) vars)- ( normalB- ( caseE- ( foldl- genArgumentCast- [|pure $(varE functionName)|]- (zip (vars ++ optVars) (repeat [|(<*>)|]))- )- [successfulEvaluation, failedEvaluation]- )- )- []-- genArgumentCast :: Q Exp -> (Maybe Name, Q Exp) -> Q Exp- genArgumentCast e = \case- (Just v, op) ->- infixE (Just e) op (Just [|fromObject $(varE v)|])- (Nothing, op) ->- infixE (Just e) op (Just [|pure Nothing|])-- successfulEvaluation :: Q Match- successfulEvaluation =- newName "action" >>= \action ->- match- (pure (conP (mkName "Right") [VarP action]))- (normalB [|toObject <$> $(varE action)|])- []- failedEvaluation :: Q Match- failedEvaluation =- newName "e" >>= \e ->- match- (pure (conP (mkName "Left") [VarP e]))- (normalB [|err ($(varE e) :: Doc AnsiStyle)|])- []
− library/Neovim/API/Text.hs
@@ -1,21 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE NoOverloadedStrings #-}--{- |-Module : Neovim.API.Text-Description : Text based API-Copyright : (c) Sebastian Witte-License : Apache-2.0--Maintainer : woozletoff@gmail.com-Stability : experimental-Portability : GHC--}-module Neovim.API.Text where--import Neovim.API.TH--$(generateAPI textVectorTypeMap)
− library/Neovim/Classes.hs
@@ -1,450 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes #-}--{- |-Module : Neovim.Classes-Description : Type classes used for conversion of msgpack and Haskell types-Copyright : (c) Sebastian Witte-License : Apache-2.0--Maintainer : woozletoff@gmail.com-Stability : experimental--}-module Neovim.Classes (- NvimObject (..),- Dictionary,- (+:),- Generic,- docToObject,- docFromObject,- docToText,- Doc,- AnsiStyle,- Pretty (..),- (<+>),- module Data.Int,- module Data.Word,- module Control.DeepSeq,-) where--import Neovim.Exceptions (NeovimException (..))--import Control.Applicative-import Control.Arrow ((***))-import Control.DeepSeq-import Control.Monad.Except-import Data.ByteString (ByteString)-import Data.Int (- Int16,- Int32,- Int64,- Int8,- )-import qualified Data.Map.Strict as SMap-import Data.MessagePack-import Data.Monoid-import Data.Text as Text (Text)-import Data.Traversable hiding (forM, mapM)-import Data.Vector (Vector)-import qualified Data.Vector as V-import Data.Word (- Word,- Word16,- Word32,- Word64,- Word8,- )-import GHC.Generics (Generic)-import Prettyprinter (- Doc,- Pretty (..),- defaultLayoutOptions,- layoutPretty,- viaShow,- (<+>),- )-import qualified Prettyprinter as P-import Prettyprinter.Render.Terminal (- AnsiStyle,- renderStrict,- )--import qualified Data.ByteString.UTF8 as UTF8 (fromString, toString)-import Data.Text.Encoding (decodeUtf8, encodeUtf8)-import UnliftIO.Exception (throwIO)--import Prelude--infixr 5 +:--{- | Convenient operator to create a list of 'Object' from normal values.- @- values +: of :+ different :+ types :+ can +: be +: combined +: this +: way +: []- @--}-(+:) :: (NvimObject o) => o -> [Object] -> [Object]-o +: os = toObject o : os--{- | Convert a 'Doc'-ument to a messagepack 'Object'. This is more a convenience- method to transport error message from and to neovim. It generally does not- hold that 'docToObject . docFromObject' = 'id'.--}-docToObject :: Doc AnsiStyle -> Object-docToObject = ObjectString . encodeUtf8 . docToText---- | See 'docToObject'.-docFromObject :: Object -> Either (Doc AnsiStyle) (Doc AnsiStyle)-docFromObject o = (P.viaShow :: Text -> Doc AnsiStyle) <$> fromObject o--docToText :: Doc AnsiStyle -> Text-docToText = renderStrict . layoutPretty defaultLayoutOptions--{- | A generic vim dictionary is a simply a map from strings to objects. This- type alias is sometimes useful as a type annotation especially if the- OverloadedStrings extension is enabled.--}-type Dictionary = SMap.Map ByteString Object--{- | Conversion from 'Object' files to Haskell types and back with respect- to neovim's interpretation.-- The 'NFData' constraint has been added to allow forcing results of function- evaluations in order to catch exceptions from pure code. This adds more- stability to the plugin provider and seems to be a cleaner approach.--}-class NFData o => NvimObject o where- toObject :: o -> Object-- fromObjectUnsafe :: Object -> o- fromObjectUnsafe o = case fromObject o of- Left e ->- error . show $- "Not the expected object:"- <+> P.viaShow o- <+> P.lparen <> e <> P.rparen- Right obj -> obj-- fromObject :: Object -> Either (Doc AnsiStyle) o- fromObject = return . fromObjectUnsafe-- fromObject' :: (MonadIO io) => Object -> io o- fromObject' = either (throwIO . ErrorMessage) return . fromObject-- {-# MINIMAL toObject, (fromObject | fromObjectUnsafe) #-}---- Instances for NvimObject {{{1-instance NvimObject () where- toObject _ = ObjectNil-- fromObject ObjectNil = return ()- fromObject o = throwError $ "Expected ObjectNil, but got" <+> P.viaShow o---- We may receive truthy values from neovim, so we should be more forgiving--- here.-instance NvimObject Bool where- toObject = ObjectBool-- fromObject (ObjectBool o) = return o- fromObject (ObjectInt 0) = return False- fromObject (ObjectUInt 0) = return False- fromObject ObjectNil = return False- fromObject (ObjectBinary "0") = return False- fromObject (ObjectBinary "") = return False- fromObject (ObjectString "0") = return False- fromObject (ObjectString "") = return False- fromObject _ = return True--instance NvimObject Double where- toObject = ObjectDouble-- fromObject (ObjectDouble o) = return o- fromObject (ObjectFloat o) = return $ realToFrac o- fromObject (ObjectInt o) = return $ fromIntegral o- fromObject (ObjectUInt o) = return $ fromIntegral o- fromObject o =- throwError $- "Expected ObjectDouble, but got"- <+> viaShow o--instance NvimObject Integer where- toObject = ObjectInt . fromIntegral-- fromObject (ObjectInt o) = return $ toInteger o- fromObject (ObjectUInt o) = return $ toInteger o- fromObject (ObjectDouble o) = return $ round o- fromObject (ObjectFloat o) = return $ round o- fromObject o = throwError $ "Expected ObjectInt, but got" <+> viaShow o--instance NvimObject Int64 where- toObject = ObjectInt-- fromObject (ObjectInt i) = return i- fromObject (ObjectUInt o) = return $ fromIntegral o- fromObject (ObjectDouble o) = return $ round o- fromObject (ObjectFloat o) = return $ round o- fromObject o = throwError $ "Expected any Integer value, but got" <+> viaShow o--instance NvimObject Int32 where- toObject = ObjectInt . fromIntegral-- fromObject (ObjectInt i) = return $ fromIntegral i- fromObject (ObjectUInt i) = return $ fromIntegral i- fromObject (ObjectDouble o) = return $ round o- fromObject (ObjectFloat o) = return $ round o- fromObject o = throwError $ "Expected any Integer value, but got" <+> viaShow o--instance NvimObject Int16 where- toObject = ObjectInt . fromIntegral-- fromObject (ObjectInt i) = return $ fromIntegral i- fromObject (ObjectUInt i) = return $ fromIntegral i- fromObject (ObjectDouble o) = return $ round o- fromObject (ObjectFloat o) = return $ round o- fromObject o = throwError $ "Expected any Integer value, but got" <+> viaShow o--instance NvimObject Int8 where- toObject = ObjectInt . fromIntegral-- fromObject (ObjectInt i) = return $ fromIntegral i- fromObject (ObjectUInt i) = return $ fromIntegral i- fromObject (ObjectDouble o) = return $ round o- fromObject (ObjectFloat o) = return $ round o- fromObject o = throwError $ "Expected any Integer value, but got" <+> viaShow o--instance NvimObject Word where- toObject = ObjectInt . fromIntegral-- fromObject (ObjectInt i) = return $ fromIntegral i- fromObject (ObjectUInt i) = return $ fromIntegral i- fromObject (ObjectDouble o) = return $ round o- fromObject (ObjectFloat o) = return $ round o- fromObject o = throwError $ "Expected any Integer value, but got" <+> viaShow o--instance NvimObject Word64 where- toObject = ObjectInt . fromIntegral-- fromObject (ObjectInt i) = return $ fromIntegral i- fromObject (ObjectUInt i) = return $ fromIntegral i- fromObject (ObjectDouble o) = return $ round o- fromObject (ObjectFloat o) = return $ round o- fromObject o = throwError $ "Expected any Integer value, but got" <+> viaShow o--instance NvimObject Word32 where- toObject = ObjectInt . fromIntegral-- fromObject (ObjectInt i) = return $ fromIntegral i- fromObject (ObjectUInt i) = return $ fromIntegral i- fromObject (ObjectDouble o) = return $ round o- fromObject (ObjectFloat o) = return $ round o- fromObject o = throwError $ "Expected any Integer value, but got" <+> viaShow o--instance NvimObject Word16 where- toObject = ObjectInt . fromIntegral-- fromObject (ObjectInt i) = return $ fromIntegral i- fromObject (ObjectUInt i) = return $ fromIntegral i- fromObject (ObjectDouble o) = return $ round o- fromObject (ObjectFloat o) = return $ round o- fromObject o = throwError $ "Expected any Integer value, but got" <+> viaShow o--instance NvimObject Word8 where- toObject = ObjectInt . fromIntegral-- fromObject (ObjectInt i) = return $ fromIntegral i- fromObject (ObjectUInt i) = return $ fromIntegral i- fromObject (ObjectDouble o) = return $ round o- fromObject (ObjectFloat o) = return $ round o- fromObject o = throwError $ "Expected any Integer value, but got" <+> viaShow o--instance NvimObject Int where- toObject = ObjectInt . fromIntegral-- fromObject (ObjectInt i) = return $ fromIntegral i- fromObject (ObjectUInt i) = return $ fromIntegral i- fromObject (ObjectDouble o) = return $ round o- fromObject (ObjectFloat o) = return $ round o- fromObject o = throwError $ "Expected any Integer value, but got" <+> viaShow o--instance {-# OVERLAPPING #-} NvimObject [Char] where- toObject = ObjectBinary . UTF8.fromString-- fromObject (ObjectBinary o) = return $ UTF8.toString o- fromObject (ObjectString o) = return $ UTF8.toString o- fromObject o = throwError $ "Expected ObjectString, but got" <+> viaShow o--instance {-# OVERLAPPABLE #-} NvimObject o => NvimObject [o] where- toObject = ObjectArray . map toObject-- fromObject (ObjectArray os) = mapM fromObject os- fromObject o = throwError $ "Expected ObjectArray, but got" <+> viaShow o--instance NvimObject o => NvimObject (Maybe o) where- toObject = maybe ObjectNil toObject-- fromObject ObjectNil = return Nothing- fromObject o = either throwError (return . Just) $ fromObject o--instance NvimObject o => NvimObject (Vector o) where- toObject = ObjectArray . V.toList . V.map toObject-- fromObject (ObjectArray os) = V.fromList <$> mapM fromObject os- fromObject o = throwError $ "Expected ObjectArray, but got" <+> viaShow o---- | Right-biased instance for toObject.-instance (NvimObject l, NvimObject r) => NvimObject (Either l r) where- toObject = either toObject toObject-- fromObject o = case fromObject o of- Right r ->- return $ Right r- Left e1 -> case fromObject o of- Right l ->- return $ Left l- Left e2 ->- throwError $ e1 <+> "--" <+> e2--instance- (Ord key, NvimObject key, NvimObject val) =>- NvimObject (SMap.Map key val)- where- toObject =- ObjectMap- . SMap.fromList- . map (toObject *** toObject)- . SMap.toList-- fromObject (ObjectMap om) =- SMap.fromList- <$> ( traverse- ( uncurry (liftA2 (,))- . (fromObject *** fromObject)- )- . SMap.toList- )- om- fromObject o = throwError $ "Expected ObjectMap, but got" <+> viaShow o--instance NvimObject Text where- toObject = ObjectBinary . encodeUtf8-- fromObject (ObjectBinary o) = return $ decodeUtf8 o- fromObject (ObjectString o) = return $ decodeUtf8 o- fromObject o = throwError $ "Expected ObjectBinary, but got" <+> viaShow o--instance NvimObject ByteString where- toObject = ObjectBinary-- fromObject (ObjectBinary o) = return o- fromObject (ObjectString o) = return o- fromObject o = throwError $ "Expected ObjectBinary, but got" <+> viaShow o--instance NvimObject Object where- toObject = id-- fromObject = return- fromObjectUnsafe = id---- By the magic of vim, i will create these.-instance (NvimObject o1, NvimObject o2) => NvimObject (o1, o2) where- toObject (o1, o2) = ObjectArray $ [toObject o1, toObject o2]-- fromObject (ObjectArray [o1, o2]) =- (,)- <$> fromObject o1- <*> fromObject o2- fromObject o = throwError $ "Expected ObjectArray, but got" <+> viaShow o--instance (NvimObject o1, NvimObject o2, NvimObject o3) => NvimObject (o1, o2, o3) where- toObject (o1, o2, o3) = ObjectArray $ [toObject o1, toObject o2, toObject o3]-- fromObject (ObjectArray [o1, o2, o3]) =- (,,)- <$> fromObject o1- <*> fromObject o2- <*> fromObject o3- fromObject o = throwError $ "Expected ObjectArray, but got" <+> viaShow o--instance (NvimObject o1, NvimObject o2, NvimObject o3, NvimObject o4) => NvimObject (o1, o2, o3, o4) where- toObject (o1, o2, o3, o4) = ObjectArray [toObject o1, toObject o2, toObject o3, toObject o4]-- fromObject (ObjectArray [o1, o2, o3, o4]) =- (,,,)- <$> fromObject o1- <*> fromObject o2- <*> fromObject o3- <*> fromObject o4- fromObject o = throwError $ "Expected ObjectArray, but got" <+> viaShow o--instance (NvimObject o1, NvimObject o2, NvimObject o3, NvimObject o4, NvimObject o5) => NvimObject (o1, o2, o3, o4, o5) where- toObject (o1, o2, o3, o4, o5) = ObjectArray [toObject o1, toObject o2, toObject o3, toObject o4, toObject o5]-- fromObject (ObjectArray [o1, o2, o3, o4, o5]) =- (,,,,)- <$> fromObject o1- <*> fromObject o2- <*> fromObject o3- <*> fromObject o4- <*> fromObject o5- fromObject o = throwError $ "Expected ObjectArray, but got" <+> viaShow o--instance (NvimObject o1, NvimObject o2, NvimObject o3, NvimObject o4, NvimObject o5, NvimObject o6) => NvimObject (o1, o2, o3, o4, o5, o6) where- toObject (o1, o2, o3, o4, o5, o6) = ObjectArray [toObject o1, toObject o2, toObject o3, toObject o4, toObject o5, toObject o6]-- fromObject (ObjectArray [o1, o2, o3, o4, o5, o6]) =- (,,,,,)- <$> fromObject o1- <*> fromObject o2- <*> fromObject o3- <*> fromObject o4- <*> fromObject o5- <*> fromObject o6- fromObject o = throwError $ "Expected ObjectArray, but got" <+> viaShow o--instance (NvimObject o1, NvimObject o2, NvimObject o3, NvimObject o4, NvimObject o5, NvimObject o6, NvimObject o7) => NvimObject (o1, o2, o3, o4, o5, o6, o7) where- toObject (o1, o2, o3, o4, o5, o6, o7) = ObjectArray [toObject o1, toObject o2, toObject o3, toObject o4, toObject o5, toObject o6, toObject o7]-- fromObject (ObjectArray [o1, o2, o3, o4, o5, o6, o7]) =- (,,,,,,)- <$> fromObject o1- <*> fromObject o2- <*> fromObject o3- <*> fromObject o4- <*> fromObject o5- <*> fromObject o6- <*> fromObject o7- fromObject o = throwError $ "Expected ObjectArray, but got" <+> viaShow o--instance (NvimObject o1, NvimObject o2, NvimObject o3, NvimObject o4, NvimObject o5, NvimObject o6, NvimObject o7, NvimObject o8) => NvimObject (o1, o2, o3, o4, o5, o6, o7, o8) where- toObject (o1, o2, o3, o4, o5, o6, o7, o8) = ObjectArray $ [toObject o1, toObject o2, toObject o3, toObject o4, toObject o5, toObject o6, toObject o7, toObject o8]-- fromObject (ObjectArray [o1, o2, o3, o4, o5, o6, o7, o8]) =- (,,,,,,,)- <$> fromObject o1- <*> fromObject o2- <*> fromObject o3- <*> fromObject o4- <*> fromObject o5- <*> fromObject o6- <*> fromObject o7- <*> fromObject o8- fromObject o = throwError $ "Expected ObjectArray, but got" <+> viaShow o--instance (NvimObject o1, NvimObject o2, NvimObject o3, NvimObject o4, NvimObject o5, NvimObject o6, NvimObject o7, NvimObject o8, NvimObject o9) => NvimObject (o1, o2, o3, o4, o5, o6, o7, o8, o9) where- toObject (o1, o2, o3, o4, o5, o6, o7, o8, o9) = ObjectArray $ [toObject o1, toObject o2, toObject o3, toObject o4, toObject o5, toObject o6, toObject o7, toObject o8, toObject o9]-- fromObject (ObjectArray [o1, o2, o3, o4, o5, o6, o7, o8, o9]) =- (,,,,,,,,)- <$> fromObject o1- <*> fromObject o2- <*> fromObject o3- <*> fromObject o4- <*> fromObject o5- <*> fromObject o6- <*> fromObject o7- <*> fromObject o8- <*> fromObject o9- fromObject o = throwError $ "Expected ObjectArray, but got" <+> viaShow o---- 1}}}
− library/Neovim/Compat/Megaparsec.hs
@@ -1,30 +0,0 @@-{-# LANGUAGE CPP #-}-module Neovim.Compat.Megaparsec- ( Parser- , module X-#if MIN_VERSION_megaparsec(7,0,0)- , anyChar-#endif- ) where---import Text.Megaparsec as X--#if MIN_VERSION_megaparsec(6,0,0)--import Data.Void-import Text.Megaparsec.Char as X--type Parser = Parsec Void String--#else--import Text.Megaparsec.String as X--#endif--#if MIN_VERSION_megaparsec(7,0,0)-anyChar :: Parser Char-anyChar = anySingle-#endif-
− library/Neovim/Config.hs
@@ -1,31 +0,0 @@-{- |-Module : Neovim.Config-Description : The user editable and compilable configuration-Copyright : (c) Sebastian Witte-License : Apache-2.0--Maintainer : woozletoff@gmail.com-Stability : experimental--}-module Neovim.Config (- NeovimConfig (..),- module System.Log,-) where--import Neovim.Context (Neovim)-import Neovim.Plugin.Internal (NeovimPlugin)--import System.Log (Priority (..))--{- | This data type contains information about the configuration of neovim. See- the fields' documentation for what you possibly want to change. Also, the- tutorial in the "Neovim" module should get you started.--}-data NeovimConfig = Config- { -- | The list of plugins. The IO type inside the list allows the plugin- -- author to run some arbitrary startup code before creating a value of- -- type 'NeovimPlugin'.- plugins :: [Neovim () NeovimPlugin]- , -- | Set the general logging options.- logOptions :: Maybe (FilePath, Priority)- }
− library/Neovim/Context.hs
@@ -1,85 +0,0 @@-{- |-Module : Neovim.Context-Description : The Neovim context-Copyright : (c) Sebastian Witte-License : Apache-2.0--Maintainer : woozletoff@gmail.com-Stability : experimental--}-module Neovim.Context (- newUniqueFunctionName,- Neovim,- NeovimException (..),- exceptionToDoc,- FunctionMap,- FunctionMapEntry,- mkFunctionMap,- runNeovim,- err,- errOnInvalidResult,- restart,- quit,- subscribe,- unsubscribe,- ask,- asks,- get,- gets,- put,- modify,- Doc,- AnsiStyle,- docToText,- throwError,- module Control.Monad.IO.Class,-) where--import Neovim.Classes-import Neovim.Context.Internal (- FunctionMap,- FunctionMapEntry,- Neovim,- mkFunctionMap,- newUniqueFunctionName,- runNeovim,- subscribe,- unsubscribe,- )-import Neovim.Exceptions (NeovimException (..), exceptionToDoc)--import qualified Neovim.Context.Internal as Internal--import Control.Concurrent (putMVar)-import Control.Exception-import Control.Monad.Except-import Control.Monad.IO.Class-import Control.Monad.Reader-import Control.Monad.State-import Data.MessagePack (Object)---- | @'throw'@ specialized to a 'Pretty' value.-err :: Doc AnsiStyle -> Neovim env a-err = throw . ErrorMessage--errOnInvalidResult ::- (NvimObject o) =>- Neovim env (Either NeovimException Object) ->- Neovim env o-errOnInvalidResult a =- a >>= \case- Left o ->- (err . exceptionToDoc) o- Right o -> case fromObject o of- Left e ->- err e- Right x ->- return x---- | Initiate a restart of the plugin provider.-restart :: Neovim env ()-restart = liftIO . flip putMVar Internal.Restart =<< Internal.asks' Internal.transitionTo---- | Initiate the termination of the plugin provider.-quit :: Neovim env ()-quit = liftIO . flip putMVar Internal.Quit =<< Internal.asks' Internal.transitionTo
− library/Neovim/Context/Internal.hs
@@ -1,316 +0,0 @@-{-# LANGUAGE DerivingVia #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-}--{- |-Module : Neovim.Context.Internal-Description : Abstract description of the plugin provider's internal context-Copyright : (c) Sebastian Witte-License : Apache-2.0--Maintainer : woozletoff@gmail.com-Stability : experimental-Portability : GHC--To shorten function and data type names, import this qualfied as @Internal@.--}-module Neovim.Context.Internal where--import Neovim.Classes (- AnsiStyle,- Doc,- NFData,- Pretty (pretty),- deepseq,- )-import Neovim.Exceptions (- NeovimException (..),- exceptionToDoc,- )-import Neovim.Plugin.Classes-import Neovim.Plugin.IPC--import Data.Map (Map)-import qualified Data.Map as Map-import Data.MessagePack (Object)-import Data.Monoid (Ap (Ap))-import Data.Text (Text, pack)-import System.Log.Logger (errorM)-import UnliftIO--import Prettyprinter (viaShow)--import Control.Exception (- ArithException,- ArrayException,- ErrorCall,- PatternMatchFail,- )-import qualified Control.Monad.Fail as Fail-import Control.Monad.Reader-import Control.Monad.Trans.Resource (MonadResource (..), MonadThrow)-import UnliftIO.Resource-import Prelude--{- | This is the environment in which all plugins are initially started.-- Functions have to run in this transformer stack to communicate with neovim.- If parts of your own functions dont need to communicate with neovim, it is- good practice to factor them out. This allows you to write tests and spot- errors easier. Essentially, you should treat this similar to 'IO' in general- haskell programs.--}-newtype Neovim env a = Neovim- {unNeovim :: ResourceT (ReaderT (Config env) IO) a}- deriving newtype (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadUnliftIO)- deriving (Semigroup, Monoid) via (Ap (Neovim env) a)---- | User facing instance declaration for the reader state.-instance MonadReader env (Neovim env) where- ask = Neovim $ asks customConfig- local f (Neovim a) = do- r <- Neovim ask- liftIO $- runReaderT- (runResourceT a)- (r{customConfig = f (customConfig r)})--instance MonadResource (Neovim env) where- liftResourceT m = Neovim $ UnliftIO.Resource.liftResourceT m--instance Fail.MonadFail (Neovim env) where- fail = throwIO . ErrorMessage . pretty---- | Same as 'ask' for the 'InternalConfig'.-ask' :: Neovim env (Config env)-ask' = Neovim ask---- | Same as 'asks' for the 'InternalConfig'.-asks' :: (Config env -> a) -> Neovim env a-asks' = Neovim . asks--exceptionHandlers :: [Handler IO (Either (Doc ann) a)]-exceptionHandlers =- [ Handler $ \(_ :: ArithException) -> ret "ArithException (e.g. division by 0)"- , Handler $ \(_ :: ArrayException) -> ret "ArrayException"- , Handler $ \(_ :: ErrorCall) -> ret "ErrorCall (e.g. call of undefined or error"- , Handler $ \(_ :: PatternMatchFail) -> ret "Pattern match failure"- , Handler $ \(_ :: SomeException) -> ret "Unhandled exception"- ]- where- ret = return . Left---- | Initialize a 'Neovim' context by supplying an 'InternalEnvironment'.-runNeovim ::- NFData a =>- Config env ->- Neovim env a ->- IO (Either (Doc AnsiStyle) a)-runNeovim = runNeovimInternal (\a -> a `deepseq` return a)--runNeovimInternal ::- (a -> IO a) ->- Config env ->- Neovim env a ->- IO (Either (Doc AnsiStyle) a)-runNeovimInternal f r (Neovim a) =- (try . runReaderT (runResourceT a)) r >>= \case- Left e -> case fromException e of- Just e' ->- return . Left . exceptionToDoc $ (e' :: NeovimException)- Nothing -> do- liftIO . errorM "Context" $ "Converting Exception to Error message: " ++ show e- (return . Left . viaShow) e- Right res ->- (Right <$> f res) `catches` exceptionHandlers--{- | Create a new unique function name. To prevent possible name clashes, digits- are stripped from the given suffix.--}-newUniqueFunctionName :: Neovim env FunctionName-newUniqueFunctionName = do- tu <- asks' uniqueCounter- -- reverseing the integer string should distribute the first character more- -- evently and hence cause faster termination for comparisons.- fmap (F . pack . reverse . show) . liftIO . atomically $ do- u <- readTVar tu- modifyTVar' tu succ- return u--{- | This data type is used to dispatch a remote function call to the appopriate- recipient.--}-newtype FunctionType- = -- | 'Stateful' functions are handled within a special thread, the 'TQueue'- -- is the communication endpoint for the arguments we have to pass.- Stateful (TQueue SomeMessage)--instance Pretty FunctionType where- pretty = \case- Stateful _ -> "\\os -> Neovim env o"---- | Type of the values stored in the function map.-type FunctionMapEntry = (FunctionalityDescription, FunctionType)--{- | A function map is a map containing the names of functions as keys and some- context dependent value which contains all the necessary information to- execute that function in the intended way.-- This type is only used internally and handles two distinct cases. One case- is a direct function call, wich is simply a function that accepts a list of- 'Object' values and returns a result in the 'Neovim' context. The second- case is calling a function that has a persistent state. This is mediated to- a thread that reads from a 'TQueue'. (NB: persistent currently means, that- state is stored for as long as the plugin provider is running and not- restarted.)--}-type FunctionMap = Map NvimMethod FunctionMapEntry---- | Create a new function map from the given list of 'FunctionMapEntry' values.-mkFunctionMap :: [FunctionMapEntry] -> FunctionMap-mkFunctionMap = Map.fromList . map (\e -> (nvimMethod (fst e), e))--data Subscriptions = Subscriptions- { nextSubscriptionId :: SubscriptionId- , byEventId :: Map NeovimEventId [Subscription]- }--{- | Subscribe to an event. When the event is received, the given callback function- is run. It is usually necessary to call the appropriate API function in order for- /neovim/ to send the notifications to /nvim-hs/. The returned subscription can be- used to 'unsubscribe'.--}-subscribe :: Text -> ([Object] -> Neovim env ()) -> Neovim env Subscription-subscribe event action = do- let eventId = NeovimEventId event- cfg <- ask'- let subscriptions' = subscriptions cfg- atomically $ do- s <- takeTMVar subscriptions'- let subscriptionId = nextSubscriptionId s- let newSubscription =- Subscription- { subId = subscriptionId- , subEventId = eventId- , subAction = void . runNeovim cfg . action- }- putTMVar- subscriptions'- s- { nextSubscriptionId = succ subscriptionId- , byEventId = Map.insertWith (<>) eventId [newSubscription] (byEventId s)- }- pure newSubscription---- | Remove the subscription that has been returned by 'subscribe'.-unsubscribe :: Subscription -> Neovim env ()-unsubscribe subscription = do- subscriptions' <- asks' subscriptions- void . atomically $ do- s <- takeTMVar subscriptions'- let eventId = subEventId subscription- deleteSubscription = Just . filter ((/= subId subscription) . subId)- putTMVar- subscriptions'- s- { byEventId = Map.update deleteSubscription eventId (byEventId s)- }--{- | A wrapper for a reader value that contains extra fields required to- communicate with the messagepack-rpc components and provide necessary data to- provide other globally available operations.-- Note that you most probably do not want to change the fields prefixed with an- underscore.--}-data Config env = Config- -- Global settings; initialized once- { -- | A queue of messages that the event handler will propagate to- -- appropriate threads and handlers.- eventQueue :: TQueue SomeMessage- , -- | The main thread will wait for this 'MVar' to be filled with a value- -- and then perform an action appropriate for the value of type- -- 'StateTransition'.- transitionTo :: MVar StateTransition- , -- | Since nvim-hs must have its "Neovim.RPC.SocketReader" and- -- "Neovim.RPC.EventHandler" running to determine the actual channel id- -- (i.e. the 'Int' value here) this field can only be set properly later.- -- Hence, the value of this field is put in an 'TMVar'.- -- Name that is used to identify this provider. Assigning such a name is- -- done in the neovim config (e.g. ~\/.nvim\/nvimrc).- providerName :: TMVar (Either String Int)- , -- | This 'TVar' is used to generate uniqe function names on the side of- -- /nvim-hs/. This is useful if you don't want to overwrite existing- -- functions or if you create autocmd functions.- uniqueCounter :: TVar Integer- , -- | This map is used to dispatch received messagepack function calls to- -- it's appropriate targets.- globalFunctionMap :: TMVar FunctionMap- , -- Local settings; intialized for each stateful component-- -- | In a registered functionality this field contains a function (and- -- possibly some context dependent values) to register new functionality.- pluginSettings :: Maybe (PluginSettings env)- , -- | Plugins can dynamically subscribe to events that neovim sends.- subscriptions :: TMVar Subscriptions- , -- | Plugin author supplyable custom configuration. Queried on the- -- user-facing side with 'ask' or 'asks'.- customConfig :: env- }--{- | Convenient helper to create a new config for the given state and read-only- config.-- Sets the 'pluginSettings' field to 'Nothing'.--}-retypeConfig :: env -> Config anotherEnv -> Config env-retypeConfig r cfg = cfg{pluginSettings = Nothing, customConfig = r}--{- | This GADT is used to share information between stateless and stateful- plugin threads since they work fundamentally in the same way. They both- contain a function to register some functionality in the plugin provider- as well as some values which are specific to the one or the other context.--}-data PluginSettings env where- StatefulSettings ::- ( FunctionalityDescription ->- ([Object] -> Neovim env Object) ->- TQueue SomeMessage ->- TVar (Map NvimMethod ([Object] -> Neovim env Object)) ->- Neovim env (Maybe FunctionMapEntry)- ) ->- TQueue SomeMessage ->- TVar (Map NvimMethod ([Object] -> Neovim env Object)) ->- PluginSettings env--{- | Create a new 'InternalConfig' object by providing the minimal amount of- necessary information.-- This function should only be called once per /nvim-hs/ session since the- arguments are shared across processes.--}-newConfig :: IO (Maybe String) -> IO env -> IO (Config env)-newConfig ioProviderName r =- Config- <$> newTQueueIO- <*> newEmptyMVar- <*> (maybe newEmptyTMVarIO (newTMVarIO . Left) =<< ioProviderName)- <*> newTVarIO 100- <*> newEmptyTMVarIO- <*> pure Nothing- <*> newTMVarIO (Subscriptions (SubscriptionId 1) mempty)- <*> r---- | The state that the plugin provider wants to transition to.-data StateTransition- = -- | Quit the plugin provider.- Quit- | -- | Restart the plugin provider.- Restart- | -- | The plugin provider failed to start or some other error occured.- Failure (Doc AnsiStyle)- | -- | The plugin provider started successfully.- InitSuccess- deriving (Show)
− library/Neovim/Debug.hs
@@ -1,227 +0,0 @@-{-# LANGUAGE NamedFieldPuns #-}--{- |-Module : Neovim.Debug-Description : Utilities to debug Neovim and nvim-hs functionality-Copyright : (c) Sebastian Witte-License : Apache-2.0--Maintainer : woozletoff@gmail.com-Stability : experimental-Portability : GHC--}-module Neovim.Debug (- debug,- debug',- NvimHSDebugInstance (..),- develMain,- quitDevelMain,- restartDevelMain,- printGlobalFunctionMap,- runNeovim,- runNeovim',- module Neovim,-) where--import Neovim-import Neovim.Classes-import Neovim.Context (runNeovim)-import qualified Neovim.Context.Internal as Internal-import Neovim.Log (disableLogger)-import Neovim.Main (- CommandLineOptions (..),- runPluginProvider,- )-import Neovim.RPC.Common (RPCConfig)--import Control.Monad-import qualified Data.Map as Map-import Foreign.Store--import UnliftIO.Async (- Async,- async,- cancel,- )-import UnliftIO.Concurrent (putMVar, takeMVar)-import UnliftIO.STM--import Prettyprinter (- nest,- softline,- vcat,- vsep,- )--import Prelude--{- | Run a 'Neovim' function.-- This function connects to the socket pointed to by the environment variable- @$NVIM@ and executes the command. It does not register itself- as a real plugin provider, you can simply call neovim-functions from the- module "Neovim.API.String" this way.-- Tip: If you run a terminal inside a neovim instance, then this variable is- automatically set.--}-debug :: env -> Internal.Neovim env a -> IO (Either (Doc AnsiStyle) a)-debug env a = disableLogger $ do- runPluginProvider def{envVar = True} Nothing transitionHandler- where- transitionHandler tids cfg =- takeMVar (Internal.transitionTo cfg) >>= \case- Internal.Failure e ->- return $ Left e- Internal.InitSuccess -> do- res <-- Internal.runNeovimInternal- return- (cfg{Internal.customConfig = env, Internal.pluginSettings = Nothing})- a-- mapM_ cancel tids- return res- _ ->- return . Left $ "Unexpected transition state."--{- | Run a 'Neovim'' function.-- @- debug' = debug ()- @-- See documentation for 'debug'.--}-debug' :: Internal.Neovim () a -> IO (Either (Doc AnsiStyle) a)-debug' = debug ()--{- | Simple datatype storing neccessary information to start, stop and reload a- set of plugins. This is passed to most of the functions in this module for- storing state even when the ghci-session has been reloaded.--}-data NvimHSDebugInstance = NvimHSDebugInstance- { threads :: [Async ()]- , neovimConfig :: NeovimConfig- , internalConfig :: Internal.Config RPCConfig- }--{- | This function is intended to be run _once_ in a ghci session that to- give a REPL based workflow when developing a plugin.-- Note that the dyre-based reload mechanisms, i.e. the- "Neovim.Plugin.ConfigHelper" plugin, is not started this way.-- To use this in ghci, you simply bind the results to some variables. After- each reload of ghci, you have to rebind those variables.-- Example:-- @- λ di <- 'develMain' 'Nothing'-- λ 'runNeovim'' di \$ vim_call_function \"getqflist\" []- 'Right' ('Right' ('ObjectArray' []))-- λ :r-- λ di <- 'develMain' 'Nothing'- @-- You can also create a GHCI alias to get rid of most the busy-work:- @- :def! x \\_ -> return \":reload\\nJust di <- develMain 'defaultConfig'{ 'plugins' = [ myDebugPlugin ] }\"- @--}-develMain ::- NeovimConfig ->- IO (Maybe NvimHSDebugInstance)-develMain neovimConfig =- lookupStore 0 >>= \case- Nothing -> do- x <-- disableLogger $- runPluginProvider- def{envVar = True}- (Just neovimConfig)- transitionHandler- void $ newStore x- return x- Just x ->- readStore x- where- transitionHandler tids cfg =- takeMVar (Internal.transitionTo cfg) >>= \case- Internal.Failure e -> do- putDoc e- return Nothing- Internal.InitSuccess -> do- transitionHandlerThread <- async $ do- void $ transitionHandler tids cfg- return . Just $- NvimHSDebugInstance- { threads = transitionHandlerThread : tids- , neovimConfig = neovimConfig- , internalConfig = cfg- }- Internal.Quit -> do- lookupStore 0 >>= \case- Nothing ->- return ()- Just x ->- deleteStore x-- mapM_ cancel tids- putStrLn "Quit develMain"- return Nothing- _ -> do- putStrLn "Unexpected transition state for develMain."- return Nothing---- | Quit a previously started plugin provider.-quitDevelMain :: NvimHSDebugInstance -> IO ()-quitDevelMain NvimHSDebugInstance{internalConfig} =- putMVar (Internal.transitionTo internalConfig) Internal.Quit---- | Restart the development plugin provider.-restartDevelMain ::- NvimHSDebugInstance ->- IO (Maybe NvimHSDebugInstance)-restartDevelMain di = do- quitDevelMain di- develMain (neovimConfig di)---- | Convenience function to run a stateless 'Neovim' function.-runNeovim' ::- NFData a =>- NvimHSDebugInstance ->- Neovim () a ->- IO (Either (Doc AnsiStyle) a)-runNeovim' NvimHSDebugInstance{internalConfig} =- runNeovim (Internal.retypeConfig () internalConfig)---- | Print the global function map to the console.-printGlobalFunctionMap :: NvimHSDebugInstance -> IO ()-printGlobalFunctionMap NvimHSDebugInstance{internalConfig} = do- es <-- fmap Map.toList . atomically $- readTMVar (Internal.globalFunctionMap internalConfig)- let header = "Printing global function map:"- funs =- map- ( \(fname, (d, f)) ->- nest- 3- ( pretty fname- <> softline- <> "->"- <> softline- <> pretty d- <+> ":"- <+> pretty f- )- )- es- putDoc $- nest 2 $- vsep [header, vcat funs, mempty]
− library/Neovim/Exceptions.hs
@@ -1,51 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}--{- |-Module : Neovim.Exceptions-Description : General Exceptions-Copyright : (c) Sebastian Witte-License : Apache-2.0--Maintainer : woozletoff@gmail.com-Stability : experimental-Portability : GHC--}-module Neovim.Exceptions (- NeovimException (..),- exceptionToDoc,- catchNeovimException,-) where--import Control.Exception (Exception)-import Data.MessagePack (Object (..))-import Data.String (IsString (..))-import Data.Typeable (Typeable)-import Prettyprinter (Doc, viaShow, (<+>))-import Prettyprinter.Render.Terminal (AnsiStyle)-import UnliftIO (MonadUnliftIO, catch)---- | Exceptions specific to /nvim-hs/.-data NeovimException- = -- | Simple error message that is passed to neovim. It should currently only- -- contain one line of text.- ErrorMessage (Doc AnsiStyle)- | -- | Error that can be returned by a remote API call. The 'Doc' argument is- -- the name of the remote function that threw this exception.- ErrorResult (Doc AnsiStyle) Object- deriving (Typeable, Show)--instance Exception NeovimException--instance IsString NeovimException where- fromString = ErrorMessage . fromString--exceptionToDoc :: NeovimException -> Doc AnsiStyle-exceptionToDoc = \case- ErrorMessage e ->- "Error message:" <+> e- ErrorResult fn o ->- "Function" <+> fn <+> "has thrown an error:" <+> viaShow o---- | Specialization of 'catch' for 'NeovimException's.-catchNeovimException :: MonadUnliftIO io => io a -> (NeovimException -> io a) -> io a-catchNeovimException action exceptionHandler = action `catch` exceptionHandler
− library/Neovim/Log.hs
@@ -1,58 +0,0 @@-{- |-Module : Neovim.Log-Description : Logging utilities and reexports-Copyright : (c) Sebastian Witte-License : Apache-2.0--Maintainer : woozletoff@gmail.com-Stability : experimental-Portability : GHC--}-module Neovim.Log (- disableLogger,- withLogger,- module System.Log.Logger,-) where--import Control.Exception-import System.Log.Formatter (simpleLogFormatter)-import System.Log.Handler (setFormatter)-import System.Log.Handler.Simple-import System.Log.Logger---- | Disable logging to stderr.-disableLogger :: IO a -> IO a-disableLogger action = do- updateGlobalLogger rootLoggerName removeHandler- action--{- | Initialize the root logger to avoid stderr and set it to log the given- file instead. Simply wrap the main entry point with this function to- initialze the logger.-- @- main = 'withLogger' "\/home\/dude\/nvim.log" 'Debug' \$ do- 'putStrLn' "Hello, World!"- @--}-withLogger :: FilePath -> Priority -> IO a -> IO a-withLogger fp p action =- bracket- setupRootLogger- (\fh -> closeFunc fh (privData fh))- (const action)- where- setupRootLogger = do- -- We shouldn't log to stderr or stdout as it is not unlikely that our- -- messagepack communication is handled via those channels.- disableLogger (return ())- -- Log to the given file instead- fh <- fileHandler fp p- -- Adjust logging format- let fh' = setFormatter fh (simpleLogFormatter "[$loggername : $prio] $msg")- -- Adjust the log level as well- updateGlobalLogger rootLoggerName (setLevel p . addHandler fh')- -- For good measure, log some debug information- logM "Neovim.Debug" DEBUG $- unwords ["Initialized root looger with priority", show p, "and file: ", fp]- return fh'
− library/Neovim/Main.hs
@@ -1,215 +0,0 @@-{- |-Module : Neovim.Main-Description : Wrapper for the actual main function-Copyright : (c) Sebastian Witte-License : Apache-2.0--Maintainer : woozletoff@gmail.com-Stability : experimental--}-module Neovim.Main where--import Neovim.Config-import qualified Neovim.Context.Internal as Internal-import Neovim.Log-import qualified Neovim.Plugin as P-import Neovim.RPC.Common as RPC-import Neovim.RPC.EventHandler-import Neovim.RPC.SocketReader-import Neovim.Util (oneLineErrorMessage)--import Control.Concurrent-import Control.Concurrent.STM (atomically, putTMVar)-import Control.Monad-import Data.Default-import Data.Maybe-import Data.Monoid-import Options.Applicative-import System.IO (stdin, stdout)-import UnliftIO.Async (Async, async)--import Prelude--logger :: String-logger = "Neovim.Main"--data CommandLineOptions = Opt- { providerName :: Maybe String- , hostPort :: Maybe (String, Int)- , unix :: Maybe FilePath- , envVar :: Bool- , logOpts :: Maybe (FilePath, Priority)- }--instance Default CommandLineOptions where- def =- Opt- { providerName = Nothing- , hostPort = Nothing- , unix = Nothing- , envVar = False- , logOpts = Nothing- }--optParser :: Parser CommandLineOptions-optParser =- Opt- <$> optional- ( strArgument- ( metavar "NAME"- <> help- ( unlines- [ "Name that associates the plugin provider with neovim."- , "This option has only an effect if you start nvim-hs"- , "with rpcstart()/jobstart() and use the factory method approach."- , "Since it is extremely hard to figure that out inside"- , "nvim-hs, this option is assumed to used if the input"- , "and output is tied to standard in and standard out."- ]- )- )- )- <*> optional- ( (,)- <$> strOption- ( long "host"- <> short 'a'- <> metavar "HOSTNAME"- <> help "Connect to the specified host. (requires -p)"- )- <*> option- auto- ( long "port"- <> short 'p'- <> metavar "PORT"- <> help "Connect to the specified port. (requires -a)"- )- )- <*> optional- ( strOption- ( long "unix"- <> short 'u'- <> help "Connect to the given unix domain socket."- )- )- <*> switch- ( long "environment"- <> short 'e'- <> help "Read connection information from $NVIM."- )- <*> optional- ( (,)- <$> strOption- ( long "log-file"- <> short 'l'- <> help "File to log to."- )- <*> option- auto- ( long "log-level"- <> short 'v'- <> help ("Log level. Must be one of: " ++ (unwords . map show) logLevels)- )- )- where- -- [minBound..maxBound] would have been nice here.- logLevels :: [Priority]- logLevels = [DEBUG, INFO, NOTICE, WARNING, ERROR, CRITICAL, ALERT, EMERGENCY]--opts :: ParserInfo CommandLineOptions-opts =- info- (helper <*> optParser)- ( fullDesc- <> header "Start a neovim plugin provider for Haskell plugins."- <> progDesc "This is still work in progress. Feel free to contribute."- )--{- | This is essentially the main function for /nvim-hs/, at least if you want- to use "Config.Dyre" for the configuration.--}-neovim :: NeovimConfig -> IO ()-neovim = realMain standalone--{- | A 'TransitionHandler' function receives the 'ThreadId's of all running- threads which have been started by the plugin provider as well as the- 'Internal.Config' with the custom field set to 'RPCConfig'. These information- can be used to properly clean up a session and then do something else.- The transition handler is first called after the plugin provider has started.--}-type TransitionHandler a = [Async ()] -> Internal.Config RPCConfig -> IO a--{- | This main functions can be used to create a custom executable without- using the "Config.Dyre" library while still using the /nvim-hs/ specific- configuration facilities.--}-realMain :: TransitionHandler a -- ^ - -> NeovimConfig -- ^ - ->- IO ()-realMain transitionHandler cfg = do- os <- execParser opts- maybe disableLogger (uncurry withLogger) (logOpts os <|> logOptions cfg) $ do- debugM logger "Starting up neovim haskell plguin provider"- void $ runPluginProvider os (Just cfg) transitionHandler---- | Generic main function. Most arguments are optional or have sane defaults.-runPluginProvider ::- -- | See /nvim-hs/ executables --help function or 'optParser'- CommandLineOptions ->- Maybe NeovimConfig ->- TransitionHandler a ->- IO a-runPluginProvider os mcfg transitionHandler = case (hostPort os, unix os) of- (Just (h, p), _) ->- createHandle (TCP p h) >>= \s -> run s s- (_, Just fp) ->- createHandle (UnixSocket fp) >>= \s -> run s s- _- | envVar os ->- createHandle Environment >>= \s -> run s s- _ ->- run stdout stdin- where- run evHandlerHandle sockreaderHandle = do- -- The plugins to register depend on the given arguments and may need- -- special initialization methods.- let allPlugins = maybe [] plugins mcfg-- conf <- Internal.newConfig (pure (providerName os)) newRPCConfig-- ehTid <-- async $- runEventHandler- evHandlerHandle- conf{Internal.pluginSettings = Nothing}-- srTid <- async $ runSocketReader sockreaderHandle conf-- let startupConf = Internal.retypeConfig () conf- P.startPluginThreads startupConf allPlugins >>= \case- Left e -> do- errorM logger $ "Error initializing plugins: " <> show (oneLineErrorMessage e)- putMVar (Internal.transitionTo conf) $ Internal.Failure e- transitionHandler [ehTid, srTid] conf- Right (funMapEntries, pluginTids) -> do- atomically $- putTMVar- (Internal.globalFunctionMap conf)- (Internal.mkFunctionMap funMapEntries)- putMVar (Internal.transitionTo conf) Internal.InitSuccess- transitionHandler (srTid : ehTid : pluginTids) conf--standalone :: TransitionHandler ()-standalone threads cfg =- takeMVar (Internal.transitionTo cfg) >>= \case- Internal.InitSuccess -> do- debugM logger "Initialization Successful"- standalone threads cfg- Internal.Restart -> do- errorM logger "Cannot restart"- standalone threads cfg- Internal.Failure e ->- errorM logger . show $ oneLineErrorMessage e- Internal.Quit ->- return ()
− library/Neovim/Plugin.hs
@@ -1,336 +0,0 @@-{-# LANGUAGE GADTs #-}--{- |-Module : Neovim.Plugin-Description : Plugin and functionality registration code-Copyright : (c) Sebastian Witte-License : Apache-2.0--Maintainer : woozletoff@gmail.com-Stability : experimental-Portability : GHC--}-module Neovim.Plugin (- startPluginThreads,- wrapPlugin,- NeovimPlugin,- Plugin (..),- Synchronous (..),- CommandOption (..),- addAutocmd,- registerPlugin,- registerFunctionality,- getProviderName,-) where--import Neovim.API.String-import Neovim.Classes-import Neovim.Context-import Neovim.Context.Internal (- FunctionType (..),- runNeovimInternal,- )-import qualified Neovim.Context.Internal as Internal-import Neovim.Plugin.Classes hiding (register)-import Neovim.Plugin.IPC.Classes-import Neovim.Plugin.Internal-import Neovim.RPC.FunctionCall--import Control.Applicative-import Control.Monad (foldM, void)-import Data.Foldable (forM_)-import Data.Map (Map)-import qualified Data.Map as Map-import Data.Either (rights)-import Data.MessagePack-import Data.Text (Text)-import Data.Traversable (forM)-import System.Log.Logger-import UnliftIO.Async (Async, async, race)-import UnliftIO.Concurrent (threadDelay)-import UnliftIO.Exception (SomeException, catch, try)-import UnliftIO.STM--import Prelude--logger :: String-logger = "Neovim.Plugin"--startPluginThreads ::- Internal.Config () ->- [Neovim () NeovimPlugin] ->- IO (Either (Doc AnsiStyle) ([FunctionMapEntry], [Async ()]))-startPluginThreads cfg = runNeovimInternal return cfg . foldM go ([], [])- where- go ::- ([FunctionMapEntry], [Async ()]) ->- Neovim () NeovimPlugin ->- Neovim () ([FunctionMapEntry], [Async ()])- go (es, tids) iop = do- NeovimPlugin p <- iop- (es', tid) <- registerStatefulFunctionality p-- return (es ++ es', tid : tids)--{- | Call the vimL functions to define a function, command or autocmd on the- neovim side. Returns 'True' if registration was successful.-- Note that this does not have any effect on the side of /nvim-hs/.--}-registerWithNeovim :: FunctionalityDescription -> Neovim anyEnv Bool-registerWithNeovim = \case- func@(Function (F functionName) s) -> do- pName <- getProviderName- let (defineFunction, host) =- either- (\n -> ("remote#define#FunctionOnHost", toObject n))- (\c -> ("remote#define#FunctionOnChannel", toObject c))- pName- reportError (e :: NeovimException) = do- liftIO . errorM logger $- "Failed to register function: " ++ show functionName ++ show e- return False- logSuccess = do- liftIO . debugM logger $- "Registered function: " ++ show functionName- return True-- flip catch reportError $ do- void $- vim_call_function defineFunction $- host +: nvimMethodName (nvimMethod func) +: s +: functionName +: (Map.empty :: Dictionary) +: []- logSuccess- cmd@(Command (F functionName) copts) -> do- let sync = case getCommandOptions copts of- -- This works because CommandOptions are sorted and CmdSync is- -- the smallest element in the sorting- (CmdSync s : _) -> s- _ -> Sync-- pName <- getProviderName- let (defineFunction, host) =- either- (\n -> ("remote#define#CommandOnHost", toObject n))- (\c -> ("remote#define#CommandOnChannel", toObject c))- pName- reportError (e :: NeovimException) = do- liftIO . errorM logger $- "Failed to register command: " ++ show functionName ++ show e- return False- logSuccess = do- liftIO . debugM logger $- "Registered command: " ++ show functionName- return True- flip catch reportError $ do- void $- vim_call_function defineFunction $- host +: nvimMethodName (nvimMethod cmd) +: sync +: functionName +: copts +: []- logSuccess- Autocmd acmdType (F functionName) sync opts -> do- pName <- getProviderName- let (defineFunction, host) =- either- (\n -> ("remote#define#AutocmdOnHost", toObject n))- (\c -> ("remote#define#AutocmdOnChannel", toObject c))- pName- reportError (e :: NeovimException) = do- liftIO . errorM logger $- "Failed to register autocmd: " ++ show functionName ++ show e- return False- logSuccess = do- liftIO . debugM logger $- "Registered autocmd: " ++ show functionName- return True- flip catch reportError $ do- void $- vim_call_function defineFunction $- host +: functionName +: sync +: acmdType +: opts +: []- logSuccess--{- | Return or retrive the provider name that the current instance is associated- with on the neovim side.--}-getProviderName :: Neovim env (Either String Int)-getProviderName = do- mp <- Internal.asks' Internal.providerName- (liftIO . atomically . tryReadTMVar) mp >>= \case- Just p ->- return p- Nothing -> do- api <- nvim_get_api_info- case api of- [] -> err "empty nvim_get_api_info"- (i : _) -> do- case fromObject i :: Either (Doc AnsiStyle) Int of- Left _ ->- err $- "Expected an integral value as the first"- <+> "argument of nvim_get_api_info"- Right channelId -> do- liftIO . atomically . putTMVar mp . Right $ fromIntegral channelId- return . Right $ fromIntegral channelId--registerFunctionality ::- FunctionalityDescription ->- ([Object] -> Neovim env Object) ->- Neovim env (Either (Doc AnsiStyle) FunctionMapEntry)-registerFunctionality d f = do- Internal.asks' Internal.pluginSettings >>= \case- Nothing -> do- let msg = "Cannot register functionality in this context."- liftIO $ errorM logger msg- return $ Left $ pretty msg- Just (Internal.StatefulSettings reg q m) ->- reg d f q m >>= \case- Just e -> do- pure $ Right e- Nothing ->- pure $ Left ""--registerInGlobalFunctionMap :: FunctionMapEntry -> Neovim env ()-registerInGlobalFunctionMap e = do- liftIO . debugM logger $ "Adding function to global function map." ++ show (fst e)- funMap <- Internal.asks' Internal.globalFunctionMap- liftIO . atomically $ do- m <- takeTMVar funMap- putTMVar funMap $ Map.insert ((nvimMethod . fst) e) e m- liftIO . debugM logger $ "Added function to global function map." ++ show (fst e)--registerPlugin ::- (FunctionMapEntry -> Neovim env ()) ->- FunctionalityDescription ->- ([Object] -> Neovim env Object) ->- TQueue SomeMessage ->- TVar (Map NvimMethod ([Object] -> Neovim env Object)) ->- Neovim env (Maybe FunctionMapEntry)-registerPlugin reg d f q tm =- registerWithNeovim d >>= \case- True -> do- let n = nvimMethod d- e = (d, Stateful q)- liftIO . atomically . modifyTVar tm $ Map.insert n f- reg e- return (Just e)- False ->- return Nothing--{- | Register an autocmd in the current context. This means that, if you are- currently in a stateful plugin, the function will be called in the current- thread and has access to the configuration and state of this thread. .-- Note that the function you pass must be fully applied.--}-addAutocmd ::- -- | The event to register to (e.g. BufWritePost)- Text ->- Synchronous ->- AutocmdOptions ->- -- | Fully applied function to register- Neovim env () ->- -- | A 'ReleaseKey' if the registration worked- Neovim env (Either (Doc AnsiStyle) FunctionMapEntry)-addAutocmd event s opts@AutocmdOptions{} f = do- n <- newUniqueFunctionName- registerFunctionality (Autocmd event n s opts) (\_ -> toObject <$> f)--{- | Create a listening thread for events and add update the 'FunctionMap' with- the corresponding 'TQueue's (i.e. communication channels).--}-registerStatefulFunctionality ::- Plugin env ->- Neovim anyEnv ([FunctionMapEntry], Async ())-registerStatefulFunctionality (Plugin{environment = env, exports = fs}) = do- messageQueue <- liftIO newTQueueIO- route <- liftIO $ newTVarIO Map.empty- subscribers <- liftIO $ newTVarIO []-- cfg <- Internal.ask'-- let startupConfig =- cfg- { Internal.customConfig = env- , Internal.pluginSettings =- Just $- Internal.StatefulSettings- (registerPlugin (\_ -> return ()))- messageQueue- route- }- res <- liftIO . runNeovimInternal return startupConfig . forM fs $ \f ->- registerFunctionality (getDescription f) (getFunction f)- es <- case res of- Left e -> err e- Right a -> return $ rights a-- let pluginThreadConfig =- cfg- { Internal.customConfig = env- , Internal.pluginSettings =- Just $- Internal.StatefulSettings- (registerPlugin registerInGlobalFunctionMap)- messageQueue- route- }-- tid <- liftIO . async . void . runNeovim pluginThreadConfig $ do- listeningThread messageQueue route subscribers-- return (es, tid) -- NB: dropping release functions/keys here- where- executeFunction ::- ([Object] -> Neovim env Object) ->- [Object] ->- Neovim env (Either String Object)- executeFunction f args =- try (f args) >>= \case- Left e -> return . Left $ show (e :: SomeException)- Right res -> return $ Right res-- killAfterSeconds :: Word -> Neovim anyEnv ()- killAfterSeconds seconds = threadDelay (fromIntegral seconds * 1000 * 1000)-- timeoutAndLog :: Word -> FunctionName -> Neovim anyEnv String- timeoutAndLog seconds functionName = do- killAfterSeconds seconds- return . show $- pretty functionName <+> "has been aborted after"- <+> pretty seconds- <+> "seconds"-- listeningThread ::- TQueue SomeMessage ->- TVar (Map NvimMethod ([Object] -> Neovim env Object)) ->- TVar [Notification -> Neovim env ()] ->- Neovim env ()- listeningThread q route subscribers = do- msg <- readSomeMessage q-- forM_ (fromMessage msg) $ \req@(Request fun@(F methodName) _ args) -> do- let method = NvimMethod methodName- route' <- liftIO $ readTVarIO route- forM_ (Map.lookup method route') $ \f -> do- respond req . either Left id- =<< race- (timeoutAndLog 10 fun)- (executeFunction f args)-- forM_ (fromMessage msg) $ \notification@(Notification (NeovimEventId methodName) args) -> do- let method = NvimMethod methodName- route' <- liftIO $ readTVarIO route- forM_ (Map.lookup method route') $ \f ->- void . async $ do- result <- either Left id <$> race- (timeoutAndLog 600 (F methodName))- (executeFunction f args)- case result of- Left message ->- nvim_err_writeln message- Right _ ->- return ()-- subscribers' <- liftIO $ readTVarIO subscribers- forM_ subscribers' $ \subscriber ->- async $ void $ race (subscriber notification) (killAfterSeconds 10)-- listeningThread q route subscribers
− library/Neovim/Plugin/Classes.hs
@@ -1,451 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DerivingVia #-}-{-# LANGUAGE RecordWildCards #-}--{- |-Module : Neovim.Plugin.Classes-Description : Classes and data types related to plugins-Copyright : (c) Sebastian Witte-License : Apache-2.0--Maintainer : woozletoff@gmail.com-Stability : experimental-Portability : GHC--}-module Neovim.Plugin.Classes (- FunctionalityDescription (..),- FunctionName (..),- NeovimEventId (..),- SubscriptionId (..),- Subscription (..),- NvimMethod (..),- Synchronous (..),- CommandOption (..),- CommandOptions,- RangeSpecification (..),- CommandArguments (..),- getCommandOptions,- mkCommandOptions,- AutocmdOptions (..),- HasFunctionName (..),-) where--import Neovim.Classes--import Control.Monad.Error.Class (MonadError (throwError))-import Data.Char (isDigit)-import Data.Default (Default (..))-import Data.List (groupBy, sort)-import qualified Data.Map as Map-import Data.Maybe (catMaybes, mapMaybe)-import Data.MessagePack (Object (..))-import Data.String (IsString (..))-import Data.Text (Text)-import Prettyprinter (cat, comma, lparen, rparen, viaShow)--import Prelude hiding (sequence)---- | Essentially just a string.-newtype FunctionName = F Text- deriving (Eq, Ord, Show, Read, Generic)- deriving (NFData, Pretty) via Text--newtype NeovimEventId = NeovimEventId Text- deriving (Eq, Ord, Show, Read, Generic)- deriving (Pretty) via Text- deriving (NFData) via Text--instance NvimObject NeovimEventId where- toObject (NeovimEventId e) = toObject e- fromObject o = NeovimEventId <$> fromObject o--newtype SubscriptionId = SubscriptionId Int64- deriving (Eq, Ord, Show, Read)- deriving (Enum) via Int64--data Subscription = Subscription- { subId :: SubscriptionId- , subEventId :: NeovimEventId- , subAction :: [Object] -> IO ()- }--{- | Functionality specific functional description entries.-- All fields which are directly specified in these constructors are not- optional, but can partialy be generated via the Template Haskell functions.- The last field is a data type that contains all relevant options with- sensible defaults, hence 'def' can be used as an argument.--}-data FunctionalityDescription- = -- | Exported function. Callable via @call name(arg1,arg2)@.- --- -- * Name of the function (must start with an uppercase letter)- -- * Option to indicate how neovim should behave when calling this function- Function FunctionName Synchronous- | -- | Exported Command. Callable via @:Name arg1 arg2@.- --- -- * Name of the command (must start with an uppercase letter)- -- * Options to configure neovim's behavior for calling the command- Command FunctionName CommandOptions- | -- | Exported autocommand. Will call the given function if the type and- -- filter match.- --- -- NB: Since we are registering this on the Haskell side of things, the- -- number of accepted arguments should be 0.- --- -- * Type of the autocmd (e.g. \"BufWritePost\")- -- * Name for the function to call- -- * Whether to use rpcrequest or rpcnotify- -- * Options for the autocmd (use 'def' here if you don't want to change anything)- Autocmd Text FunctionName Synchronous AutocmdOptions- deriving (Show, Read, Eq, Ord, Generic)--instance NFData FunctionalityDescription--instance Pretty FunctionalityDescription where- pretty = \case- Function fname s ->- "Function" <+> pretty s <+> pretty fname- Command fname copts ->- "Command" <+> pretty copts <+> pretty fname- Autocmd t fname s aopts ->- "Autocmd"- <+> pretty t- <+> pretty s- <+> pretty aopts- <+> pretty fname--{- | This option detemines how neovim should behave when calling some- functionality on a remote host.--}-data Synchronous- = -- | Call the functionality entirely for its side effects and do not wait- -- for it to finish. Calling a functionality with this flag set is- -- completely asynchronous and nothing is really expected to happen. This- -- is why a call like this is called notification on the neovim side of- -- things.- Async- | -- | Call the function and wait for its result. This is only synchronous on- -- the neovim side. This means that the GUI will (probably) not- -- allow any user input until a reult is received.- Sync- deriving (Show, Read, Eq, Ord, Enum, Generic)--instance NFData Synchronous--instance Pretty Synchronous where- pretty = \case- Async -> "async"- Sync -> "sync"--instance IsString Synchronous where- fromString = \case- "sync" -> Sync- "async" -> Async- _ -> error "Only \"sync\" and \"async\" are valid string representations"--instance NvimObject Synchronous where- toObject = \case- Async -> toObject False- Sync -> toObject True-- fromObject = \case- ObjectBool True -> return Sync- ObjectBool False -> return Async- ObjectInt 0 -> return Async- _ -> return Sync--{- | Options for commands.-- Some command can also be described by using the OverloadedString extensions.- This means that you can write a literal 'String' inside your source file in- place for a 'CommandOption' value. See the documentation for each value on- how these strings should look like (Both versions are compile time checked.)--}-data CommandOption- = -- | Stringliteral "sync" or "async"- CmdSync Synchronous- | -- | Register passed to the command.- --- -- Stringliteral: @\"\\\"\"@- CmdRegister- | -- | Command takes a specific amount of arguments- --- -- Automatically set via template haskell functions. You- -- really shouldn't use this option yourself unless you have- -- to.- CmdNargs String- | -- | Determines how neovim passes the range.- --- -- Stringliterals: \"%\" for 'WholeFile', \",\" for line- -- and \",123\" for 123 lines.- CmdRange RangeSpecification- | -- | Command handles a count. The argument defines the- -- default count.- --- -- Stringliteral: string of numbers (e.g. "132")- CmdCount Word- | -- | Command handles a bang- --- -- Stringliteral: \"!\"- CmdBang- | -- | Verbatim string passed to the @-complete=@ command attribute- CmdComplete String- deriving (Eq, Ord, Show, Read, Generic)--instance NFData CommandOption--instance Pretty CommandOption where- pretty = \case- CmdSync s ->- pretty s- CmdRegister ->- "\""- CmdNargs n ->- pretty n- CmdRange rs ->- pretty rs- CmdCount c ->- pretty c- CmdBang ->- "!"- CmdComplete cs ->- pretty cs--instance IsString CommandOption where- fromString = \case- "%" -> CmdRange WholeFile- "\"" -> CmdRegister- "!" -> CmdBang- "sync" -> CmdSync Sync- "async" -> CmdSync Async- "," -> CmdRange CurrentLine- ',' : ds | not (null ds) && all isDigit ds -> CmdRange (read ds)- ds | not (null ds) && all isDigit ds -> CmdCount (read ds)- _ -> error "Not a valid string for a CommandOptions. Check the docs!"--{- | Newtype wrapper for a list of 'CommandOption'. Any properly constructed- object of this type is sorted and only contains zero or one object for each- possible option.--}-newtype CommandOptions = CommandOptions {getCommandOptions :: [CommandOption]}- deriving (Eq, Ord, Show, Read, Generic)--instance NFData CommandOptions--instance Pretty CommandOptions where- pretty (CommandOptions os) =- cat $ map pretty os--{- | Smart constructor for 'CommandOptions'. This sorts the command options and- removes duplicate entries for semantically the same thing. Note that the- smallest option stays for whatever ordering is defined. It is best to simply- not define the same thing multiple times.--}-mkCommandOptions :: [CommandOption] -> CommandOptions-mkCommandOptions = CommandOptions . map head . groupBy constructor . sort- where- constructor a b = case (a, b) of- _ | a == b -> True- -- Only CmdSync and CmdNargs may fail for the equality check,- -- so we just have to check those.- (CmdSync _, CmdSync _) -> True- (CmdRange _, CmdRange _) -> True- -- Range and conut are mutually recursive.- -- XXX Actually '-range=N' and '-count=N' are, but the code in- -- remote#define#CommandOnChannel treats it exclusive as a whole.- -- (see :h :command-range)- (CmdRange _, CmdCount _) -> True- (CmdNargs _, CmdNargs _) -> True- _ -> False--instance NvimObject CommandOptions where- toObject (CommandOptions opts) =- (toObject :: Dictionary -> Object) . Map.fromList $ mapMaybe addOption opts- where- addOption = \case- CmdRange r -> Just ("range", toObject r)- CmdCount n -> Just ("count", toObject n)- CmdBang -> Just ("bang", ObjectBinary "")- CmdRegister -> Just ("register", ObjectBinary "")- CmdNargs n -> Just ("nargs", toObject n)- CmdComplete cs -> Just ("complete", toObject cs)- _ -> Nothing-- fromObject o =- throwError $- "Did not expect to receive a CommandOptions object:" <+> viaShow o---- | Specification of a range that acommand can operate on.-data RangeSpecification- = -- | The line the cursor is at when the command is invoked.- CurrentLine- | -- | Let the command operate on every line of the file.- WholeFile- | -- | Let the command operate on each line in the given range.- RangeCount Int- deriving (Eq, Ord, Show, Read, Generic)--instance NFData RangeSpecification--instance Pretty RangeSpecification where- pretty = \case- CurrentLine ->- mempty- WholeFile ->- "%"- RangeCount c ->- pretty c--instance NvimObject RangeSpecification where- toObject = \case- CurrentLine -> ObjectBinary ""- WholeFile -> ObjectBinary "%"- RangeCount n -> toObject n-- fromObject o =- throwError $- "Did not expect to receive a RangeSpecification object:" <+> viaShow o--{- | You can use this type as the first argument for a function which is- intended to be exported as a command. It holds information about the special- attributes a command can take.--}-data CommandArguments = CommandArguments- { bang :: Maybe Bool- -- ^ 'Nothing' means that the function was not defined to handle a bang,- -- otherwise it means that the bang was passed (@'Just' 'True'@) or that it- -- was not passed when called (@'Just' 'False'@).- , range :: Maybe (Int, Int)- -- ^ Range passed from neovim. Only set if 'CmdRange' was used in the export- -- declaration of the command.- --- -- Example:- --- -- * @Just (1,12)@- , count :: Maybe Int- -- ^ Count passed by neovim. Only set if 'CmdCount' was used in the export- -- declaration of the command.- , register :: Maybe String- -- ^ Register that the command can\/should\/must use.- }- deriving (Eq, Ord, Show, Read, Generic)--instance NFData CommandArguments--instance Pretty CommandArguments where- pretty CommandArguments{..} =- cat $- catMaybes- [ (\b -> if b then "!" else mempty) <$> bang- , ( \(s, e) ->- lparen <> pretty s <> comma- <+> pretty e <> rparen- )- <$> range- , pretty <$> count- , pretty <$> register- ]--instance Default CommandArguments where- def =- CommandArguments- { bang = Nothing- , range = Nothing- , count = Nothing- , register = Nothing- }---- XXX This instance is used as a bit of a hack, so that I don't have to write--- special code handling in the code generator and "Neovim.RPC.SocketReader".-instance NvimObject CommandArguments where- toObject CommandArguments{..} =- (toObject :: Dictionary -> Object)- . Map.fromList- . catMaybes- $ [ bang >>= \b -> return ("bang", toObject b)- , range >>= \r -> return ("range", toObject r)- , count >>= \c -> return ("count", toObject c)- , register >>= \r -> return ("register", toObject r)- ]-- fromObject (ObjectMap m) = do- let l key = mapM fromObject (Map.lookup (ObjectBinary key) m)- bang <- l "bang"- range <- l "range"- count <- l "count"- register <- l "register"- return CommandArguments{..}- fromObject ObjectNil = return def- fromObject o =- throwError $- "Expected a map for CommandArguments object, but got: "- <+> viaShow o--{- | Options that can be used to register an autocmd. See @:h :autocmd@ or any- referenced neovim help-page from the fields of this data type.--}-data AutocmdOptions = AutocmdOptions- { acmdPattern :: String- -- ^ Pattern to match on. (default: \"*\")- , acmdNested :: Bool- -- ^ Nested autocmd. (default: False)- --- -- See @:h autocmd-nested@- , acmdGroup :: Maybe String- -- ^ Group in which the autocmd should be registered.- }- deriving (Show, Read, Eq, Ord, Generic)--instance NFData AutocmdOptions--instance Pretty AutocmdOptions where- pretty AutocmdOptions{..} =- pretty acmdPattern- <+> if acmdNested- then "nested"- else- "unnested"- <> maybe mempty (\g -> mempty <+> pretty g) acmdGroup--instance Default AutocmdOptions where- def =- AutocmdOptions- { acmdPattern = "*"- , acmdNested = False- , acmdGroup = Nothing- }--instance NvimObject AutocmdOptions where- toObject AutocmdOptions{..} =- (toObject :: Dictionary -> Object) . Map.fromList $- [ ("pattern", toObject acmdPattern)- , ("nested", toObject acmdNested)- ]- ++ catMaybes- [ acmdGroup >>= \g -> return ("group", toObject g)- ]- fromObject o =- throwError $- "Did not expect to receive an AutocmdOptions object: " <+> viaShow o--newtype NvimMethod = NvimMethod {nvimMethodName :: Text}- deriving (Eq, Ord, Show, Read, Generic)- deriving (Pretty, NFData) via Text---- | Conveniennce class to extract a name from some value.-class HasFunctionName a where- name :: a -> FunctionName- nvimMethod :: a -> NvimMethod--instance HasFunctionName FunctionalityDescription where- name = \case- Function n _ -> n- Command n _ -> n- Autocmd _ n _ _ -> n-- nvimMethod = \case- Function (F n) _ -> NvimMethod $ n <> ":function"- Command (F n) _ -> NvimMethod $ n <> ":command"- Autocmd _ (F n) _ _ -> NvimMethod n-
− library/Neovim/Plugin/IPC.hs
@@ -1,18 +0,0 @@-{- |-Module : Neovim.Plugin.IPC-Description : Communication between Haskell processes/threads-Copyright : (c) Sebastian Witte-License : Apache-2.0--Maintainer : woozletoff@gmail.com-Stability : experimental--This module reexports publicly available means to communicate between different-plugins (or more generally threads running in the same plugin provider).--}-module Neovim.Plugin.IPC (- SomeMessage (..),- fromMessage,-) where--import Neovim.Plugin.IPC.Classes
− library/Neovim/Plugin/IPC/Classes.hs
@@ -1,167 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE RecordWildCards #-}--{- |-Module : Neovim.Plugin.IPC.Classes-Description : Classes used for Inter Plugin Communication-Copyright : (c) Sebastian Witte-License : Apache-2.0--Maintainer : woozletoff@gmail.com-Stability : experimental-Portability : GHC--}-module Neovim.Plugin.IPC.Classes (- SomeMessage (..),- Message (..),- FunctionCall (..),- Request (..),- Notification (..),- writeMessage,- readSomeMessage,- UTCTime,- getCurrentTime,- module Data.Int,-) where--import Neovim.Classes (- Generic,- Int64,- NFData (..),- Pretty (pretty),- deepseq,- (<+>),- )-import Neovim.Plugin.Classes (FunctionName, NeovimEventId)--import Data.Data (cast)-import Data.Int (Int64)-import Data.MessagePack (Object)-import Data.Time (UTCTime, formatTime, getCurrentTime)-import Data.Time.Locale.Compat (defaultTimeLocale)-import Prettyprinter (hardline, nest, viaShow)-import UnliftIO (- MonadIO (..),- MonadUnliftIO,- TMVar,- TQueue,- Typeable,- atomically,- evaluate,- readTQueue,- writeTQueue,- )--import Prelude--{- | Taken from xmonad and based on ideas in /An Extensible Dynamically-Typed- Hierarchy of Exceptions/, Simon Marlow, 2006.-- User-extensible messages must be put into a value of this type, so that it- can be sent to other plugins.--}-data SomeMessage = forall msg. Message msg => SomeMessage msg--{- | This class allows type safe casting of 'SomeMessage' to an actual message.- The cast is successful if the type you're expecting matches the type in the- 'SomeMessage' wrapper. This way, you can subscribe to an arbitrary message- type withouth having to pattern match on the constructors. This also allows- plugin authors to create their own message types without having to change the- core code of /nvim-hs/.--}-class (NFData message, Typeable message) => Message message where- -- | Try to convert a given message to a value of the message type we are- -- interested in. Will evaluate to 'Nothing' for any other type.- fromMessage :: SomeMessage -> Maybe message- fromMessage (SomeMessage message) = cast message--writeMessage :: (MonadUnliftIO m, Message message) => TQueue SomeMessage -> message -> m ()-writeMessage q message = liftIO $ do- evaluate (rnf message)- atomically $ writeTQueue q (SomeMessage message)--readSomeMessage :: MonadIO m => TQueue SomeMessage -> m SomeMessage-readSomeMessage q = liftIO $ atomically (readTQueue q)---- | Haskell representation of supported Remote Procedure Call messages.-data FunctionCall- = -- | Method name, parameters, callback, timestamp- FunctionCall FunctionName [Object] (TMVar (Either Object Object)) UTCTime- deriving (Typeable, Generic)--instance NFData FunctionCall where- rnf (FunctionCall f os v t) = f `deepseq` os `deepseq` v `seq` t `deepseq` ()--instance Message FunctionCall--instance Pretty FunctionCall where- pretty (FunctionCall fname args _ t) =- nest 2 $- "Function call for:"- <+> pretty fname- <> hardline- <> "Arguments:"- <+> viaShow args- <> hardline- <> "Timestamp:"- <+> (viaShow . formatTime defaultTimeLocale "%H:%M:%S (%q)") t--{- | A request is a data type containing the method to call, its arguments and- an identifier used to map the result to the function that has been called.--}-data Request = Request- { -- | Name of the function to call.- reqMethod :: FunctionName- , -- | Identifier to map the result to a function call invocation.- reqId :: !Int64- , -- | Arguments for the function.- reqArgs :: [Object]- }- deriving (Eq, Ord, Show, Typeable, Generic)--instance NFData Request--instance Message Request--instance Pretty Request where- pretty Request{..} =- nest 2 $- "Request"- <+> "#"- <> pretty reqId- <> hardline- <> "Method:"- <+> pretty reqMethod- <> hardline- <> "Arguments:"- <+> viaShow reqArgs--{- | A notification is similar to a 'Request'. It essentially does the same- thing, but the function is only called for its side effects. This type of- message is sent by neovim if the caller there does not care about the result- of the computation.--}-data Notification = Notification- { -- | Event name of the notification.- notEvent :: NeovimEventId- , -- | Arguments for the function.- notArgs :: [Object]- }- deriving (Eq, Ord, Show, Typeable, Generic)--instance NFData Notification--instance Message Notification--instance Pretty Notification where- pretty Notification{..} =- nest 2 $- "Notification"- <> hardline- <> "Event:"- <+> pretty notEvent- <> hardline- <> "Arguments:"- <+> viaShow notEvent
− library/Neovim/Plugin/Internal.hs
@@ -1,63 +0,0 @@-{-# LANGUAGE ExistentialQuantification #-}--{- |-Module : Neovim.Plugin.Internal-Description : Split module that can import Neovim.Context without creating import circles-Copyright : (c) Sebastian Witte-License : Apache-2.0--Maintainer : woozletoff@gmail.com-Stability : experimental-Portability : GHC--}-module Neovim.Plugin.Internal (- ExportedFunctionality (..),- getFunction,- getDescription,- NeovimPlugin (..),- Plugin (..),- wrapPlugin,-) where--import Neovim.Context (Neovim)-import Neovim.Plugin.Classes (- FunctionalityDescription,- HasFunctionName (..),- )--import Data.MessagePack (Object)--{- | This data type is used in the plugin registration to properly register the- functions.--}-newtype ExportedFunctionality env- = EF (FunctionalityDescription, [Object] -> Neovim env Object)---- | Extract the description of an 'ExportedFunctionality'.-getDescription :: ExportedFunctionality env -> FunctionalityDescription-getDescription (EF (d, _)) = d---- | Extract the function of an 'ExportedFunctionality'.-getFunction :: ExportedFunctionality env -> [Object] -> Neovim env Object-getFunction (EF (_, f)) = f--instance HasFunctionName (ExportedFunctionality env) where- name = name . getDescription- nvimMethod = nvimMethod . getDescription---- | This data type contains meta information for the plugin manager.-data Plugin env = Plugin- { environment :: env- , exports :: [ExportedFunctionality env]- }--{- | 'Plugin' values are wraped inside this data type via 'wrapPlugin' so that- we can put plugins in an ordinary list.--}-data NeovimPlugin = forall env. NeovimPlugin (Plugin env)--{- | Wrap a 'Plugin' in some nice blankets, so that we can put them in a simple- list.--}-wrapPlugin :: Applicative m => Plugin env -> m NeovimPlugin-wrapPlugin = pure . NeovimPlugin
− library/Neovim/Quickfix.hs
@@ -1,205 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE RecordWildCards #-}--{- |-Module : Neovim.Quickfix-Description : API for interacting with the quickfix list-Copyright : (c) Sebastian Witte-License : Apache-2.0--Maintainer : woozletoff@gmail.com-Stability : experimental-Portability : GHC--}-module Neovim.Quickfix where--import Control.Applicative-import Control.Monad (void)-import Data.ByteString as BS (ByteString, all, elem)-import qualified Data.Map as Map-import Data.Maybe-import Data.MessagePack-import Data.Monoid-import Prettyprinter (viaShow)--import Neovim.API.String-import Neovim.Classes-import Neovim.Context--import Prelude--{- | This is a wrapper around neovim's @setqflist()@. @strType@ can be any- string that you can append to (hence 'Monoid') that is also an instance- of 'NvimObject'. You can e.g. use the plain old 'String'.--}-setqflist ::- (Monoid strType, NvimObject strType) =>- [QuickfixListItem strType] ->- QuickfixAction ->- Neovim env ()-setqflist qs a =- void $ vim_call_function "setqflist" $ qs +: a +: []--data ColumnNumber- = VisualColumn Int- | ByteIndexColumn Int- | NoColumn- deriving (Eq, Ord, Show, Generic)--instance NFData ColumnNumber--data SignLocation strType- = LineNumber Int- | SearchPattern strType- deriving (Eq, Ord, Show, Generic)--instance (NFData strType) => NFData (SignLocation strType)--{- | Quickfix list item. The parameter names should mostly conform to those in- @:h setqflist()@. Some fields are merged to explicitly state mutually- exclusive elements or some other behavior of the fields.-- see 'quickfixListItem' for creating a value of this type without typing too- much.--}-data QuickfixListItem strType = QFItem- { -- | Since the filename is only used if no buffer can be specified, this- -- field is a merge of @bufnr@ and @filename@.- bufOrFile :: Either Int strType- , -- | Line number or search pattern to locate the error.- lnumOrPattern :: Either Int strType- , -- | A tuple of a column number and a boolean indicating which kind of- -- indexing should be used. 'True' means that the visual column should be- -- used. 'False' means to use the byte index.- col :: ColumnNumber- , -- | Error number.- nr :: Maybe Int- , -- | Description of the error.- text :: strType- , -- | Type of error.- errorType :: QuickfixErrorType- }- deriving (Eq, Show, Generic)--instance (NFData strType) => NFData (QuickfixListItem strType)---- | Simple error type enum.-data QuickfixErrorType = Warning | Error- deriving (Eq, Ord, Show, Read, Enum, Bounded, Generic)--instance NFData QuickfixErrorType--instance NvimObject QuickfixErrorType where- toObject = \case- Warning -> ObjectBinary "W"- Error -> ObjectBinary "E"-- fromObject o = case fromObject o :: Either (Doc AnsiStyle) String of- Right "W" -> return Warning- Right "E" -> return Error- _ -> return Error--{- | Create a 'QuickfixListItem' by providing the minimal amount of arguments- needed.--}-quickfixListItem ::- (Monoid strType) =>- -- | buffer of file name- Either Int strType ->- -- | line number or pattern- Either Int strType ->- QuickfixListItem strType-quickfixListItem bufferOrFile lineOrPattern =- QFItem- { bufOrFile = bufferOrFile- , lnumOrPattern = lineOrPattern- , col = NoColumn- , nr = Nothing- , text = mempty- , errorType = Error- }--instance- (Monoid strType, NvimObject strType) =>- NvimObject (QuickfixListItem strType)- where- toObject QFItem{..} =- (toObject :: Map.Map ByteString Object -> Object) . Map.fromList $- [ either- (\b -> ("bufnr", toObject b))- (\f -> ("filename", toObject f))- bufOrFile- , either- (\l -> ("lnum", toObject l))- (\p -> ("pattern", toObject p))- lnumOrPattern- , ("type", toObject errorType)- , ("text", toObject text)- ]- ++ case col of- NoColumn -> []- ByteIndexColumn i -> [("col", toObject i), ("vcol", toObject False)]- VisualColumn i -> [("col", toObject i), ("vcol", toObject True)]-- fromObject objectMap@(ObjectMap _) = do- m <- fromObject objectMap- let l :: NvimObject o => ByteString -> Either (Doc AnsiStyle) o- l key = case Map.lookup key m of- Just o -> fromObject o- Nothing -> throwError $ "Key not found."- bufOrFile <- case (l "bufnr", l "filename") of- (Right b, _) -> return $ Left b- (_, Right f) -> return $ Right f- _ -> throwError $ "No buffer number or file name inside quickfix list item."- lnumOrPattern <- case (l "lnum", l "pattern") of- (Right lnum, _) -> return $ Left lnum- (_, Right pat) -> return $ Right pat- _ -> throwError $ "No line number or search pattern inside quickfix list item."- let l' :: NvimObject o => ByteString -> Either (Doc AnsiStyle) (Maybe o)- l' key = case Map.lookup key m of- Just o -> Just <$> fromObject o- Nothing -> return Nothing- nr <-- l' "nr" >>= \case- Just 0 -> return Nothing- nr' -> return nr'- c <- l' "col"- v <- l' "vcol"- let col = fromMaybe NoColumn $ do- c' <- c- v' <- v- case (c', v') of- (0, _) -> return NoColumn- (_, True) -> return $ VisualColumn c'- (_, False) -> return $ ByteIndexColumn c'- text <- fromMaybe mempty <$> l' "text"- errorType <- fromMaybe Error <$> l' "type"- return QFItem{..}- fromObject o =- throwError $- "Could not deserialize QuickfixListItem,"- <+> "expected a map but received:"- <+> viaShow o--data QuickfixAction- = -- | Add items to the current list (or create a new one if none exists).- Append- | -- | Replace current list (or create a new one if none exists).- Replace- | -- | Create a new list.- New- deriving (Eq, Ord, Enum, Bounded, Show, Generic)--instance NFData QuickfixAction--instance NvimObject QuickfixAction where- toObject = \case- Append -> ObjectBinary "a"- Replace -> ObjectBinary "r"- New -> ObjectBinary ""-- fromObject o = case fromObject o of- Right "a" -> return Append- Right "r" -> return Replace- Right s | BS.all (`BS.elem` " \t\n\r") s -> return New- _ -> Left "Could not convert to QuickfixAction"
− library/Neovim/RPC/Classes.hs
@@ -1,101 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}--{- |-Module : Neovim.RPC.Classes-Description : Data types and classes for the RPC components-Copyright : (c) Sebastian Witte-License : Apache-2.0--Maintainer : woozletoff@gmail.com-Stability : experimental-Portability : GHC--Import this module qualified as @MsgpackRPC@--}-module Neovim.RPC.Classes (- Message (..),-) where--import Neovim.Classes-import Neovim.Plugin.Classes (FunctionName (..), NeovimEventId (..))-import qualified Neovim.Plugin.IPC.Classes as IPC--import Control.Applicative-import Control.Monad.Error.Class-import Data.Data (Typeable)-import Data.MessagePack (Object (..))-import Prettyprinter (hardline, nest, viaShow)--import Prelude--{- | See https://github.com/msgpack-rpc/msgpack-rpc/blob/master/spec.md for- details about the msgpack rpc specification.--}-data Message- = -- | Request in the sense of the msgpack rpc specification- --- -- Parameters- -- * Message identifier that has to be put in the response to this request- -- * Function name- -- * Function arguments- Request IPC.Request- | -- | Response in the sense of the msgpack rpc specifcation- --- -- Parameters- -- * Mesage identifier which matches a request- -- * 'Either' an error 'Object' or a result 'Object'- Response !Int64 (Either Object Object)- | -- | Notification in the sense of the msgpack rpc specification- Notification IPC.Notification- deriving (Eq, Ord, Show, Typeable, Generic)--instance NFData Message--instance IPC.Message Message--instance NvimObject Message where- toObject = \case- Request (IPC.Request (F m) i ps) ->- ObjectArray $ (0 :: Int64) +: i +: m +: ps +: []- Response i (Left e) ->- ObjectArray $ (1 :: Int64) +: i +: e +: () +: []- Response i (Right r) ->- ObjectArray $ (1 :: Int64) +: i +: () +: r +: []- Notification (IPC.Notification (NeovimEventId eventId) ps) ->- ObjectArray $ (2 :: Int64) +: eventId +: ps +: []-- fromObject = \case- ObjectArray [ObjectInt 0, i, m, ps] -> do- r <-- IPC.Request- <$> fmap F (fromObject m)- <*> fromObject i- <*> fromObject ps- return $ Request r- ObjectArray [ObjectInt 1, i, e, r] ->- let eer = case e of- ObjectNil -> Right r- _ -> Left e- in Response <$> fromObject i- <*> pure eer- ObjectArray [ObjectInt 2, m, ps] -> do- n <-- IPC.Notification- <$> fmap NeovimEventId (fromObject m)- <*> fromObject ps- return $ Notification n- o ->- throwError $ "Not a known/valid msgpack-rpc message:" <+> viaShow o--instance Pretty Message where- pretty = \case- Request request ->- pretty request- Response i ret ->- nest 2 $- "Response" <+> "#" <> pretty i- <> hardline- <> either viaShow viaShow ret- Notification notification ->- pretty notification
− library/Neovim/RPC/Common.hs
@@ -1,141 +0,0 @@-{-# LANGUAGE RankNTypes #-}--{- |-Module : Neovim.RPC.Common-Description : Common functons for the RPC module-Copyright : (c) Sebastian Witte-License : Apache-2.0--Maintainer : woozletoff@gmail.com-Stability : experimental--}-module Neovim.RPC.Common where--import Neovim.OS (getSocketUnix)--import Control.Applicative (Alternative ((<|>)))-import Control.Monad (unless)-import Data.Int (Int64)-import Data.Map (Map)-import Data.MessagePack (Object)-import Data.Streaming.Network (getSocketTCP)-import Data.String (IsString (fromString))-import Data.Time (UTCTime)-import Neovim.Compat.Megaparsec as P (- MonadParsec (eof, try),- Parser,- anySingle,- anySingleBut,- many,- parse,- single,- some,- )-import Network.Socket as N (socketToHandle)-import System.Log.Logger (errorM, warningM)--import Data.List (intercalate)-import qualified Data.List as List-import Data.Maybe (catMaybes)-import qualified Text.Megaparsec.Char.Lexer as L-import UnliftIO.Environment (lookupEnv)-import UnliftIO--import Prelude---- | Things shared between the socket reader and the event handler.-data RPCConfig = RPCConfig- { recipients :: TVar (Map Int64 (UTCTime, TMVar (Either Object Object)))- -- ^ A map from message identifiers (as per RPC spec) to a tuple with a- -- timestamp and a 'TMVar' that is used to communicate the result back to- -- the calling thread.- , nextMessageId :: TVar Int64- -- ^ Message identifier for the next message as per RPC spec.- }--{- | Create a new basic configuration containing a communication channel for- remote procedure call events and an empty lookup table for functions to- mediate.--}-newRPCConfig :: (Applicative io, MonadUnliftIO io) => io RPCConfig-newRPCConfig =- RPCConfig- <$> liftIO (newTVarIO mempty)- <*> liftIO (newTVarIO 1)---- | Simple data type defining the kind of socket the socket reader should use.-data SocketType- = -- | Use the handle for receiving msgpack-rpc messages. This is- -- suitable for an embedded neovim which is used in test cases.- Stdout Handle- | -- | Read the connection information from the environment- -- variable @NVIM@.- Environment- | -- | Use a unix socket.- UnixSocket FilePath- | -- | Use an IP socket. First argument is the port and the- -- second is the host name.- TCP Int String--{- | Create a 'Handle' from the given socket description.-- The handle is not automatically closed.--}-createHandle ::- (Functor io, MonadUnliftIO io) =>- SocketType ->- io Handle-createHandle = \case- Stdout h -> do- liftIO $ hSetBuffering h (BlockBuffering Nothing)- return h- UnixSocket f ->- liftIO $ createHandle . Stdout =<< flip socketToHandle ReadWriteMode =<< getSocketUnix f- TCP p h ->- createHandle . Stdout =<< createTCPSocketHandle p h- Environment ->- createHandle . Stdout =<< createSocketHandleFromEnvironment- where- createTCPSocketHandle :: (MonadUnliftIO io) => Int -> String -> io Handle- createTCPSocketHandle p h =- liftIO $- getSocketTCP (fromString h) p- >>= flip socketToHandle ReadWriteMode . fst-- createSocketHandleFromEnvironment = liftIO $ do- -- NVIM_LISTEN_ADDRESS is for backwards compatibility- envValues <- catMaybes <$> mapM lookupEnv ["NVIM", "NVIM_LISTEN_ADDRESS"]- listenAdresses <- mapM parseNvimEnvironmentVariable envValues- case listenAdresses of- (s : _) -> createHandle s- _ -> do- let errMsg =- unlines- [ "Unhandled socket type from environment variable: "- , "\t" <> intercalate ", " envValues- ]- liftIO $ errorM "createHandle" errMsg- error errMsg--parseNvimEnvironmentVariable :: MonadFail m => String -> m SocketType-parseNvimEnvironmentVariable envValue =- either (fail . show) pure $ parse (P.try pTcpAddress <|> pUnixSocket) envValue envValue--pUnixSocket :: P.Parser SocketType-pUnixSocket = UnixSocket <$> P.some anySingle <* P.eof--pTcpAddress :: P.Parser SocketType-pTcpAddress = do- prefixes <- P.some (P.try (P.many (P.anySingleBut ':') <* P.single ':'))- port <- L.lexeme P.eof L.decimal- P.eof- pure $ TCP port (List.intercalate ":" prefixes)--{- | Close the handle and print a warning if the conduit chain has been- interrupted prematurely.--}-cleanUpHandle :: (MonadUnliftIO io) => Handle -> Bool -> io ()-cleanUpHandle h completed = liftIO $ do- hClose h- unless completed $- warningM "cleanUpHandle" "Cleanup called on uncompleted handle."
− library/Neovim/RPC/EventHandler.hs
@@ -1,104 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--{- |-Module : Neovim.RPC.EventHandler-Description : Event handling loop-Copyright : (c) Sebastian Witte-License : Apache-2.0--Maintainer : woozletoff@gmail.com-Stability : experimental--}-module Neovim.RPC.EventHandler (- runEventHandler,-) where--import Neovim.Classes-import Neovim.Context-import qualified Neovim.Context.Internal as Internal-import Neovim.Plugin.IPC.Classes-import qualified Neovim.RPC.Classes as MsgpackRPC-import Neovim.RPC.Common-import Neovim.RPC.FunctionCall--import Conduit as C-import Control.Applicative-import Control.Concurrent.STM hiding (writeTQueue)-import Control.Monad.Reader-import Data.ByteString (ByteString)-import qualified Data.Map as Map-import Data.Serialize (encode)-import System.IO (Handle)-import System.Log.Logger--import Prelude--{- | This function will establish a connection to the given socket and write- msgpack-rpc requests to it.--}-runEventHandler ::- Handle ->- Internal.Config RPCConfig ->- IO ()-runEventHandler writeableHandle env =- runEventHandlerContext env . runConduit $ do- eventHandlerSource- .| eventHandler- .| sinkHandleFlush writeableHandle---- | Convenient monad transformer stack for the event handler-newtype EventHandler a- = EventHandler (ResourceT (ReaderT (Internal.Config RPCConfig) IO) a)- deriving- ( Functor- , Applicative- , Monad- , MonadIO- , MonadReader (Internal.Config RPCConfig)- )--runEventHandlerContext ::- Internal.Config RPCConfig -> EventHandler a -> IO a-runEventHandlerContext env (EventHandler a) =- runReaderT (runResourceT a) env--eventHandlerSource :: ConduitT () SomeMessage EventHandler ()-eventHandlerSource =- asks Internal.eventQueue >>= \q ->- forever $ yield =<< readSomeMessage q--eventHandler :: ConduitM SomeMessage EncodedResponse EventHandler ()-eventHandler =- await >>= \case- Nothing ->- return () -- i.e. close the conduit -- TODO signal shutdown globally- Just message -> do- handleMessage (fromMessage message, fromMessage message)- eventHandler--type EncodedResponse = C.Flush ByteString--yield' :: (MonadIO io) => MsgpackRPC.Message -> ConduitM i EncodedResponse io ()-yield' o = do- liftIO . debugM "EventHandler" $ "Sending: " ++ show o- yield . Chunk . encode $ toObject o- yield Flush--handleMessage ::- (Maybe FunctionCall, Maybe MsgpackRPC.Message) ->- ConduitM i EncodedResponse EventHandler ()-handleMessage = \case- (Just (FunctionCall fn params reply time), _) -> do- cfg <- asks Internal.customConfig- messageId <- atomically' $ do- i <- readTVar (nextMessageId cfg)- modifyTVar' (nextMessageId cfg) succ- modifyTVar' (recipients cfg) $ Map.insert i (time, reply)- return i- yield' $ MsgpackRPC.Request (Request fn messageId params)- (_, Just r@MsgpackRPC.Response{}) ->- yield' r- (_, Just n@MsgpackRPC.Notification{}) ->- yield' n- _ ->- return () -- i.e. skip to next message
− library/Neovim/RPC/FunctionCall.hs
@@ -1,108 +0,0 @@-{-# 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,- scall,- scall',- scallThrow,- atomically',- wait,- wait',- 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 UnliftIO.Exception (throwIO)--import Prelude---- | 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 env (STM (Either NeovimException result))-acall fn parameters = do- q <- Internal.asks' Internal.eventQueue- mv <- liftIO newEmptyTMVarIO- timestamp <- liftIO getCurrentTime- writeMessage q $ FunctionCall fn parameters mv timestamp- return $ convertObject <$> readTMVar mv- where- convertObject ::- (NvimObject result) =>- Either Object Object ->- Either NeovimException result- convertObject = \case- Left e -> Left $ ErrorResult (pretty fn) e- Right o -> case fromObject o of- Left e -> Left $ ErrorMessage e- Right r -> Right r--{- | Call a neovim function synchronously. This function blocks until the- result is available.--}-scall ::- (NvimObject result) =>- FunctionName ->- -- | Parameters in an 'Object' array- [Object] ->- -- | result value of the call or the thrown exception- Neovim env (Either NeovimException result)-scall fn parameters = acall fn parameters >>= atomically'---- | Similar to 'scall', but throw a 'NeovimException' instead of returning it.-scallThrow ::- (NvimObject result) =>- FunctionName ->- [Object] ->- Neovim env result-scallThrow fn parameters = scall fn parameters >>= either throwIO return--{- | Helper function similar to 'scall' that throws a runtime exception if the- result is an error object.--}-scall' :: NvimObject result => FunctionName -> [Object] -> Neovim env result-scall' fn = either throwIO pure <=< 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 env (STM result) -> Neovim env result-wait = (=<<) atomically'---- | Variant of 'wait' that discards the result.-wait' :: Neovim env (STM result) -> Neovim env ()-wait' = void . wait---- | Send the result back to the neovim instance.-respond :: (NvimObject result) => Request -> Either String result -> Neovim env ()-respond Request{..} result = do- q <- Internal.asks' Internal.eventQueue- writeMessage q . MsgpackRPC.Response reqId $- either (Left . toObject) (Right . toObject) result
− library/Neovim/RPC/SocketReader.hs
@@ -1,202 +0,0 @@-{- |-Module : Neovim.RPC.SocketReader-Description : The component which reads RPC messages from the neovim instance-Copyright : (c) Sebastian Witte-License : Apache-2.0--Maintainer : woozletoff@gmail.com-Stability : experimental--}-module Neovim.RPC.SocketReader (- runSocketReader,- parseParams,-) where--import Neovim.Classes-import Neovim.Context-import qualified Neovim.Context.Internal as Internal-import Neovim.Plugin.Classes (- CommandArguments (..),- CommandOption (..),- FunctionName (..),- FunctionalityDescription (..),- NeovimEventId (..),- NvimMethod (..),- Subscription (..),- getCommandOptions,- )-import Neovim.Plugin.IPC.Classes-import qualified Neovim.RPC.Classes as MsgpackRPC-import Neovim.RPC.Common-import Neovim.RPC.FunctionCall--import Conduit as C-import Control.Applicative-import Control.Concurrent.STM-import Control.Monad (void)-import Data.Conduit.Cereal (conduitGet2)-import Data.Default (def)-import Data.Foldable (foldl', forM_)-import qualified Data.Map as Map-import Data.Maybe (fromMaybe)-import Data.MessagePack-import Data.Monoid-import qualified Data.Serialize (get)-import System.IO (Handle)-import System.Log.Logger-import UnliftIO (timeout)-import UnliftIO.Async (async)--import Prelude--logger :: String-logger = "Socket Reader"--type SocketHandler = Neovim RPCConfig--{- | This function will establish a connection to the given socket and read- msgpack-rpc events from it.--}-runSocketReader ::- Handle ->- Internal.Config RPCConfig ->- IO ()-runSocketReader readableHandle cfg =- void . runNeovim (Internal.retypeConfig (Internal.customConfig cfg) cfg) . runConduit $ do- sourceHandle readableHandle- .| conduitGet2 Data.Serialize.get- .| messageHandlerSink--{- | Sink that delegates the messages depending on their type.- <https://github.com/msgpack-rpc/msgpack-rpc/blob/master/spec.md>--}-messageHandlerSink :: ConduitT Object Void SocketHandler ()-messageHandlerSink = awaitForever $ \rpc -> do- liftIO . debugM logger $ "Received: " <> show rpc- case fromObject rpc of- Right (MsgpackRPC.Request (Request fn i ps)) ->- handleRequest i fn ps- Right (MsgpackRPC.Response i r) ->- handleResponse i r- Right (MsgpackRPC.Notification (Notification eventId args)) ->- handleNotification eventId args- Left e ->- liftIO . errorM logger $ "Unhandled rpc message: " <> show e--handleResponse :: Int64 -> Either Object Object -> ConduitT a Void SocketHandler ()-handleResponse i result = do- answerMap <- asks recipients- mReply <- Map.lookup i <$> liftIO (readTVarIO answerMap)- case mReply of- Nothing ->- liftIO $ warningM logger "Received response but could not find a matching recipient."- Just (_, reply) -> do- atomically' . modifyTVar' answerMap $ Map.delete i- atomically' $ putTMVar reply result--lookupFunction ::- Internal.Config RPCConfig ->- FunctionName ->- IO (Maybe (FunctionalityDescription, Internal.FunctionType))-lookupFunction rpc (F functionName) = do- functionMap <- atomically $ readTMVar (Internal.globalFunctionMap rpc)- pure $ Map.lookup (NvimMethod functionName) functionMap--handleRequest :: Int64 -> FunctionName -> [Object] -> ConduitT a Void SocketHandler ()-handleRequest requestId functionToCall params = do- cfg <- lift Internal.ask'- void . liftIO . async $ timeout (10 * 1000 * 1000) (handle cfg)- return ()- where- handle :: Internal.Config RPCConfig -> IO ()- handle rpc =- lookupFunction rpc functionToCall >>= \case- Nothing -> do- let errM = "No provider for: " <> show functionToCall- debugM logger errM- writeMessage (Internal.eventQueue rpc) $- MsgpackRPC.Response requestId (Left (toObject errM))- Just (copts, Internal.Stateful c) -> do- now <- liftIO getCurrentTime- reply <- liftIO newEmptyTMVarIO- let q = (recipients . Internal.customConfig) rpc- liftIO . debugM logger $ "Executing stateful function with ID: " <> show requestId- atomically' . modifyTVar q $ Map.insert requestId (now, reply)- writeMessage c $ Request functionToCall requestId (parseParams copts params)--handleNotification :: NeovimEventId -> [Object] -> ConduitT a Void SocketHandler ()-handleNotification eventId@(NeovimEventId str) args = do- cfg <- lift Internal.ask'- liftIO (lookupFunction cfg (F str)) >>= \case- Just (copts, Internal.Stateful c) -> liftIO $ do- debugM logger $ "Executing function asynchronously: " <> show str- writeMessage c $ Notification eventId (parseParams copts args)- Nothing -> do- liftIO $ debugM logger $ "Handling event: " <> show str- subscriptions' <- lift $ Internal.asks' Internal.subscriptions- subscribers <- liftIO $- atomically $ do- s <- readTMVar subscriptions'- pure $ fromMaybe [] $ Map.lookup eventId (Internal.byEventId s)- forM_ subscribers $ \subscription -> liftIO $ subAction subscription args--parseParams :: FunctionalityDescription -> [Object] -> [Object]-parseParams (Function _ _) args = case args of- -- Defining a function on the remote host creates a function that, that- -- passes all arguments in a list. At the time of this writing, no other- -- arguments are passed for such a function.- --- -- The function generating the function on neovim side is called:- -- @remote#define#FunctionOnHost@- [ObjectArray fArgs] -> fArgs- _ -> args-parseParams cmd@(Command _ opts) args = case args of- (ObjectArray _ : _) ->- let cmdArgs = filter isPassedViaRPC (getCommandOptions opts)- (c, args') = foldl' createCommandArguments (def, []) $ zip cmdArgs args- in toObject c : args'- _ -> parseParams cmd [ObjectArray args]- where- isPassedViaRPC :: CommandOption -> Bool- isPassedViaRPC = \case- CmdSync{} -> False- _ -> True-- -- Neovim passes arguments in a special form, depending on the- -- CommandOption values used to export the (command) function (e.g. via- -- 'command' or 'command'').- createCommandArguments ::- (CommandArguments, [Object]) ->- (CommandOption, Object) ->- (CommandArguments, [Object])- createCommandArguments old@(c, args') = \case- (CmdRange _, o) ->- either (const old) (\r -> (c{range = Just r}, args')) $ fromObject o- (CmdCount _, o) ->- either (const old) (\n -> (c{count = Just n}, args')) $ fromObject o- (CmdBang, o) ->- either (const old) (\b -> (c{bang = Just b}, args')) $ fromObject o- (CmdNargs "*", ObjectArray os) ->- -- CommandArguments -> [String] -> Neovim r st a- (c, os)- (CmdNargs "+", ObjectArray (o : os)) ->- -- CommandArguments -> String -> [String] -> Neovim r st a- (c, o : [ObjectArray os])- (CmdNargs "?", ObjectArray [o]) ->- -- CommandArguments -> Maybe String -> Neovim r st a- (c, [toObject (Just o)])- (CmdNargs "?", ObjectArray []) ->- -- CommandArguments -> Maybe String -> Neovim r st a- (c, [toObject (Nothing :: Maybe Object)])- (CmdNargs "0", ObjectArray []) ->- -- CommandArguments -> Neovim r st a- (c, [])- (CmdNargs "1", ObjectArray [o]) ->- -- CommandArguments -> String -> Neovim r st a- (c, [o])- (CmdRegister, o) ->- either (const old) (\r -> (c{register = Just r}, args')) $ fromObject o- _ -> old-parseParams Autocmd{} args = case args of- [ObjectArray fArgs] -> fArgs- _ -> args
− library/Neovim/Test.hs
@@ -1,214 +0,0 @@-{-# LANGUAGE RecordWildCards #-}--{- |-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 (- runInEmbeddedNeovim,- runInEmbeddedNeovim',- Seconds (..),- TestConfiguration (..),- -- deprecated- testWithEmbeddedNeovim,-) where--import Neovim-import Neovim.API.Text (nvim_command, vim_command)-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.Default (Default)-import Data.Text (pack)-import GHC.IO.Exception (ioe_filename)-import Neovim.Plugin (startPluginThreads)-import Neovim.Util (oneLineErrorMessage)-import Path (File, Path, toFilePath)-import Prettyprinter (annotate, vsep)-import Prettyprinter.Render.Terminal (Color (..), color)-import System.Process.Typed (- ExitCode (ExitFailure, ExitSuccess),- Process,- createPipe,- getExitCode,- getStdin,- getStdout,- proc,- setStdin,- setStdout,- startProcess,- stopProcess,- waitExitCode,- )-import UnliftIO (Handle, IOException, async, atomically, cancel, catch, newEmptyMVar, putMVar, putTMVar, throwIO, timeout)-import UnliftIO.Concurrent (takeMVar, threadDelay)---- | Type synonym for 'Word'.-newtype Seconds = Seconds Word- deriving (Show)--microSeconds :: Integral i => Seconds -> i-microSeconds (Seconds s) = fromIntegral s * 1000 * 1000--newtype TestConfiguration = TestConfiguration- { cancelAfter :: Seconds- }- deriving (Show)--instance Default TestConfiguration where- def =- TestConfiguration- { cancelAfter = Seconds 2- }--{- | Run a neovim process with @-n --clean --embed@ and execute the- given action that will have access to the started instance.--The 'TestConfiguration' contains sensible defaults.--'env' is the state of your function that you want to test.--}-runInEmbeddedNeovim :: TestConfiguration -> Plugin env -> Neovim env a -> IO ()-runInEmbeddedNeovim TestConfiguration{..} plugin action =- warnIfNvimIsNotOnPath runTest- where- runTest = do- resultMVar <- newEmptyMVar- let action' = do- result <- action- q <- Internal.asks' Internal.transitionTo- putMVar q Internal.Quit- -- vim_command isn't asynchronous, so we need to avoid waiting- -- for the result of the operation by using 'async' since- -- neovim cannot send a result if it has quit.- _ <- async . void $ vim_command "qa!"- putMVar resultMVar result- (nvimProcess, cleanUp) <- startEmbeddedNvim cancelAfter plugin action'-- result <- timeout (microSeconds cancelAfter) (takeMVar resultMVar)-- waitExitCode nvimProcess >>= \case- ExitFailure i ->- fail $ "Neovim returned with an exit status of: " ++ show i- ExitSuccess -> case result of- Nothing -> fail "Test timed out"- Just _ -> pure ()- cleanUp--type TransitionHandler a = Internal.Config RPCConfig -> IO a--testTransitionHandler :: IO a -> TransitionHandler ()-testTransitionHandler onInitAction cfg =- takeMVar (Internal.transitionTo cfg) >>= \case- Internal.InitSuccess -> do- void onInitAction- testTransitionHandler onInitAction cfg- Internal.Restart -> do- fail "Restart unexpected"- Internal.Failure e -> do- fail . show $ oneLineErrorMessage e- Internal.Quit -> do- return ()--runInEmbeddedNeovim' :: TestConfiguration -> Neovim () a -> IO ()-runInEmbeddedNeovim' testCfg = runInEmbeddedNeovim testCfg Plugin{environment = (), exports = []}--{-# DEPRECATED testWithEmbeddedNeovim "Use \"runInEmbeddedNeovim def env action\" and open files with nvim_command \"edit file\"" #-}--{- | The same as 'runInEmbeddedNeovim' with the given file opened via @nvim_command "edit file"@.- - This method is kept for backwards compatibility.--}-testWithEmbeddedNeovim ::- -- | Optional path to a file that should be opened- Maybe (Path b File) ->- -- | Maximum time (in seconds) that a test is allowed to run- Seconds ->- -- | Read-only configuration- env ->- -- | Test case- Neovim env a ->- IO ()-testWithEmbeddedNeovim file timeoutAfter env action =- runInEmbeddedNeovim- def{cancelAfter = timeoutAfter}- Plugin{environment = env, exports = []}- (openTestFile <* action)- where- openTestFile = case file of- Nothing -> pure ()- Just f -> nvim_command $ pack $ "edit " ++ toFilePath f--warnIfNvimIsNotOnPath :: IO a -> IO ()-warnIfNvimIsNotOnPath test = void test `catch` \(e :: IOException) -> case ioe_filename e of- Just "nvim" ->- putDoc . annotate (color Red) $- vsep- [ "The neovim executable 'nvim' is not on the PATH."- , "You may not be testing fully!"- ]- _ ->- throwIO e--startEmbeddedNvim ::- Seconds ->- Plugin env ->- Neovim env () ->- IO (Process Handle Handle (), IO ())-startEmbeddedNvim timeoutAfter plugin (Internal.Neovim action) = do- nvimProcess <-- startProcess $- setStdin createPipe $- setStdout createPipe $- proc "nvim" ["-n", "--clean", "--embed"]-- cfg <- Internal.newConfig (pure Nothing) newRPCConfig-- socketReader <-- async . void $- runSocketReader- (getStdout nvimProcess)- (cfg{Internal.pluginSettings = Nothing})-- eventHandler <-- async . void $- runEventHandler- (getStdin nvimProcess)- (cfg{Internal.pluginSettings = Nothing})-- let actionCfg = Internal.retypeConfig (environment plugin) cfg- action' = runReaderT (runResourceT action) actionCfg- pluginHandlers <-- startPluginThreads (Internal.retypeConfig () cfg) [wrapPlugin plugin] >>= \case- Left e -> do- putMVar (Internal.transitionTo cfg) $ Internal.Failure e- pure []- Right (funMapEntries, pluginTids) -> do- atomically $- putTMVar- (Internal.globalFunctionMap cfg)- (Internal.mkFunctionMap funMapEntries)- putMVar (Internal.transitionTo cfg) Internal.InitSuccess- pure pluginTids-- transitionHandler <- async . void $ do- testTransitionHandler action' cfg- timeoutAsync <- async . void $ do- threadDelay $ microSeconds timeoutAfter- getExitCode nvimProcess >>= maybe (stopProcess nvimProcess) (\_ -> pure ())-- let cleanUp =- mapM_ cancel $- [socketReader, eventHandler, timeoutAsync, transitionHandler]- ++ pluginHandlers-- pure (nvimProcess, cleanUp)
− library/Neovim/Util.hs
@@ -1,32 +0,0 @@-{- |-Module : Neovim.Util-Description : Utility functions-Copyright : (c) Sebastian Witte-License : Apache-2.0--Maintainer : woozletoff@gmail.com-Stability : experimental-Portability : GHC--}-module Neovim.Util (- whenM,- unlessM,- oneLineErrorMessage,-) where--import Control.Monad (unless, when)-import qualified Data.Text as T-import Neovim.Context---- | 'when' with a monadic predicate.-whenM :: (Monad m) => m Bool -> m () -> m ()-whenM mp a = mp >>= \p -> when p a---- | 'unless' with a monadic predicate.-unlessM :: (Monad m) => m Bool -> m () -> m ()-unlessM mp a = mp >>= \p -> unless p a--oneLineErrorMessage :: Doc AnsiStyle -> T.Text-oneLineErrorMessage d = case T.lines $ docToText d of- (x : _) -> x- [] -> mempty
nvim-hs.cabal view
@@ -1,5 +1,6 @@+cabal-version: 3.0 name: nvim-hs-version: 2.3.2.0+version: 2.3.2.1 synopsis: Haskell plugin backend for neovim description: This package provides a plugin provider for neovim. It allows you to write@@ -26,10 +27,9 @@ license-file: LICENSE author: Sebastian Witte maintainer: woozletoff@gmail.com-copyright: Copyright 2017-2018 Sebastian Witte <woozletoff@gmail.com>+copyright: Copyright 2017-2022 Sebastian Witte <woozletoff@gmail.com> category: Editor build-type: Simple-cabal-version: 1.18 extra-source-files: test-files/hello , apiblobs/0.1.7.msgpack , apiblobs/0.2.0.msgpack@@ -48,7 +48,44 @@ type: git location: https://github.com/neovimhaskell/nvim-hs +common defaults+ default-language: Haskell2010+ default-extensions: BangPatterns+ , ScopedTypeVariables+ , StrictData+ other-extensions: DeriveDataTypeable+ , DeriveGeneric+ , DerivingVia+ , ExistentialQuantification+ , FlexibleContexts+ , FlexibleInstances+ , GADTs+ , GeneralizedNewtypeDeriving+ , LambdaCase+ , MultiParamTypeClasses+ , NamedFieldPuns+ , NoOverloadedStrings+ , NoRebindableSyntax+ , OverloadedLists+ , OverloadedStrings+ , PackageImports+ , RankNTypes+ , RecordWildCards+ , TemplateHaskell+ ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates+ build-depends: base >=4.9 && < 5 + , containers+ , data-default+ , deepseq >= 1.1 && < 1.5+ , prettyprinter+ , prettyprinter-ansi-terminal+ , unliftio >= 0.2+ , unliftio-core >= 0.2+ , vector+ , void+ library+ import: defaults exposed-modules: Neovim , Neovim.Quickfix , Neovim.Debug@@ -83,37 +120,11 @@ , Neovim.Util , Neovim.API.Parser , Neovim.API.TH- default-extensions: OverloadedStrings- , LambdaCase- , ScopedTypeVariables- other-extensions: BangPatterns- , CPP- , DeriveDataTypeable- , DeriveGeneric- , ExistentialQuantification- , FlexibleContexts- , FlexibleInstances- , GADTs- , GeneralizedNewtypeDeriving- , MultiParamTypeClasses- , MultiWayIf- , NamedFieldPuns- , NoOverloadedStrings- , OverlappingInstances- , PackageImports- , RankNTypes- , RecordWildCards- , TemplateHaskell- build-depends: base >=4.9 && < 5- , bytestring+ other-extensions: CPP+ build-depends: bytestring , cereal , cereal-conduit >= 0.8.0 , conduit >= 1.3.0- , containers- , data-default- , deepseq >= 1.1 && < 1.5- , path- , path-io , foreign-store , hslogger , messagepack >= 0.5.4@@ -122,26 +133,14 @@ , optparse-applicative , time-locale-compat , megaparsec < 10- , prettyprinter >= 1.7 && < 2- , prettyprinter-ansi-terminal- , resourcet >= 1.1.11- , stm , streaming-commons , template-haskell , template-haskell-compat-v0208 >= 0.1.9 , text , time- , transformers- , transformers-base , typed-process- , unliftio >= 0.2- , unliftio-core >= 0.2 , utf8-string- , vector- , void- hs-source-dirs: library- default-language: Haskell2010- ghc-options: -Wall+ hs-source-dirs: src if os(windows) cpp-options: -DWINDOWS@@ -151,62 +150,24 @@ test-suite hspec+ import: defaults type: exitcode-stdio-1.0- hs-source-dirs: test-suite+ hs-source-dirs: tests main-is: Spec.hs- default-extensions: OverloadedStrings- , LambdaCase- , ScopedTypeVariables- default-language: Haskell2010- build-depends: base >= 4.6 && < 5- , nvim-hs+ build-depends: nvim-hs , hspec ==2.* , hspec-discover , QuickCheck >=2.6 - , bytestring- , cereal- , cereal-conduit- , conduit- , containers- , data-default- , path- , path-io- , foreign-store- , hslogger- , mtl- , messagepack- , time-locale-compat- , network- , optparse-applicative- , megaparsec- , prettyprinter- , prettyprinter-ansi-terminal- , typed-process >= 0.2.1.0- , resourcet- , stm- , streaming-commons- , text- , template-haskell- , template-haskell-compat-v0208- , time- , transformers- , transformers-base- , unliftio- , unliftio-core- , utf8-string- , vector- , HUnit-- other-modules: Neovim.API.THSpec- , Neovim.API.THSpecFunctions- , Neovim.EmbeddedRPCSpec- , Neovim.EventSubscriptionSpec- , Neovim.Plugin.ClassesSpec+ other-modules: API.THSpec+ , API.THSpecFunctions+ , EmbeddedRPCSpec+ , EventSubscriptionSpec+ , Plugin.ClassesSpec , AsyncFunctionSpec- , Neovim.RPC.SocketReaderSpec- , Neovim.RPC.CommonSpec+ , RPC.SocketReaderSpec+ , RPC.CommonSpec ghc-options: -threaded -rtsopts -with-rtsopts=-N
+ src/Neovim.hs view
@@ -0,0 +1,476 @@+{- |+Module : Neovim+Description : API for the neovim plugin provider /nvim-hs/+Copyright : (c) Sebastian Witte+License : Apache-2.0++Maintainer : woozletoff@gmail.com+Stability : experimental+Portability : GHC (due to Template Haskell)++This module should contain all the things you need to write neovim plugins in+your favorite language! @:-)@++The documentation in this module should provide every information you need to start+writing plugins.+-}+module Neovim (+ -- * Installation+ -- $installation++ -- * Tutorial+ -- ** Motivation+ -- $overview+ -- ** Combining existing plugins+ -- $existingplugins+ Neovim,+ neovim,+ NeovimConfig(..),+ defaultConfig,+ def,+++ -- ** Creating a plugin+ -- $creatingplugins+ NeovimPlugin(..),+ Plugin(..),+ NvimObject(..),+ (+:),+ Dictionary,+ Object(..),+ wrapPlugin,+ function,+ function',+ command,+ command',+ autocmd,+ Synchronous(..),+ CommandOption(..),+ RangeSpecification(..),+ CommandArguments(..),+ AutocmdOptions(..),+ addAutocmd,++ ask,+ asks,++ -- ** Subscribing to notifications or events+ Subscription,+ subscribe,+ unsubscribe,+ NeovimEventId(..),++ -- ** Creating a stateful plugin+ -- $statefulplugin++ -- ** Calling remote functions+ -- $remote+ wait,+ wait',+ err,+ errOnInvalidResult,+ catchNeovimException,+ NeovimException(..),++ -- * Unsorted exports+ -- This section contains just a bunch of more or less useful functions which+ -- were not introduced in any of the previous sections.+ liftIO,+ whenM,+ unlessM,+ docToObject,+ docFromObject,+ Doc,+ AnsiStyle,+ Pretty(..),+ putDoc,+ exceptionToDoc,+ Priority(..),+ module Control.Monad,+ module Control.Applicative,+ module Data.Monoid,+ module Data.Int,+ module Data.Word,++ ) where++import Control.Applicative+import Control.Monad (void)+import Control.Monad.IO.Class (liftIO)+import Data.Default (def)+import Data.Int (Int16, Int32, Int64, Int8)+import Data.MessagePack (Object (..))+import Data.Monoid+import Data.Word (Word, Word16, Word32, Word8)+import Neovim.API.TH (autocmd, command, command',+ function, function')+import Neovim.Classes (Dictionary, NvimObject (..),+ Doc, AnsiStyle, Pretty(..),+ docFromObject, docToObject, (+:))+import Neovim.Config (NeovimConfig (..))+import Neovim.Context (Neovim,+ NeovimException(..),+ exceptionToDoc,+ ask, asks, err,+ errOnInvalidResult, subscribe, unsubscribe)+import Neovim.Main (neovim)+import Neovim.Exceptions (catchNeovimException)+import Neovim.Plugin (addAutocmd)+import Neovim.Plugin.Classes (AutocmdOptions (..),+ CommandArguments (..),+ CommandOption (CmdBang, CmdCount, CmdRange, CmdRegister, CmdSync),+ RangeSpecification (..),+ Synchronous (..),+ Subscription, NeovimEventId(..))+import Neovim.Plugin.Internal (NeovimPlugin (..), Plugin (..),+ wrapPlugin)+import Neovim.RPC.FunctionCall (wait, wait')+import Neovim.Util (unlessM, whenM)+import System.Log.Logger (Priority (..))+import Prettyprinter.Render.Terminal (putDoc)+-- Installation+{- $installation++Installation instructions are in the README.md file that comes with the source+of this package. It is also on the repositories front page.++-}++-- Tutorial+-- Overview+{- $overview+An @nvim-hs@ plugin is just a collection of haskell functions that can be+called from neovim.++As a user of plugins, you basically have two choices. You can start every+plugin in a separate process and use normal vim plugin management strategies+such as <https://github.com/junegunn/vim-plug vim-plug>+or <https://github.com/tpope/vim-pathogen pathogen>.+Alternatively, you can create a haskell project and depend on the plugins+you want to use and plumb them together. This plumbing is equivalent to+writing a plugin.++Since you are reading haddock documentation, you probably want the latter, so+just keep reading. @:-)@++-}+++-- Combining Existing Plugins+{- $existingplugins+The easiest way to start is to use the stack template as described in the+@README.md@ of this package. If you initialize it in your neovim configuration+directory (@~\/.config\/nvim@ on linux-based systems), it should automatically be+compiled and run with two simple example plugins.++You have to define a haskell project that depends on this package and+contains an executable secion within a main file that looks something like this:++@+import TestPlugin.ExamplePlugin (examplePlugin)++main = 'neovim' 'def'+ { 'plugins' = [ examplePlugin ] ++ 'plugins' 'defaultConfig'+ }+@+++/nvim-hs/ is all about importing and creating plugins. This is done following a+concise API. Let's start by making a given plugin available inside+our plugin provider. Assuming that we have installed a cabal package that exports+an @examplePlugin@ from the module @TestPlugin.ExamplePlugin@, a minimal+main file would look something like this:++That's all you have to do! Multiple plugins are simply imported and put in a+list.++-}++-- | Default configuration options for /nvim-hs/. If you want to keep the+-- default plugins enabled, you can define your config like this:+--+-- @+-- main = 'neovim' 'defaultConfig'+-- { plugins = plugins defaultConfig ++ myPlugins+-- }+-- @+--+defaultConfig :: NeovimConfig+defaultConfig = Config+ { plugins = []+ , logOptions = Nothing+ }+++-- Creating a plugin+{- $creatingplugins+Creating plugins isn't difficult either. You just have to follow and survive the+compile time errors of seemingly valid code. This may sound scary, but it is not+so bad. We will cover most pitfalls in the following paragraphs and if there+isn't a solution for your error, you can always ask any friendly Haskeller in+\#haskell on @irc.freenode.net@!++Enough scary stuff said for now, let's write a plugin!+Due to a stage restriction in GHC when using Template Haskell+(i.e. code generation), we must define+our functions in a different module than @\$XDG_CONFIG_HOME\/nvim\/nvim.hs@.+(I'm assuming here, that you use @\$XDG_CONFIG_HOME\/nvim\/@ as the base+directory for historical reasons and because it might be an appropriate place.)+This is a bit unfortunate, but it will save you a lot of boring boilerplate and+it will present you with helpful error messages if your plugin's functions do+not work together with neovim.++So, let\'s write a plugin that calculates the @n@th Fibonacci number. Don\'t we all+love those!++File @\~\/.config\/nvim\/lib\/Fibonacci\/Plugin.hs@:++@+module Fibonacci.Plugin (fibonacci) where++import "Neovim"++\-\- \| Neovim is not really good with big numbers, so we return a 'String' here.+fibonacci :: 'Int' -> 'Neovim' env 'String'+fibonacci n = 'return' . 'show' \$ fibs !! n+ where+ fibs :: [Integer]+ fibs = 0:1:'scanl1' (+) fibs+@++File @\~\/.config\/nvim\/lib\/Fibonacci.hs@:++@+\{\-\# LANGUAGE TemplateHaskell \#\-\}+module Fibonacci (plugin) where++import "Neovim"+import Fibonacci.Plugin (fibonacci)++plugin :: 'Neovim' () 'NeovimPlugin'+plugin = 'wrapPlugin' Plugin+ { 'environment' = ()+ , 'exports' = [ $('function'' 'fibonacci) 'Sync' ]+ }+@++File @~\/.config\/nvim\/nvim.hs@:++@+import "Neovim"++import qualified Fibonacci as Fibonacci++main :: 'IO' ()+main = 'neovim' 'defaultConfig'+ { 'plugins' = 'plugins' 'defaultConfig' ++ [ Fibonacci.plugin ]+ }+@++Let's analyze how it works. The module @Fibonacci.Plugin@ simply defines a function+that takes the @n@th element of the infinite list of Fibonacci numbers. Even though+the definition is very concise and asthetically pleasing, the important part is the+type signature for @fibonacci@. Similarly how @main :: IO ()@ works in normal Haskell+programs, 'Neovim' is the environment we need for plugins. Internally, it stores a+few things that are needed to communicate with neovim, but that shouldn't bother you+too much. Simply remember that every plugin function must have a function signature+whose last element is of type @'Neovim' env something@. The result of @fibonacci@+is 'String' because neovim cannot handle big numbers so well. :-)+You can use any argument or result type as long as it is an instance of 'NvimObject'.++The second part of of the puzzle, which is the definition of @plugin@+in @~\/.config\/nvim\/lib\/Fibonacci.hs@, shows what a plugin is. It is essentially+an empty environment and a list of functions, commands or autocommands in the context of vim+terminology. In the end, all of those things map to a function at the side+of /nvim-hs/. If you really want to know what the distinction between those is, you+have to consult the @:help@ pages of neovim (e.g. @:help :function@, @:help :command@+and @:help :autocmd@). What's relevant from the side of /nvim-hs/ is the environment.+The environment is a data type that is avaiable to all exported functions of your+plugin. This example does not make use of anything of that environment, so+we used '()', also known as unit, as our environment. The definition of+@fibonacci@ uses a type variable @env@ as it does not access the environment and+can handle any environment. If you want to access the environment, you can call+'ask' or 'asks' if you are inside a 'Neovim' environment. An example that shows+you how to use it can be found in a later chapter.++Now to the magical part: @\$('function'' 'fibonacci)@. This is a so called+Template Haskell splice and this is why you need+@\{\-\# LANGUAGE TemplateHaskell \#\-\}@ at the top of your Haskell file. This+splice simply generates Haskell code that, in this case, still needs a value+of type 'Synchronous' which indicates whether calling the function will make+neovim wait for its result or not. Internally, the expression+@\$('function'' 'fibonacci) 'Sync'@ creates a value that contains all the+necessary information to properly register the function with neovim. Note the+prime symbol before the function name! This would have probably caused you+some trouble if I haven't mentioned it here! Template Haskell simply requires+you to put that in front of function names that are passed in a splice.++If you compile this and restart the plugin, you can calculate the 2000th Fibonacci+number like as if it were a normal vim-script function:++@+:echo Fibonacci(2000)+@++You can also directly insert the result inside any text file opened with neovim+by using the evaluation register by pressing the following key sequence in insert+mode:++@+\<C-r\>=Fibonacci(2000)+@++The haddock documentation will now list all the things we have used up until now.+Afterwards, there is a plugin with state which uses the environment.++-}+-- Creating a stateful plugin+{- $statefulplugin+Now that we are a little bit comfortable with the interface provided by /nvim-hs/,+we can start to write a more complicated plugin. Let's create a random number+generator!++File @~\/.config\/nvim\/lib\/Random\/Plugin.hs@:++@+module Random.Plugin (nextRandom, setNextRandom) where++import "Neovim"++import System.Random (newStdGen, randoms)+import UnliftIO.STM (TVar, atomically, readTVar, modifyTVar, newTVarIO)++-- You may want to define a type alias for your plugin, so that if you change+-- your environment, you don't have to change all type signatures.+--+-- If I were to write a real plugin, I would probably also create a data type+-- instead of directly using a TVar here.+--+type MyNeovim a = Neovim ('TVar' ['Int16']) a++-- This function will create an initial environment for our random number+-- generator. Note that the return type is the type of our environment.+randomNumbers :: Neovim startupEnv (TVar [Int16])+randomNumbers = do+ g <- liftIO newStdGen -- Create a new seed for a pseudo random number generator+ newTVarIO (randoms g) -- Put an infinite list of random numbers into a TVar++-- | Get the next random number and update the state of the list.+nextRandom :: MyNeovim 'Int16'+nextRandom = do+ tVarWithRandomNumbers <- 'ask'+ atomically $ do+ -- pick the head of our list of random numbers+ r \<- 'head' <$> 'readTVar' tVarWithRandomNumbers++ -- Since we do not want to return the same number all over the place+ -- remove the head of our list of random numbers+ modifyTVar tVarWithRandomNumbers 'tail'++ 'return' r+++-- | You probably don't want this in a random number generator, but this shows+-- hoy you can edit the state of a stateful plugin.+setNextRandom :: 'Int16' -> MyNeovim ()+setNextRandom n = do+ tVarWithRandomNumbers <- 'ask'++ -- cons n to the front of the infinite list+ atomically $ modifyTVar tVarWithRandomNumbers (n:)+@++File @~\/.config\/nvim\/lib\/Random.hs@:++@+\{\-\# LANGUAGE TemplateHaskell \#\-\}+module Random (plugin) where++import "Neovim"+import Random.Plugin (nextRandom, setNextRandom)+import "System.Random" ('newStdGen', 'randoms')++plugin :: 'Neovim' ('StartupConfig' 'NeovimConfig') () 'NeovimPlugin'+plugin = do+ env <- randomNumbers+ 'wrapPlugin' 'Plugin'+ { environment = env+ , 'exports' =+ [ $('function'' 'nextRandom) 'Sync'+ , $('function' \"SetNextRandom\" 'setNextRandom) 'Async'+ ]+ }+@++File @~\/.config\/nvim\/nvim.hs@:++@+import "Neovim"++import qualified Fibonacci as Fibonacci+import qualified Random as Random++main :: 'IO' ()+main = 'neovim' 'defaultConfig'+ { 'plugins' = 'plugins' 'defaultConfig' ++ [ Fibonacci.plugin, Random.plugin ]+ }+@+++That wasn't too hard, was it? The definition is very similar to the previous+example, we just were able to mutate our state and share that with other+functions. Another noteworthy detail, in case you+are not familiar with it, is the use of 'liftIO' in front of 'newStdGen'. You+have to do this, because 'newStdGen' has type @'IO' 'StdGen'@ but the actions+inside the startup code are of type+@'Neovim' () something@. 'liftIO' lifts an+'IO' function so that it can be run inside the 'Neovim' context (or more+generally, any monad that implements the 'MonadIO' type class).++After you have saved these files (and removed any typos @:-)@), you can restart+/nvim-hs/ with @:RestartNvimhs@ and insert random numbers in your text files!++@+\<C-r\>=NextRandom()+@++You can also cheat and pretend you know the next number:++@+:call SetNextRandom(42)+@++-}+-- Calling remote functions+{- $remote+Calling remote functions is only possible inside a 'Neovim' context. There are+a few patterns of return values for the available functions. Let's start with+getting some abstract 'Buffer' object, test whether it is valid and then try+to rename it.++@+inspectBuffer :: 'Neovim' env ()+inspectBuffer = do+ cb <- 'vim_get_current_buffer'+ isValid <- 'buffer_is_valid' cb+ when isValid $ do+ let newName = "magic"+ cbName \<- 'wait'' $ 'buffer_set_name' cb newName+ case () of+ _ | cbName == newName -> 'return' ()+ _ -> 'err' $ "Renaming the current buffer failed!"+@++You may have noticed the 'wait'' function in there. Some functions have a return+type with 'STM' in it. This means that the function call is asynchronous. We can+'wait' (or 'wait'') for the result at the point at which we actually need it. In+this short example, we put the 'wait'' directly in front of the remote function+call because we want to inspect the result immediately, though. The other+functions either returned a result directly or they returned+@'Either' 'Object' something@ whose result we inspected ourselves. The 'err'+function directly terminates the current thread and sends the given error+message to neovim which the user immediately notices.++That's pretty much all there is to it.+-}+
+ src/Neovim/API/ByteString.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE NoOverloadedStrings #-}++{- |+Module : Neovim.API.ByteString+Description : ByteString based API+Copyright : (c) Sebastian Witte+License : Apache-2.0++Maintainer : woozletoff@gmail.com+Stability : experimental+Portability : GHC+-}+module Neovim.API.ByteString where++import Neovim.API.TH++$(generateAPI bytestringVectorTypeMap)
+ src/Neovim/API/Parser.hs view
@@ -0,0 +1,171 @@+{-# LANGUAGE OverloadedStrings #-}+{- |+Module : Neovim.API.Parser+Description : P.Parser for the msgpack output stram API+Copyright : (c) Sebastian Witte+License : Apache-2.0++Maintainer : woozletoff@gmail.com+Stability : experimental+-}+module Neovim.API.Parser (+ NeovimAPI (..),+ NeovimFunction (..),+ NeovimType (..),+ parseAPI,+) where++import Neovim.Classes+import Neovim.OS (isWindows)++import Control.Applicative (optional)+import Control.Monad.Except (MonadError (throwError), forM)+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as LB+import Data.Map (Map)+import qualified Data.Map as Map+import Data.MessagePack (Object)+import Data.Serialize (decode)+import Neovim.Compat.Megaparsec as P (+ MonadParsec (eof, try),+ Parser,+ char,+ noneOf,+ oneOf,+ parse,+ some,+ space,+ string,+ (<|>),+ )+import System.Process.Typed (proc, readProcessStdout_)+import UnliftIO.Exception (+ SomeException,+ catch,+ )++import Prelude++data NeovimType+ = SimpleType String+ | NestedType NeovimType (Maybe Int)+ | Void+ deriving (Show, Eq)++{- | This data type contains simple information about a function as received+ throudh the @nvim --api-info@ command.+-}+data NeovimFunction = NeovimFunction+ { -- | function name+ name :: String+ , -- | A list of type name and variable name.+ parameters :: [(NeovimType, String)]+ , -- | Indicator whether the function can fail/throws exceptions.+ canFail :: Bool+ , -- | Indicator whether the this function is asynchronous.+ async :: Bool+ , -- | Functions return type.+ returnType :: NeovimType+ }+ deriving (Show)++{- | This data type represents the top-level structure of the @nvim --api-info@+ output.+-}+data NeovimAPI = NeovimAPI+ { -- | The error types are defined by a name and an identifier.+ errorTypes :: [(String, Int64)]+ , -- | Extension types defined by neovim.+ customTypes :: [(String, Int64)]+ , -- | The remotely executable functions provided by the neovim api.+ functions :: [NeovimFunction]+ }+ deriving (Show)++-- | Run @nvim --api-info@ and parse its output.+parseAPI :: IO (Either (Doc AnsiStyle) NeovimAPI)+parseAPI = either (Left . pretty) extractAPI <$> go+ where+ go+ | isWindows = readFromAPIFile+ | otherwise = decodeAPI `catch` \(_ignored :: SomeException) -> readFromAPIFile++decodeAPI :: IO (Either String Object)+decodeAPI =+ decode . LB.toStrict <$> readProcessStdout_ (proc "nvim" ["--api-info"])++extractAPI :: Object -> Either (Doc AnsiStyle) NeovimAPI+extractAPI apiObj =+ fromObject apiObj >>= \apiMap ->+ NeovimAPI+ <$> extractErrorTypes apiMap+ <*> extractCustomTypes apiMap+ <*> extractFunctions apiMap++readFromAPIFile :: IO (Either String Object)+readFromAPIFile = (decode <$> B.readFile "api") `catch` returnNoApiForCodegeneratorErrorMessage+ where+ returnNoApiForCodegeneratorErrorMessage :: SomeException -> IO (Either String Object)+ returnNoApiForCodegeneratorErrorMessage _ =+ return . Left $+ "The 'nvim' process could not be started and there is no file named 'api' in the working directory as a substitute."++oLookup :: (NvimObject o) => String -> Map String Object -> Either (Doc AnsiStyle) o+oLookup qry = maybe throwErrorMessage fromObject . Map.lookup qry+ where+ throwErrorMessage = throwError $ "No entry for:" <+> pretty qry++oLookupDefault :: (NvimObject o) => o -> String -> Map String Object -> Either (Doc AnsiStyle) o+oLookupDefault d qry m = maybe (return d) fromObject $ Map.lookup qry m++extractErrorTypes :: Map String Object -> Either (Doc AnsiStyle) [(String, Int64)]+extractErrorTypes objAPI = extractTypeNameAndID =<< oLookup "error_types" objAPI++extractTypeNameAndID :: Object -> Either (Doc AnsiStyle) [(String, Int64)]+extractTypeNameAndID m = do+ types <- Map.toList <$> fromObject m+ forM types $ \(errName, idMap) -> do+ i <- oLookup "id" idMap+ return (errName, i)++extractCustomTypes :: Map String Object -> Either (Doc AnsiStyle) [(String, Int64)]+extractCustomTypes objAPI = extractTypeNameAndID =<< oLookup "types" objAPI++extractFunctions :: Map String Object -> Either (Doc AnsiStyle) [NeovimFunction]+extractFunctions objAPI = mapM extractFunction =<< oLookup "functions" objAPI++toParameterlist :: [(String, String)] -> Either (Doc AnsiStyle) [(NeovimType, String)]+toParameterlist ps = forM ps $ \(t, n) -> do+ t' <- parseType t+ return (t', n)++extractFunction :: Map String Object -> Either (Doc AnsiStyle) NeovimFunction+extractFunction funDefMap =+ NeovimFunction+ <$> oLookup "name" funDefMap+ <*> (oLookup "parameters" funDefMap >>= toParameterlist)+ <*> oLookupDefault True "can_fail" funDefMap+ <*> oLookupDefault False "async" funDefMap+ <*> (oLookup "return_type" funDefMap >>= parseType)++parseType :: String -> Either (Doc AnsiStyle) NeovimType+parseType s = either (throwError . pretty . show) return $ parse (pType <* eof) s s++pType :: P.Parser NeovimType+pType = pArray P.<|> pVoid P.<|> pSimple++pVoid :: P.Parser NeovimType+pVoid = Void <$ (P.try (string "void") <* eof)++pSimple :: P.Parser NeovimType+pSimple = SimpleType <$> P.some (noneOf [',', ')'])++pArray :: P.Parser NeovimType+pArray =+ NestedType+ <$> (P.try (string "ArrayOf(") *> pType)+ <*> optional pNum+ <* char ')'++pNum :: P.Parser Int+pNum = read <$> (P.try (char ',') *> space *> P.some (oneOf ['0' .. '9']))
+ src/Neovim/API/String.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE NoOverloadedStrings #-}++{- |+Module : Neovim.API.String+Description : String based API+Copyright : (c) Sebastian Witte+License : Apache-2.0++Maintainer : woozletoff@gmail.com+Stability : experimental++Note that this module is completely generated. If you're reading this on+hackage, the actual functions of this module may be different from what is+available to you. All the functions in this module depend on the neovim version+that was used when this package was compiled.+-}+module Neovim.API.String where++import Neovim.API.TH++$(generateAPI stringListTypeMap)
+ src/Neovim/API/TH.hs view
@@ -0,0 +1,579 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE TemplateHaskell #-}++{- |+Module : Neovim.API.TH+Description : Template Haskell API generation module+Copyright : (c) Sebastian Witte+License : Apache-2.0++Maintainer : woozletoff@gmail.com+Stability : experimental+-}+module Neovim.API.TH (+ generateAPI,+ function,+ function',+ command,+ command',+ autocmd,+ stringListTypeMap,+ textVectorTypeMap,+ bytestringVectorTypeMap,+ createFunction,+ module UnliftIO.Exception,+ module Neovim.Classes,+ module Data.Data,+ module Data.MessagePack,+) where++import Neovim.API.Parser+import Neovim.Classes+import Neovim.Context+import Neovim.Plugin.Classes (+ CommandArguments (..),+ CommandOption (..),+ FunctionName (..),+ FunctionalityDescription (..),+ mkCommandOptions,+ )+import Neovim.Plugin.Internal (ExportedFunctionality (..))+import Neovim.RPC.FunctionCall++import Language.Haskell.TH hiding (conP, dataD, instanceD)+import TemplateHaskell.Compat.V0208++import Control.Applicative+import Control.Arrow (first)+import Control.Exception+import Control.Monad+import Data.ByteString (ByteString)+import Data.Char (isUpper, toUpper)+import Data.Data (Data, Typeable)+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe+import Data.MessagePack+import Data.Monoid+import qualified Data.Set as Set+import Data.Text (Text)+import qualified Data.Text as T+import Data.Vector (Vector)+import Prettyprinter (viaShow)+import UnliftIO (STM)+import UnliftIO.Exception++import Prelude++{- | Generate the API types and functions provided by @nvim --api-info@.++ The provided map allows the use of different Haskell types for the types+ defined in the API. The types must be an instance of 'NvimObject' and they+ must form an isomorphism with the sent messages types. Currently, it+ provides a Convenient way to replace the /String/ type with 'Text',+ 'ByteString' or 'String'.+-}+generateAPI :: TypeMap -> Q [Dec]+generateAPI typeMap = do+ api <- either (fail . show) return =<< runIO parseAPI+ let exceptionName = mkName "NeovimExceptionGen"+ exceptions = (\(n, i) -> (mkName ("Neovim" <> n), i)) `map` errorTypes api+ customTypesN = first mkName `map` customTypes api+ join+ <$> sequence+ [ join . pure <$> createDataTypeWithByteStringComponent exceptionName (map fst exceptions)+ , exceptionInstance exceptionName+ , customTypeInstance exceptionName exceptions+ , fmap join (mapM ((\n -> createDataTypeWithByteStringComponent n [n]) . fst) customTypesN)+ , join <$> mapM (\(n, i) -> customTypeInstance n [(n, i)]) customTypesN+ , fmap join . mapM (createFunction typeMap) $ functions api+ ]++-- | Maps type identifiers from the neovim API to Haskell types.+data TypeMap = TypeMap+ { typesOfAPI :: Map String (Q Type)+ , list :: Q Type+ }++stringListTypeMap :: TypeMap+stringListTypeMap =+ TypeMap+ { typesOfAPI =+ Map.fromList+ [ ("Boolean", [t|Bool|])+ , ("Integer", [t|Int64|])+ , ("LuaRef", [t|Int64|])+ , ("Float", [t|Double|])+ , ("String", [t|String|])+ , ("Array", [t|[Object]|])+ , ("Dictionary", [t|Map String Object|])+ , ("void", [t|()|])+ ]+ , list = listT+ }++textVectorTypeMap :: TypeMap+textVectorTypeMap =+ stringListTypeMap+ { typesOfAPI = adjustTypeMapForText $ typesOfAPI stringListTypeMap+ , list = [t|Vector|]+ }+ where+ adjustTypeMapForText =+ Map.insert "String" [t|Text|]+ . Map.insert "Array" [t|Vector Object|]+ . Map.insert "Dictionary" [t|Map Text Object|]++bytestringVectorTypeMap :: TypeMap+bytestringVectorTypeMap =+ textVectorTypeMap+ { typesOfAPI = adjustTypeMapForByteString $ typesOfAPI textVectorTypeMap+ }+ where+ adjustTypeMapForByteString =+ Map.insert "String" [t|ByteString|]+ . Map.insert "Array" [t|Vector Object|]+ . Map.insert "Dictionary" [t|Map ByteString Object|]++apiTypeToHaskellType :: TypeMap -> NeovimType -> Q Type+apiTypeToHaskellType typeMap@TypeMap{typesOfAPI, list} at = case at of+ Void -> [t|()|]+ NestedType t Nothing ->+ appT list $ apiTypeToHaskellType typeMap t+ NestedType t (Just n) ->+ foldl appT (tupleT n) . replicate n $ apiTypeToHaskellType typeMap t+ SimpleType t ->+ fromMaybe ((conT . mkName) t) $ Map.lookup t typesOfAPI++{- | This function will create a wrapper function with neovim's function name+ as its name.++ Synchronous function:+ @+ buffer_get_number :: Buffer -> Neovim Int64+ buffer_get_number buffer = scall "buffer_get_number" [toObject buffer]+ @++ Asynchronous function:+ @+ vim_eval :: String -> Neovim (TMVar Object)+ vim_eval str = acall "vim_eval" [toObject str]+ @++ Asynchronous function without a return value:+ @+ vim_feed_keys :: String -> String -> Bool -> Neovim ()+ vim_feed_keys keys mode escape_csi =+ acallVoid "vim_feed_keys" [ toObject keys+ , toObject mode+ , toObject escape_csi+ ]+ @+-}+createFunction :: TypeMap -> NeovimFunction -> Q [Dec]+createFunction typeMap nf = do+ let withDeferred+ | async nf = appT [t|STM|] . appT [t|Either NeovimException|]+ | otherwise = id++ callFn+ | async nf = [|acall|]+ | otherwise = [|scall'|]++ functionName = mkName $ name nf+ toObjVar v = [|toObject $(varE v)|]++ let env = mkName "env"+ retType <- appT [t|Neovim $(varT env)|]+ . withDeferred+ . apiTypeToHaskellType typeMap+ $ returnType nf++ -- prefix with arg0_, arg1_ etc. to prevent generated code from crashing due+ -- to keywords being used.+ -- see https://github.com/neovimhaskell/nvim-hs/issues/65+ let prefixWithNumber i n = "arg" ++ show i ++ "_" ++ n+ applyPrefixWithNumber =+ zipWith+ (\i (t, n) -> (t, prefixWithNumber i n))+ [0 :: Int ..]+ . parameters+ vars <-+ mapM+ ( \(t, n) ->+ (,)+ <$> apiTypeToHaskellType typeMap t+ <*> newName n+ )+ $ applyPrefixWithNumber nf++ sequence+ [ (sigD functionName . return)+ . ForallT [specifiedPlainTV env] []+ $ foldr ((AppT . AppT ArrowT) . fst) retType vars+ , funD+ functionName+ [ clause+ (map (varP . snd) vars)+ ( normalB+ ( callFn+ `appE` ([|(F . T.pack)|] `appE` (litE . stringL . name) nf)+ `appE` listE (map (toObjVar . snd) vars)+ )+ )+ []+ ]+ ]++{- | @ createDataTypeWithObjectComponent SomeName [Foo,Bar]@+ will create this:+ @+ data SomeName = Foo !Object+ | Bar !Object+ deriving (Typeable, Eq, Show)+ @+-}+createDataTypeWithByteStringComponent :: Name -> [Name] -> Q [Dec]+createDataTypeWithByteStringComponent nme cs = do+ tObject <- [t|ByteString|]++ let strictNess = (Bang NoSourceUnpackedness SourceStrict, tObject)++ pure+ [ dataD+ []+ nme+ []+ (map (\n -> NormalC n [strictNess]) cs)+ (mkName <$> ["Typeable", "Eq", "Show", "Generic"])+ , instanceD [] (AppT (ConT (mkName "NFData")) (ConT nme)) []+ ]++{- | If the first parameter is @mkName NeovimException@, this function will+ generate @instance Exception NeovimException@.+-}+exceptionInstance :: Name -> Q [Dec]+exceptionInstance exceptionName = do+ tException <- [t|Exception|]+ pure [instanceD [] (tException `AppT` ConT exceptionName) []]++{- | @customTypeInstance Foo [(Bar, 1), (Quz, 2)]@+ will create this:+ @+ instance Serializable Foo where+ toObject (Bar bs) = ObjectExt 1 bs+ toObject (Quz bs) = ObjectExt 2 bs+ fromObject (ObjectExt 1 bs) = return $ Bar bs+ fromObject (ObjectExt 2 bs) = return $ Quz bs+ fromObject o = Left $ "Object is not convertible to: Foo Received: " <> show o+ @+-}+customTypeInstance :: Name -> [(Name, Int64)] -> Q [Dec]+customTypeInstance typeName nis = do+ let fromObjectClause :: Name -> Int64 -> Q Clause+ fromObjectClause n i = do+ bs <- newName "bs"+ let objectExtMatch =+ conP+ (mkName "ObjectExt")+ [(LitP . integerL . fromIntegral) i, VarP bs]+ clause+ [pure objectExtMatch]+ (normalB [|return $ $(conE n) $(varE bs)|])+ []+ fromObjectErrorClause :: Q Clause+ fromObjectErrorClause = do+ o <- newName "o"+ let n = nameBase typeName+ clause+ [varP o]+ ( normalB+ [|+ throwError $+ pretty "Object is not convertible to:"+ <+> viaShow n+ <+> pretty "Received:"+ <+> viaShow $(varE o)+ |]+ )+ []++ toObjectClause :: Name -> Int64 -> Q Clause+ toObjectClause n i = do+ bs <- newName "bs"+ clause+ [pure (conP n [VarP bs])]+ (normalB [|ObjectExt $((litE . integerL . fromIntegral) i) $(varE bs)|])+ []++ tNvimObject <- [t|NvimObject|]+ fToObject <- funD (mkName "toObject") $ map (uncurry toObjectClause) nis+ fFromObject <- funD (mkName "fromObject") $ map (uncurry fromObjectClause) nis <> [fromObjectErrorClause]+ pure [instanceD [] (tNvimObject `AppT` ConT typeName) [fToObject, fFromObject]]++{- | Define an exported function by providing a custom name and referencing the+ function you want to export.++ Note that the name must start with an upper case letter.++ Example: @ $(function \"MyExportedFunction\" 'myDefinedFunction) 'Sync' @+-}+function :: String -> Name -> Q Exp+function [] _ = fail "Empty names are not allowed for exported functions."+function customName@(c : _) functionName+ | (not . isUpper) c = error $ "Custom function name must start with a capital letter: " <> show customName+ | otherwise = do+ (_, fun) <- functionImplementation functionName+ [|\funOpts -> EF (Function (F (T.pack $(litE (StringL customName)))) funOpts, $(return fun))|]++uppercaseFirstCharacter :: Name -> String+uppercaseFirstCharacter name = case nameBase name of+ "" -> ""+ (c : cs) -> toUpper c : cs++{- | Define an exported function. This function works exactly like 'function',+ but it generates the exported name automatically by converting the first+ letter to upper case.+-}+function' :: Name -> Q Exp+function' functionName = function (uppercaseFirstCharacter functionName) functionName++{- | Simply data type used to identify a string-ish type (e.g. 'String', 'Text',+ 'ByteString' for a value of type.+-}+data ArgType+ = StringyType+ | ListOfStringyTypes+ | Optional ArgType+ | CommandArgumentsType+ | OtherType+ deriving (Eq, Ord, Show, Read)++{- | Given a value of type 'Type', test whether it can be classified according+ to the constructors of "ArgType".+-}+classifyArgType :: Type -> Q ArgType+classifyArgType t = do+ set <- genStringTypesSet+ maybeType <- [t|Maybe|]+ cmdArgsType <- [t|CommandArguments|]+ case t of+ AppT ListT (ConT str)+ | str `Set.member` set ->+ return ListOfStringyTypes+ AppT m mt@(ConT _)+ | m == maybeType ->+ Optional <$> classifyArgType mt+ ConT str+ | str `Set.member` set ->+ return StringyType+ cmd+ | cmd == cmdArgsType ->+ return CommandArgumentsType+ _ -> return OtherType+ where+ genStringTypesSet = do+ types <- sequence [[t|String|], [t|ByteString|], [t|Text|]]+ return $ Set.fromList [n | ConT n <- types]++{- | Similarly to 'function', this function is used to export a command with a+ custom name.++ Note that commands must start with an upper case letter.++ Due to limitations on the side of (neo)vim, commands can only have one of the+ following five signatures, where you can replace 'String' with 'ByteString'+ or 'Text' if you wish:++ * 'CommandArguments' -> 'Neovim' env ()++ * 'CommandArguments' -> 'Maybe' 'String' -> 'Neovim' env ()++ * 'CommandArguments' -> 'String' -> 'Neovim' env ()++ * 'CommandArguments' -> ['String'] -> 'Neovim' env ()++ * 'CommandArguments' -> 'String' -> ['String'] -> 'Neovim' env ()++ Example: @ $(command \"RememberThePrime\" 'someFunction) ['CmdBang'] @++ Note that the list of command options (i.e. the last argument) removes+ duplicate options by means of some internally convenient sorting. You should+ simply not define the same option twice.+-}+command :: String -> Name -> Q Exp+command [] _ = error "Empty names are not allowed for exported commands."+command customFunctionName@(c : _) functionName+ | (not . isUpper) c = error $ "Custom command name must start with a capital letter: " <> show customFunctionName+ | otherwise = do+ (argTypes, fun) <- functionImplementation functionName+ -- See :help :command-nargs for what the result strings mean+ case argTypes of+ (CommandArgumentsType : _) -> return ()+ _ -> error "First argument for a function exported as a command must be CommandArguments!"+ let nargs = case tail argTypes of+ [] -> [|CmdNargs "0"|]+ [StringyType] -> [|CmdNargs "1"|]+ [Optional StringyType] -> [|CmdNargs "?"|]+ [ListOfStringyTypes] -> [|CmdNargs "*"|]+ [StringyType, ListOfStringyTypes] -> [|CmdNargs "+"|]+ _ ->+ error $+ unlines+ [ "Trying to generate a command without compatible types."+ , "Due to a limitation burdened on us by vimL, we can only"+ , "use a limited amount type signatures for commands. See"+ , "the documentation for 'command' for a more thorough"+ , "explanation."+ ]+ [|+ \copts ->+ EF+ ( Command+ (F (T.pack $(litE (StringL customFunctionName))))+ (mkCommandOptions ($(nargs) : copts))+ , $(return fun)+ )+ |]++{- | Define an exported command. This function works exactly like 'command', but+ it generates the command name by converting the first letter to upper case.+-}+command' :: Name -> Q Exp+command' functionName = command (uppercaseFirstCharacter functionName) functionName++{- | This function generates an export for autocmd. Since this is a static+ registration, arguments are not allowed here. You can, of course, define a+ fully applied function and pass it as an argument. If you have to add+ autocmds dynamically, it can be done with 'addAutocmd'.++ Example:++ @+ someFunction :: a -> b -> c -> d -> Neovim r st res+ someFunction = ...++ theFunction :: Neovim r st res+ theFunction = someFunction 1 2 3 4+-}++{- $(autocmd 'theFunction) def+ @++ @def@ is of type 'AutocmdOptions'.++ Note that you have to define @theFunction@ in a different module due to+ the use of Template Haskell.+-}++autocmd :: Name -> Q Exp+autocmd functionName = do+ (as, fun) <- functionImplementation functionName+ case as of+ [] ->+ [|\t sync acmdOpts -> EF (Autocmd t (F (T.pack $(litE (StringL (uppercaseFirstCharacter functionName))))) sync acmdOpts, $(return fun))|]+ _ ->+ error "Autocmd functions have to be fully applied (i.e. they should not take any arguments)."++{- | Generate a function of type @[Object] -> Neovim' Object@ from the argument+ function.++ The function+ @+ add :: Int -> Int -> Int+ add = (+)+ @+ will be converted to+ @+ \args -> case args of+ [x,y] -> case pure add <*> fromObject x <*> fromObject y of+ Left e -> err $ "Wrong type of arguments for add: " ++ e+ Right action -> toObject <$> action+ _ -> err $ "Wrong number of arguments for add: " ++ show xs+ @+-}+functionImplementation :: Name -> Q ([ArgType], Exp)+functionImplementation functionName = do+ fInfo <- reify functionName+ nargs <- mapM classifyArgType $ case fInfo of+ VarI _ functionType _ ->+ determineNumberOfArguments functionType+ x ->+ error $ "Value given to function is (likely) not the name of a function.\n" <> show x++ e <- topLevelCase nargs+ return (nargs, e)+ where+ determineNumberOfArguments :: Type -> [Type]+ determineNumberOfArguments ft = case ft of+ ForallT _ _ t -> determineNumberOfArguments t+ AppT (AppT ArrowT t) r -> t : determineNumberOfArguments r+ _ -> []+ -- \args -> case args of ...+ topLevelCase :: [ArgType] -> Q Exp+ topLevelCase ts = do+ let n = length ts+ minLength = length [() | Optional _ <- reverse ts]+ args <- newName "args"+ lamE+ [varP args]+ ( caseE+ (varE args)+ (zipWith matchingCase [n, n - 1 ..] [0 .. minLength] ++ [errorCase])+ )++ -- _ -> err "Wrong number of arguments"+ errorCase :: Q Match+ errorCase =+ match+ wildP+ ( normalB+ [|+ throw . ErrorMessage . pretty $+ "Wrong number of arguments for function: "+ ++ $(litE (StringL (nameBase functionName)))+ |]+ )+ []++ -- [x,y] -> case pure add <*> fromObject x <*> fromObject y of ...+ matchingCase :: Int -> Int -> Q Match+ matchingCase n x = do+ vars <- mapM (\_ -> Just <$> newName "x") [1 .. n]+ let optVars = replicate x (Nothing :: Maybe Name)+ match+ ((listP . map varP . catMaybes) vars)+ ( normalB+ ( caseE+ ( foldl+ genArgumentCast+ [|pure $(varE functionName)|]+ (zip (vars ++ optVars) (repeat [|(<*>)|]))+ )+ [successfulEvaluation, failedEvaluation]+ )+ )+ []++ genArgumentCast :: Q Exp -> (Maybe Name, Q Exp) -> Q Exp+ genArgumentCast e = \case+ (Just v, op) ->+ infixE (Just e) op (Just [|fromObject $(varE v)|])+ (Nothing, op) ->+ infixE (Just e) op (Just [|pure Nothing|])++ successfulEvaluation :: Q Match+ successfulEvaluation =+ newName "action" >>= \action ->+ match+ (pure (conP (mkName "Right") [VarP action]))+ (normalB [|toObject <$> $(varE action)|])+ []+ failedEvaluation :: Q Match+ failedEvaluation =+ newName "e" >>= \e ->+ match+ (pure (conP (mkName "Left") [VarP e]))+ (normalB [|err ($(varE e) :: Doc AnsiStyle)|])+ []
+ src/Neovim/API/Text.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE NoOverloadedStrings #-}++{- |+Module : Neovim.API.Text+Description : Text based API+Copyright : (c) Sebastian Witte+License : Apache-2.0++Maintainer : woozletoff@gmail.com+Stability : experimental+Portability : GHC+-}+module Neovim.API.Text where++import Neovim.API.TH++$(generateAPI textVectorTypeMap)
+ src/Neovim/Classes.hs view
@@ -0,0 +1,451 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE OverloadedStrings #-}++{- |+Module : Neovim.Classes+Description : Type classes used for conversion of msgpack and Haskell types+Copyright : (c) Sebastian Witte+License : Apache-2.0++Maintainer : woozletoff@gmail.com+Stability : experimental+-}+module Neovim.Classes (+ NvimObject (..),+ Dictionary,+ (+:),+ Generic,+ docToObject,+ docFromObject,+ docToText,+ Doc,+ AnsiStyle,+ Pretty (..),+ (<+>),+ module Data.Int,+ module Data.Word,+ module Control.DeepSeq,+) where++import Neovim.Exceptions (NeovimException (..))++import Control.Applicative+import Control.Arrow ((***))+import Control.DeepSeq+import Control.Monad.Except+import Data.ByteString (ByteString)+import Data.Int (+ Int16,+ Int32,+ Int64,+ Int8,+ )+import qualified Data.Map.Strict as SMap+import Data.MessagePack+import Data.Monoid+import Data.Text as Text (Text)+import Data.Traversable hiding (forM, mapM)+import Data.Vector (Vector)+import qualified Data.Vector as V+import Data.Word (+ Word,+ Word16,+ Word32,+ Word64,+ Word8,+ )+import GHC.Generics (Generic)+import Prettyprinter (+ Doc,+ Pretty (..),+ defaultLayoutOptions,+ layoutPretty,+ viaShow,+ (<+>),+ )+import qualified Prettyprinter as P+import Prettyprinter.Render.Terminal (+ AnsiStyle,+ renderStrict,+ )++import qualified Data.ByteString.UTF8 as UTF8 (fromString, toString)+import Data.Text.Encoding (decodeUtf8, encodeUtf8)+import UnliftIO.Exception (throwIO)++import Prelude++infixr 5 +:++{- | Convenient operator to create a list of 'Object' from normal values.+ @+ values +: of :+ different :+ types :+ can +: be +: combined +: this +: way +: []+ @+-}+(+:) :: (NvimObject o) => o -> [Object] -> [Object]+o +: os = toObject o : os++{- | Convert a 'Doc'-ument to a messagepack 'Object'. This is more a convenience+ method to transport error message from and to neovim. It generally does not+ hold that 'docToObject . docFromObject' = 'id'.+-}+docToObject :: Doc AnsiStyle -> Object+docToObject = ObjectString . encodeUtf8 . docToText++-- | See 'docToObject'.+docFromObject :: Object -> Either (Doc AnsiStyle) (Doc AnsiStyle)+docFromObject o = (P.viaShow :: Text -> Doc AnsiStyle) <$> fromObject o++docToText :: Doc AnsiStyle -> Text+docToText = renderStrict . layoutPretty defaultLayoutOptions++{- | A generic vim dictionary is a simply a map from strings to objects. This+ type alias is sometimes useful as a type annotation especially if the+ OverloadedStrings extension is enabled.+-}+type Dictionary = SMap.Map ByteString Object++{- | Conversion from 'Object' files to Haskell types and back with respect+ to neovim's interpretation.++ The 'NFData' constraint has been added to allow forcing results of function+ evaluations in order to catch exceptions from pure code. This adds more+ stability to the plugin provider and seems to be a cleaner approach.+-}+class NFData o => NvimObject o where+ toObject :: o -> Object++ fromObjectUnsafe :: Object -> o+ fromObjectUnsafe o = case fromObject o of+ Left e ->+ error . show $+ "Not the expected object:"+ <+> P.viaShow o+ <+> P.lparen <> e <> P.rparen+ Right obj -> obj++ fromObject :: Object -> Either (Doc AnsiStyle) o+ fromObject = return . fromObjectUnsafe++ fromObject' :: (MonadIO io) => Object -> io o+ fromObject' = either (throwIO . ErrorMessage) return . fromObject++ {-# MINIMAL toObject, (fromObject | fromObjectUnsafe) #-}++-- Instances for NvimObject {{{1+instance NvimObject () where+ toObject _ = ObjectNil++ fromObject ObjectNil = return ()+ fromObject o = throwError $ "Expected ObjectNil, but got" <+> P.viaShow o++-- We may receive truthy values from neovim, so we should be more forgiving+-- here.+instance NvimObject Bool where+ toObject = ObjectBool++ fromObject (ObjectBool o) = return o+ fromObject (ObjectInt 0) = return False+ fromObject (ObjectUInt 0) = return False+ fromObject ObjectNil = return False+ fromObject (ObjectBinary "0") = return False+ fromObject (ObjectBinary "") = return False+ fromObject (ObjectString "0") = return False+ fromObject (ObjectString "") = return False+ fromObject _ = return True++instance NvimObject Double where+ toObject = ObjectDouble++ fromObject (ObjectDouble o) = return o+ fromObject (ObjectFloat o) = return $ realToFrac o+ fromObject (ObjectInt o) = return $ fromIntegral o+ fromObject (ObjectUInt o) = return $ fromIntegral o+ fromObject o =+ throwError $+ "Expected ObjectDouble, but got"+ <+> viaShow o++instance NvimObject Integer where+ toObject = ObjectInt . fromIntegral++ fromObject (ObjectInt o) = return $ toInteger o+ fromObject (ObjectUInt o) = return $ toInteger o+ fromObject (ObjectDouble o) = return $ round o+ fromObject (ObjectFloat o) = return $ round o+ fromObject o = throwError $ "Expected ObjectInt, but got" <+> viaShow o++instance NvimObject Int64 where+ toObject = ObjectInt++ fromObject (ObjectInt i) = return i+ fromObject (ObjectUInt o) = return $ fromIntegral o+ fromObject (ObjectDouble o) = return $ round o+ fromObject (ObjectFloat o) = return $ round o+ fromObject o = throwError $ "Expected any Integer value, but got" <+> viaShow o++instance NvimObject Int32 where+ toObject = ObjectInt . fromIntegral++ fromObject (ObjectInt i) = return $ fromIntegral i+ fromObject (ObjectUInt i) = return $ fromIntegral i+ fromObject (ObjectDouble o) = return $ round o+ fromObject (ObjectFloat o) = return $ round o+ fromObject o = throwError $ "Expected any Integer value, but got" <+> viaShow o++instance NvimObject Int16 where+ toObject = ObjectInt . fromIntegral++ fromObject (ObjectInt i) = return $ fromIntegral i+ fromObject (ObjectUInt i) = return $ fromIntegral i+ fromObject (ObjectDouble o) = return $ round o+ fromObject (ObjectFloat o) = return $ round o+ fromObject o = throwError $ "Expected any Integer value, but got" <+> viaShow o++instance NvimObject Int8 where+ toObject = ObjectInt . fromIntegral++ fromObject (ObjectInt i) = return $ fromIntegral i+ fromObject (ObjectUInt i) = return $ fromIntegral i+ fromObject (ObjectDouble o) = return $ round o+ fromObject (ObjectFloat o) = return $ round o+ fromObject o = throwError $ "Expected any Integer value, but got" <+> viaShow o++instance NvimObject Word where+ toObject = ObjectInt . fromIntegral++ fromObject (ObjectInt i) = return $ fromIntegral i+ fromObject (ObjectUInt i) = return $ fromIntegral i+ fromObject (ObjectDouble o) = return $ round o+ fromObject (ObjectFloat o) = return $ round o+ fromObject o = throwError $ "Expected any Integer value, but got" <+> viaShow o++instance NvimObject Word64 where+ toObject = ObjectInt . fromIntegral++ fromObject (ObjectInt i) = return $ fromIntegral i+ fromObject (ObjectUInt i) = return $ fromIntegral i+ fromObject (ObjectDouble o) = return $ round o+ fromObject (ObjectFloat o) = return $ round o+ fromObject o = throwError $ "Expected any Integer value, but got" <+> viaShow o++instance NvimObject Word32 where+ toObject = ObjectInt . fromIntegral++ fromObject (ObjectInt i) = return $ fromIntegral i+ fromObject (ObjectUInt i) = return $ fromIntegral i+ fromObject (ObjectDouble o) = return $ round o+ fromObject (ObjectFloat o) = return $ round o+ fromObject o = throwError $ "Expected any Integer value, but got" <+> viaShow o++instance NvimObject Word16 where+ toObject = ObjectInt . fromIntegral++ fromObject (ObjectInt i) = return $ fromIntegral i+ fromObject (ObjectUInt i) = return $ fromIntegral i+ fromObject (ObjectDouble o) = return $ round o+ fromObject (ObjectFloat o) = return $ round o+ fromObject o = throwError $ "Expected any Integer value, but got" <+> viaShow o++instance NvimObject Word8 where+ toObject = ObjectInt . fromIntegral++ fromObject (ObjectInt i) = return $ fromIntegral i+ fromObject (ObjectUInt i) = return $ fromIntegral i+ fromObject (ObjectDouble o) = return $ round o+ fromObject (ObjectFloat o) = return $ round o+ fromObject o = throwError $ "Expected any Integer value, but got" <+> viaShow o++instance NvimObject Int where+ toObject = ObjectInt . fromIntegral++ fromObject (ObjectInt i) = return $ fromIntegral i+ fromObject (ObjectUInt i) = return $ fromIntegral i+ fromObject (ObjectDouble o) = return $ round o+ fromObject (ObjectFloat o) = return $ round o+ fromObject o = throwError $ "Expected any Integer value, but got" <+> viaShow o++instance {-# OVERLAPPING #-} NvimObject [Char] where+ toObject = ObjectBinary . UTF8.fromString++ fromObject (ObjectBinary o) = return $ UTF8.toString o+ fromObject (ObjectString o) = return $ UTF8.toString o+ fromObject o = throwError $ "Expected ObjectString, but got" <+> viaShow o++instance {-# OVERLAPPABLE #-} NvimObject o => NvimObject [o] where+ toObject = ObjectArray . map toObject++ fromObject (ObjectArray os) = mapM fromObject os+ fromObject o = throwError $ "Expected ObjectArray, but got" <+> viaShow o++instance NvimObject o => NvimObject (Maybe o) where+ toObject = maybe ObjectNil toObject++ fromObject ObjectNil = return Nothing+ fromObject o = either throwError (return . Just) $ fromObject o++instance NvimObject o => NvimObject (Vector o) where+ toObject = ObjectArray . V.toList . V.map toObject++ fromObject (ObjectArray os) = V.fromList <$> mapM fromObject os+ fromObject o = throwError $ "Expected ObjectArray, but got" <+> viaShow o++-- | Right-biased instance for toObject.+instance (NvimObject l, NvimObject r) => NvimObject (Either l r) where+ toObject = either toObject toObject++ fromObject o = case fromObject o of+ Right r ->+ return $ Right r+ Left e1 -> case fromObject o of+ Right l ->+ return $ Left l+ Left e2 ->+ throwError $ e1 <+> "--" <+> e2++instance+ (Ord key, NvimObject key, NvimObject val) =>+ NvimObject (SMap.Map key val)+ where+ toObject =+ ObjectMap+ . SMap.fromList+ . map (toObject *** toObject)+ . SMap.toList++ fromObject (ObjectMap om) =+ SMap.fromList+ <$> ( traverse+ ( uncurry (liftA2 (,))+ . (fromObject *** fromObject)+ )+ . SMap.toList+ )+ om+ fromObject o = throwError $ "Expected ObjectMap, but got" <+> viaShow o++instance NvimObject Text where+ toObject = ObjectBinary . encodeUtf8++ fromObject (ObjectBinary o) = return $ decodeUtf8 o+ fromObject (ObjectString o) = return $ decodeUtf8 o+ fromObject o = throwError $ "Expected ObjectBinary, but got" <+> viaShow o++instance NvimObject ByteString where+ toObject = ObjectBinary++ fromObject (ObjectBinary o) = return o+ fromObject (ObjectString o) = return o+ fromObject o = throwError $ "Expected ObjectBinary, but got" <+> viaShow o++instance NvimObject Object where+ toObject = id++ fromObject = return+ fromObjectUnsafe = id++-- By the magic of vim, i will create these.+instance (NvimObject o1, NvimObject o2) => NvimObject (o1, o2) where+ toObject (o1, o2) = ObjectArray $ [toObject o1, toObject o2]++ fromObject (ObjectArray [o1, o2]) =+ (,)+ <$> fromObject o1+ <*> fromObject o2+ fromObject o = throwError $ "Expected ObjectArray, but got" <+> viaShow o++instance (NvimObject o1, NvimObject o2, NvimObject o3) => NvimObject (o1, o2, o3) where+ toObject (o1, o2, o3) = ObjectArray $ [toObject o1, toObject o2, toObject o3]++ fromObject (ObjectArray [o1, o2, o3]) =+ (,,)+ <$> fromObject o1+ <*> fromObject o2+ <*> fromObject o3+ fromObject o = throwError $ "Expected ObjectArray, but got" <+> viaShow o++instance (NvimObject o1, NvimObject o2, NvimObject o3, NvimObject o4) => NvimObject (o1, o2, o3, o4) where+ toObject (o1, o2, o3, o4) = ObjectArray [toObject o1, toObject o2, toObject o3, toObject o4]++ fromObject (ObjectArray [o1, o2, o3, o4]) =+ (,,,)+ <$> fromObject o1+ <*> fromObject o2+ <*> fromObject o3+ <*> fromObject o4+ fromObject o = throwError $ "Expected ObjectArray, but got" <+> viaShow o++instance (NvimObject o1, NvimObject o2, NvimObject o3, NvimObject o4, NvimObject o5) => NvimObject (o1, o2, o3, o4, o5) where+ toObject (o1, o2, o3, o4, o5) = ObjectArray [toObject o1, toObject o2, toObject o3, toObject o4, toObject o5]++ fromObject (ObjectArray [o1, o2, o3, o4, o5]) =+ (,,,,)+ <$> fromObject o1+ <*> fromObject o2+ <*> fromObject o3+ <*> fromObject o4+ <*> fromObject o5+ fromObject o = throwError $ "Expected ObjectArray, but got" <+> viaShow o++instance (NvimObject o1, NvimObject o2, NvimObject o3, NvimObject o4, NvimObject o5, NvimObject o6) => NvimObject (o1, o2, o3, o4, o5, o6) where+ toObject (o1, o2, o3, o4, o5, o6) = ObjectArray [toObject o1, toObject o2, toObject o3, toObject o4, toObject o5, toObject o6]++ fromObject (ObjectArray [o1, o2, o3, o4, o5, o6]) =+ (,,,,,)+ <$> fromObject o1+ <*> fromObject o2+ <*> fromObject o3+ <*> fromObject o4+ <*> fromObject o5+ <*> fromObject o6+ fromObject o = throwError $ "Expected ObjectArray, but got" <+> viaShow o++instance (NvimObject o1, NvimObject o2, NvimObject o3, NvimObject o4, NvimObject o5, NvimObject o6, NvimObject o7) => NvimObject (o1, o2, o3, o4, o5, o6, o7) where+ toObject (o1, o2, o3, o4, o5, o6, o7) = ObjectArray [toObject o1, toObject o2, toObject o3, toObject o4, toObject o5, toObject o6, toObject o7]++ fromObject (ObjectArray [o1, o2, o3, o4, o5, o6, o7]) =+ (,,,,,,)+ <$> fromObject o1+ <*> fromObject o2+ <*> fromObject o3+ <*> fromObject o4+ <*> fromObject o5+ <*> fromObject o6+ <*> fromObject o7+ fromObject o = throwError $ "Expected ObjectArray, but got" <+> viaShow o++instance (NvimObject o1, NvimObject o2, NvimObject o3, NvimObject o4, NvimObject o5, NvimObject o6, NvimObject o7, NvimObject o8) => NvimObject (o1, o2, o3, o4, o5, o6, o7, o8) where+ toObject (o1, o2, o3, o4, o5, o6, o7, o8) = ObjectArray $ [toObject o1, toObject o2, toObject o3, toObject o4, toObject o5, toObject o6, toObject o7, toObject o8]++ fromObject (ObjectArray [o1, o2, o3, o4, o5, o6, o7, o8]) =+ (,,,,,,,)+ <$> fromObject o1+ <*> fromObject o2+ <*> fromObject o3+ <*> fromObject o4+ <*> fromObject o5+ <*> fromObject o6+ <*> fromObject o7+ <*> fromObject o8+ fromObject o = throwError $ "Expected ObjectArray, but got" <+> viaShow o++instance (NvimObject o1, NvimObject o2, NvimObject o3, NvimObject o4, NvimObject o5, NvimObject o6, NvimObject o7, NvimObject o8, NvimObject o9) => NvimObject (o1, o2, o3, o4, o5, o6, o7, o8, o9) where+ toObject (o1, o2, o3, o4, o5, o6, o7, o8, o9) = ObjectArray $ [toObject o1, toObject o2, toObject o3, toObject o4, toObject o5, toObject o6, toObject o7, toObject o8, toObject o9]++ fromObject (ObjectArray [o1, o2, o3, o4, o5, o6, o7, o8, o9]) =+ (,,,,,,,,)+ <$> fromObject o1+ <*> fromObject o2+ <*> fromObject o3+ <*> fromObject o4+ <*> fromObject o5+ <*> fromObject o6+ <*> fromObject o7+ <*> fromObject o8+ <*> fromObject o9+ fromObject o = throwError $ "Expected ObjectArray, but got" <+> viaShow o++-- 1}}}
+ src/Neovim/Compat/Megaparsec.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE CPP #-}+module Neovim.Compat.Megaparsec+ ( Parser+ , module X+#if MIN_VERSION_megaparsec(7,0,0)+ , anyChar+#endif+ ) where+++import Text.Megaparsec as X++#if MIN_VERSION_megaparsec(6,0,0)++import Data.Void+import Text.Megaparsec.Char as X++type Parser = Parsec Void String++#else++import Text.Megaparsec.String as X++#endif++#if MIN_VERSION_megaparsec(7,0,0)+anyChar :: Parser Char+anyChar = anySingle+#endif+
+ src/Neovim/Config.hs view
@@ -0,0 +1,31 @@+{- |+Module : Neovim.Config+Description : The user editable and compilable configuration+Copyright : (c) Sebastian Witte+License : Apache-2.0++Maintainer : woozletoff@gmail.com+Stability : experimental+-}+module Neovim.Config (+ NeovimConfig (..),+ module System.Log,+) where++import Neovim.Context (Neovim)+import Neovim.Plugin.Internal (NeovimPlugin)++import System.Log (Priority (..))++{- | This data type contains information about the configuration of neovim. See+ the fields' documentation for what you possibly want to change. Also, the+ tutorial in the "Neovim" module should get you started.+-}+data NeovimConfig = Config+ { -- | The list of plugins. The IO type inside the list allows the plugin+ -- author to run some arbitrary startup code before creating a value of+ -- type 'NeovimPlugin'.+ plugins :: [Neovim () NeovimPlugin]+ , -- | Set the general logging options.+ logOptions :: Maybe (FilePath, Priority)+ }
+ src/Neovim/Context.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE LambdaCase #-}+{- |+Module : Neovim.Context+Description : The Neovim context+Copyright : (c) Sebastian Witte+License : Apache-2.0++Maintainer : woozletoff@gmail.com+Stability : experimental+-}+module Neovim.Context (+ newUniqueFunctionName,+ Neovim,+ NeovimException (..),+ exceptionToDoc,+ FunctionMap,+ FunctionMapEntry,+ mkFunctionMap,+ runNeovim,+ err,+ errOnInvalidResult,+ restart,+ quit,+ subscribe,+ unsubscribe,+ ask,+ asks,+ get,+ gets,+ put,+ modify,+ Doc,+ AnsiStyle,+ docToText,+ throwError,+ module Control.Monad.IO.Class,+) where++import Neovim.Classes+import Neovim.Context.Internal (+ FunctionMap,+ FunctionMapEntry,+ Neovim,+ mkFunctionMap,+ newUniqueFunctionName,+ runNeovim,+ subscribe,+ unsubscribe,+ )+import Neovim.Exceptions (NeovimException (..), exceptionToDoc)++import qualified Neovim.Context.Internal as Internal++import Control.Concurrent (putMVar)+import Control.Exception+import Control.Monad.Except+import Control.Monad.IO.Class+import Control.Monad.Reader+import Control.Monad.State+import Data.MessagePack (Object)++-- | @'throw'@ specialized to a 'Pretty' value.+err :: Doc AnsiStyle -> Neovim env a+err = throw . ErrorMessage++errOnInvalidResult ::+ (NvimObject o) =>+ Neovim env (Either NeovimException Object) ->+ Neovim env o+errOnInvalidResult a =+ a >>= \case+ Left o ->+ (err . exceptionToDoc) o+ Right o -> case fromObject o of+ Left e ->+ err e+ Right x ->+ return x++-- | Initiate a restart of the plugin provider.+restart :: Neovim env ()+restart = liftIO . flip putMVar Internal.Restart =<< Internal.asks' Internal.transitionTo++-- | Initiate the termination of the plugin provider.+quit :: Neovim env ()+quit = liftIO . flip putMVar Internal.Quit =<< Internal.asks' Internal.transitionTo
+ src/Neovim/Context/Internal.hs view
@@ -0,0 +1,347 @@+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}++{- |+Module : Neovim.Context.Internal+Description : Abstract description of the plugin provider's internal context+Copyright : (c) Sebastian Witte+License : Apache-2.0++Maintainer : woozletoff@gmail.com+Stability : experimental+Portability : GHC++To shorten function and data type names, import this qualfied as @Internal@.+-}+module Neovim.Context.Internal where++import Neovim.Classes (+ AnsiStyle,+ Doc,+ NFData,+ Pretty (pretty),+ deepseq,+ )+import Neovim.Exceptions (+ NeovimException (..),+ exceptionToDoc,+ )+import Neovim.Plugin.Classes (+ FunctionName (..),+ FunctionalityDescription,+ HasFunctionName (nvimMethod),+ NeovimEventId (..),+ NvimMethod,+ Subscription (..),+ SubscriptionId (..),+ )+import Neovim.Plugin.IPC (SomeMessage)++import Data.Map (Map)+import qualified Data.Map as Map+import Data.MessagePack (Object)+import Data.Monoid (Ap (Ap))+import Data.Text (Text, pack)+import System.Log.Logger (errorM)+import UnliftIO (+ Exception (fromException),+ Handler (..),+ MVar,+ MonadIO (..),+ MonadUnliftIO,+ SomeException,+ TMVar,+ TQueue,+ TVar,+ atomically,+ catches,+ modifyTVar',+ newEmptyMVar,+ newEmptyTMVarIO,+ newTMVarIO,+ newTQueueIO,+ newTVarIO,+ putTMVar,+ readTVar,+ takeTMVar,+ throwIO,+ try,+ )++import Prettyprinter (viaShow)++import Conduit (MonadThrow)+import Control.Exception (+ ArithException,+ ArrayException,+ ErrorCall,+ PatternMatchFail,+ )+import qualified Control.Monad.Fail as Fail+import Control.Monad.Reader (+ MonadReader (ask, local),+ ReaderT (..),+ asks,+ void,+ )+import Prelude++{- | This is the environment in which all plugins are initially started.++ Functions have to run in this transformer stack to communicate with neovim.+ If parts of your own functions dont need to communicate with neovim, it is+ good practice to factor them out. This allows you to write tests and spot+ errors easier. Essentially, you should treat this similar to 'IO' in general+ haskell programs.+-}+newtype Neovim env a = Neovim+ {unNeovim :: ReaderT (Config env) IO a}+ deriving newtype (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadUnliftIO)+ deriving (Semigroup, Monoid) via (Ap (Neovim env) a)++-- | User facing instance declaration for the reader state.+instance MonadReader env (Neovim env) where+ ask = Neovim $ asks customConfig+ local f (Neovim a) = do+ r <- Neovim ask+ liftIO $ runReaderT a (r{customConfig = f (customConfig r)})++instance Fail.MonadFail (Neovim env) where+ fail = throwIO . ErrorMessage . pretty++-- | Same as 'ask' for the 'InternalConfig'.+ask' :: Neovim env (Config env)+ask' = Neovim ask++-- | Same as 'asks' for the 'InternalConfig'.+asks' :: (Config env -> a) -> Neovim env a+asks' = Neovim . asks++exceptionHandlers :: [Handler IO (Either (Doc ann) a)]+exceptionHandlers =+ [ Handler $ \(_ :: ArithException) -> ret "ArithException (e.g. division by 0)"+ , Handler $ \(_ :: ArrayException) -> ret "ArrayException"+ , Handler $ \(_ :: ErrorCall) -> ret "ErrorCall (e.g. call of undefined or error"+ , Handler $ \(_ :: PatternMatchFail) -> ret "Pattern match failure"+ , Handler $ \(_ :: SomeException) -> ret "Unhandled exception"+ ]+ where+ ret = return . Left++-- | Initialize a 'Neovim' context by supplying an 'InternalEnvironment'.+runNeovim ::+ NFData a =>+ Config env ->+ Neovim env a ->+ IO (Either (Doc AnsiStyle) a)+runNeovim = runNeovimInternal (\a -> a `deepseq` return a)++runNeovimInternal ::+ (a -> IO a) ->+ Config env ->+ Neovim env a ->+ IO (Either (Doc AnsiStyle) a)+runNeovimInternal f r (Neovim a) =+ (try . runReaderT a) r >>= \case+ Left e -> case fromException e of+ Just e' ->+ return . Left . exceptionToDoc $ (e' :: NeovimException)+ Nothing -> do+ liftIO . errorM "Context" $ "Converting Exception to Error message: " ++ show e+ (return . Left . viaShow) e+ Right res ->+ (Right <$> f res) `catches` exceptionHandlers++{- | Create a new unique function name. To prevent possible name clashes, digits+ are stripped from the given suffix.+-}+newUniqueFunctionName :: Neovim env FunctionName+newUniqueFunctionName = do+ tu <- asks' uniqueCounter+ -- reverseing the integer string should distribute the first character more+ -- evently and hence cause faster termination for comparisons.+ fmap (F . pack . reverse . show) . liftIO . atomically $ do+ u <- readTVar tu+ modifyTVar' tu succ+ return u++{- | This data type is used to dispatch a remote function call to the appopriate+ recipient.+-}+newtype FunctionType+ = -- | 'Stateful' functions are handled within a special thread, the 'TQueue'+ -- is the communication endpoint for the arguments we have to pass.+ Stateful (TQueue SomeMessage)++instance Pretty FunctionType where+ pretty = \case+ Stateful _ -> "\\os -> Neovim env o"++-- | Type of the values stored in the function map.+type FunctionMapEntry = (FunctionalityDescription, FunctionType)++{- | A function map is a map containing the names of functions as keys and some+ context dependent value which contains all the necessary information to+ execute that function in the intended way.++ This type is only used internally and handles two distinct cases. One case+ is a direct function call, wich is simply a function that accepts a list of+ 'Object' values and returns a result in the 'Neovim' context. The second+ case is calling a function that has a persistent state. This is mediated to+ a thread that reads from a 'TQueue'. (NB: persistent currently means, that+ state is stored for as long as the plugin provider is running and not+ restarted.)+-}+type FunctionMap = Map NvimMethod FunctionMapEntry++-- | Create a new function map from the given list of 'FunctionMapEntry' values.+mkFunctionMap :: [FunctionMapEntry] -> FunctionMap+mkFunctionMap = Map.fromList . map (\e -> (nvimMethod (fst e), e))++data Subscriptions = Subscriptions+ { nextSubscriptionId :: SubscriptionId+ , byEventId :: Map NeovimEventId [Subscription]+ }++{- | Subscribe to an event. When the event is received, the given callback function+ is run. It is usually necessary to call the appropriate API function in order for+ /neovim/ to send the notifications to /nvim-hs/. The returned subscription can be+ used to 'unsubscribe'.+-}+subscribe :: Text -> ([Object] -> Neovim env ()) -> Neovim env Subscription+subscribe event action = do+ let eventId = NeovimEventId event+ cfg <- ask'+ let subscriptions' = subscriptions cfg+ atomically $ do+ s <- takeTMVar subscriptions'+ let subscriptionId = nextSubscriptionId s+ let newSubscription =+ Subscription+ { subId = subscriptionId+ , subEventId = eventId+ , subAction = void . runNeovim cfg . action+ }+ putTMVar+ subscriptions'+ s+ { nextSubscriptionId = succ subscriptionId+ , byEventId = Map.insertWith (<>) eventId [newSubscription] (byEventId s)+ }+ pure newSubscription++-- | Remove the subscription that has been returned by 'subscribe'.+unsubscribe :: Subscription -> Neovim env ()+unsubscribe subscription = do+ subscriptions' <- asks' subscriptions+ void . atomically $ do+ s <- takeTMVar subscriptions'+ let eventId = subEventId subscription+ deleteSubscription = Just . filter ((/= subId subscription) . subId)+ putTMVar+ subscriptions'+ s+ { byEventId = Map.update deleteSubscription eventId (byEventId s)+ }++{- | A wrapper for a reader value that contains extra fields required to+ communicate with the messagepack-rpc components and provide necessary data to+ provide other globally available operations.++ Note that you most probably do not want to change the fields prefixed with an+ underscore.+-}+data Config env = Config+ -- Global settings; initialized once+ { eventQueue :: TQueue SomeMessage+ -- ^ A queue of messages that the event handler will propagate to+ -- appropriate threads and handlers.+ , transitionTo :: MVar StateTransition+ -- ^ The main thread will wait for this 'MVar' to be filled with a value+ -- and then perform an action appropriate for the value of type+ -- 'StateTransition'.+ , providerName :: TMVar (Either String Int)+ -- ^ Since nvim-hs must have its "Neovim.RPC.SocketReader" and+ -- "Neovim.RPC.EventHandler" running to determine the actual channel id+ -- (i.e. the 'Int' value here) this field can only be set properly later.+ -- Hence, the value of this field is put in an 'TMVar'.+ -- Name that is used to identify this provider. Assigning such a name is+ -- done in the neovim config (e.g. ~\/.nvim\/nvimrc).+ , uniqueCounter :: TVar Integer+ -- ^ This 'TVar' is used to generate uniqe function names on the side of+ -- /nvim-hs/. This is useful if you don't want to overwrite existing+ -- functions or if you create autocmd functions.+ , globalFunctionMap :: TMVar FunctionMap+ -- ^ This map is used to dispatch received messagepack function calls to+ -- it's appropriate targets.+ , -- Local settings; intialized for each stateful component++ pluginSettings :: Maybe (PluginSettings env)+ -- ^ In a registered functionality this field contains a function (and+ -- possibly some context dependent values) to register new functionality.+ , subscriptions :: TMVar Subscriptions+ -- ^ Plugins can dynamically subscribe to events that neovim sends.+ , customConfig :: env+ -- ^ Plugin author supplyable custom configuration. Queried on the+ -- user-facing side with 'ask' or 'asks'.+ }++{- | Convenient helper to create a new config for the given state and read-only+ config.++ Sets the 'pluginSettings' field to 'Nothing'.+-}+retypeConfig :: env -> Config anotherEnv -> Config env+retypeConfig r cfg = cfg{pluginSettings = Nothing, customConfig = r}++{- | This GADT is used to share information between stateless and stateful+ plugin threads since they work fundamentally in the same way. They both+ contain a function to register some functionality in the plugin provider+ as well as some values which are specific to the one or the other context.+-}+data PluginSettings env where+ StatefulSettings ::+ ( FunctionalityDescription ->+ ([Object] -> Neovim env Object) ->+ TQueue SomeMessage ->+ TVar (Map NvimMethod ([Object] -> Neovim env Object)) ->+ Neovim env (Maybe FunctionMapEntry)+ ) ->+ TQueue SomeMessage ->+ TVar (Map NvimMethod ([Object] -> Neovim env Object)) ->+ PluginSettings env++{- | Create a new 'InternalConfig' object by providing the minimal amount of+ necessary information.++ This function should only be called once per /nvim-hs/ session since the+ arguments are shared across processes.+-}+newConfig :: IO (Maybe String) -> IO env -> IO (Config env)+newConfig ioProviderName r =+ Config+ <$> newTQueueIO+ <*> newEmptyMVar+ <*> (maybe newEmptyTMVarIO (newTMVarIO . Left) =<< ioProviderName)+ <*> newTVarIO 100+ <*> newEmptyTMVarIO+ <*> pure Nothing+ <*> newTMVarIO (Subscriptions (SubscriptionId 1) mempty)+ <*> r++-- | The state that the plugin provider wants to transition to.+data StateTransition+ = -- | Quit the plugin provider.+ Quit+ | -- | Restart the plugin provider.+ Restart+ | -- | The plugin provider failed to start or some other error occured.+ Failure (Doc AnsiStyle)+ | -- | The plugin provider started successfully.+ InitSuccess+ deriving (Show)
+ src/Neovim/Debug.hs view
@@ -0,0 +1,229 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++{- |+Module : Neovim.Debug+Description : Utilities to debug Neovim and nvim-hs functionality+Copyright : (c) Sebastian Witte+License : Apache-2.0++Maintainer : woozletoff@gmail.com+Stability : experimental+Portability : GHC+-}+module Neovim.Debug (+ debug,+ debug',+ NvimHSDebugInstance (..),+ develMain,+ quitDevelMain,+ restartDevelMain,+ printGlobalFunctionMap,+ runNeovim,+ runNeovim',+ module Neovim,+) where++import Neovim+import Neovim.Classes+import Neovim.Context (runNeovim)+import qualified Neovim.Context.Internal as Internal+import Neovim.Log (disableLogger)+import Neovim.Main (+ CommandLineOptions (..),+ runPluginProvider,+ )+import Neovim.RPC.Common (RPCConfig)++import Control.Monad+import qualified Data.Map as Map+import Foreign.Store++import UnliftIO.Async (+ Async,+ async,+ cancel,+ )+import UnliftIO.Concurrent (putMVar, takeMVar)+import UnliftIO.STM++import Prettyprinter (+ nest,+ softline,+ vcat,+ vsep,+ )++import Prelude++{- | Run a 'Neovim' function.++ This function connects to the socket pointed to by the environment variable+ @$NVIM@ and executes the command. It does not register itself+ as a real plugin provider, you can simply call neovim-functions from the+ module "Neovim.API.String" this way.++ Tip: If you run a terminal inside a neovim instance, then this variable is+ automatically set.+-}+debug :: env -> Internal.Neovim env a -> IO (Either (Doc AnsiStyle) a)+debug env a = disableLogger $ do+ runPluginProvider def{envVar = True} Nothing transitionHandler+ where+ transitionHandler tids cfg =+ takeMVar (Internal.transitionTo cfg) >>= \case+ Internal.Failure e ->+ return $ Left e+ Internal.InitSuccess -> do+ res <-+ Internal.runNeovimInternal+ return+ (cfg{Internal.customConfig = env, Internal.pluginSettings = Nothing})+ a++ mapM_ cancel tids+ return res+ _ ->+ return . Left $ "Unexpected transition state."++{- | Run a 'Neovim'' function.++ @+ debug' = debug ()+ @++ See documentation for 'debug'.+-}+debug' :: Internal.Neovim () a -> IO (Either (Doc AnsiStyle) a)+debug' = debug ()++{- | Simple datatype storing neccessary information to start, stop and reload a+ set of plugins. This is passed to most of the functions in this module for+ storing state even when the ghci-session has been reloaded.+-}+data NvimHSDebugInstance = NvimHSDebugInstance+ { threads :: [Async ()]+ , neovimConfig :: NeovimConfig+ , internalConfig :: Internal.Config RPCConfig+ }++{- | This function is intended to be run _once_ in a ghci session that to+ give a REPL based workflow when developing a plugin.++ Note that the dyre-based reload mechanisms, i.e. the+ "Neovim.Plugin.ConfigHelper" plugin, is not started this way.++ To use this in ghci, you simply bind the results to some variables. After+ each reload of ghci, you have to rebind those variables.++ Example:++ @+ λ di <- 'develMain' 'Nothing'++ λ 'runNeovim'' di \$ vim_call_function \"getqflist\" []+ 'Right' ('Right' ('ObjectArray' []))++ λ :r++ λ di <- 'develMain' 'Nothing'+ @++ You can also create a GHCI alias to get rid of most the busy-work:+ @+ :def! x \\_ -> return \":reload\\nJust di <- develMain 'defaultConfig'{ 'plugins' = [ myDebugPlugin ] }\"+ @+-}+develMain ::+ NeovimConfig ->+ IO (Maybe NvimHSDebugInstance)+develMain neovimConfig =+ lookupStore 0 >>= \case+ Nothing -> do+ x <-+ disableLogger $+ runPluginProvider+ def{envVar = True}+ (Just neovimConfig)+ transitionHandler+ void $ newStore x+ return x+ Just x ->+ readStore x+ where+ transitionHandler tids cfg =+ takeMVar (Internal.transitionTo cfg) >>= \case+ Internal.Failure e -> do+ putDoc e+ return Nothing+ Internal.InitSuccess -> do+ transitionHandlerThread <- async $ do+ void $ transitionHandler tids cfg+ return . Just $+ NvimHSDebugInstance+ { threads = transitionHandlerThread : tids+ , neovimConfig = neovimConfig+ , internalConfig = cfg+ }+ Internal.Quit -> do+ lookupStore 0 >>= \case+ Nothing ->+ return ()+ Just x ->+ deleteStore x++ mapM_ cancel tids+ putStrLn "Quit develMain"+ return Nothing+ _ -> do+ putStrLn "Unexpected transition state for develMain."+ return Nothing++-- | Quit a previously started plugin provider.+quitDevelMain :: NvimHSDebugInstance -> IO ()+quitDevelMain NvimHSDebugInstance{internalConfig} =+ putMVar (Internal.transitionTo internalConfig) Internal.Quit++-- | Restart the development plugin provider.+restartDevelMain ::+ NvimHSDebugInstance ->+ IO (Maybe NvimHSDebugInstance)+restartDevelMain di = do+ quitDevelMain di+ develMain (neovimConfig di)++-- | Convenience function to run a stateless 'Neovim' function.+runNeovim' ::+ NFData a =>+ NvimHSDebugInstance ->+ Neovim () a ->+ IO (Either (Doc AnsiStyle) a)+runNeovim' NvimHSDebugInstance{internalConfig} =+ runNeovim (Internal.retypeConfig () internalConfig)++-- | Print the global function map to the console.+printGlobalFunctionMap :: NvimHSDebugInstance -> IO ()+printGlobalFunctionMap NvimHSDebugInstance{internalConfig} = do+ es <-+ fmap Map.toList . atomically $+ readTMVar (Internal.globalFunctionMap internalConfig)+ let header = "Printing global function map:"+ funs =+ map+ ( \(fname, (d, f)) ->+ nest+ 3+ ( pretty fname+ <> softline+ <> "->"+ <> softline+ <> pretty d+ <+> ":"+ <+> pretty f+ )+ )+ es+ putDoc $+ nest 2 $+ vsep [header, vcat funs, mempty]
+ src/Neovim/Exceptions.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++{- |+Module : Neovim.Exceptions+Description : General Exceptions+Copyright : (c) Sebastian Witte+License : Apache-2.0++Maintainer : woozletoff@gmail.com+Stability : experimental+Portability : GHC+-}+module Neovim.Exceptions (+ NeovimException (..),+ exceptionToDoc,+ catchNeovimException,+) where++import Control.Exception (Exception)+import Data.MessagePack (Object (..))+import Data.String (IsString (..))+import Data.Typeable (Typeable)+import Prettyprinter (Doc, viaShow, (<+>))+import Prettyprinter.Render.Terminal (AnsiStyle)+import UnliftIO (MonadUnliftIO, catch)++-- | Exceptions specific to /nvim-hs/.+data NeovimException+ = -- | Simple error message that is passed to neovim. It should currently only+ -- contain one line of text.+ ErrorMessage (Doc AnsiStyle)+ | -- | Error that can be returned by a remote API call. The 'Doc' argument is+ -- the name of the remote function that threw this exception.+ ErrorResult (Doc AnsiStyle) Object+ deriving (Typeable, Show)++instance Exception NeovimException++instance IsString NeovimException where+ fromString = ErrorMessage . fromString++exceptionToDoc :: NeovimException -> Doc AnsiStyle+exceptionToDoc = \case+ ErrorMessage e ->+ "Error message:" <+> e+ ErrorResult fn o ->+ "Function" <+> fn <+> "has thrown an error:" <+> viaShow o++-- | Specialization of 'catch' for 'NeovimException's.+catchNeovimException :: MonadUnliftIO io => io a -> (NeovimException -> io a) -> io a+catchNeovimException action exceptionHandler = action `catch` exceptionHandler
+ src/Neovim/Log.hs view
@@ -0,0 +1,58 @@+{- |+Module : Neovim.Log+Description : Logging utilities and reexports+Copyright : (c) Sebastian Witte+License : Apache-2.0++Maintainer : woozletoff@gmail.com+Stability : experimental+Portability : GHC+-}+module Neovim.Log (+ disableLogger,+ withLogger,+ module System.Log.Logger,+) where++import Control.Exception+import System.Log.Formatter (simpleLogFormatter)+import System.Log.Handler (setFormatter)+import System.Log.Handler.Simple+import System.Log.Logger++-- | Disable logging to stderr.+disableLogger :: IO a -> IO a+disableLogger action = do+ updateGlobalLogger rootLoggerName removeHandler+ action++{- | Initialize the root logger to avoid stderr and set it to log the given+ file instead. Simply wrap the main entry point with this function to+ initialze the logger.++ @+ main = 'withLogger' "\/home\/dude\/nvim.log" 'Debug' \$ do+ 'putStrLn' "Hello, World!"+ @+-}+withLogger :: FilePath -> Priority -> IO a -> IO a+withLogger fp p action =+ bracket+ setupRootLogger+ (\fh -> closeFunc fh (privData fh))+ (const action)+ where+ setupRootLogger = do+ -- We shouldn't log to stderr or stdout as it is not unlikely that our+ -- messagepack communication is handled via those channels.+ disableLogger (return ())+ -- Log to the given file instead+ fh <- fileHandler fp p+ -- Adjust logging format+ let fh' = setFormatter fh (simpleLogFormatter "[$loggername : $prio] $msg")+ -- Adjust the log level as well+ updateGlobalLogger rootLoggerName (setLevel p . addHandler fh')+ -- For good measure, log some debug information+ logM "Neovim.Debug" DEBUG $+ unwords ["Initialized root looger with priority", show p, "and file: ", fp]+ return fh'
+ src/Neovim/Main.hs view
@@ -0,0 +1,242 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++{- |+Module : Neovim.Main+Description : Wrapper for the actual main function+Copyright : (c) Sebastian Witte+License : Apache-2.0++Maintainer : woozletoff@gmail.com+Stability : experimental+-}+module Neovim.Main where++import Neovim.Config (+ NeovimConfig (logOptions, plugins),+ Priority (..),+ )+import qualified Neovim.Context.Internal as Internal+import Neovim.Log (debugM, disableLogger, errorM, withLogger)+import qualified Neovim.Plugin as P+import Neovim.RPC.Common as RPC (+ RPCConfig,+ SocketType (Environment, TCP, UnixSocket),+ createHandle,+ newRPCConfig,+ )+import Neovim.RPC.EventHandler (runEventHandler)+import Neovim.RPC.SocketReader (runSocketReader)+import Neovim.Util (oneLineErrorMessage)++import Control.Monad (void)+import Data.Default (Default (..))+import Options.Applicative (+ Parser,+ ParserInfo,+ auto,+ execParser,+ fullDesc,+ header,+ help,+ helper,+ info,+ long,+ metavar,+ option,+ optional,+ progDesc,+ short,+ strArgument,+ strOption,+ switch,+ )+import System.IO (stdin, stdout)+import UnliftIO (Async, async, putMVar, atomically, putTMVar, takeMVar)+import Control.Applicative ((<|>))++import Prelude++logger :: String+logger = "Neovim.Main"++data CommandLineOptions = Opt+ { providerName :: Maybe String+ , hostPort :: Maybe (String, Int)+ , unix :: Maybe FilePath+ , envVar :: Bool+ , logOpts :: Maybe (FilePath, Priority)+ }++instance Default CommandLineOptions where+ def =+ Opt+ { providerName = Nothing+ , hostPort = Nothing+ , unix = Nothing+ , envVar = False+ , logOpts = Nothing+ }++optParser :: Parser CommandLineOptions+optParser =+ Opt+ <$> optional+ ( strArgument+ ( metavar "NAME"+ <> help+ ( unlines+ [ "Name that associates the plugin provider with neovim."+ , "This option has only an effect if you start nvim-hs"+ , "with rpcstart()/jobstart() and use the factory method approach."+ , "Since it is extremely hard to figure that out inside"+ , "nvim-hs, this option is assumed to used if the input"+ , "and output is tied to standard in and standard out."+ ]+ )+ )+ )+ <*> optional+ ( (,)+ <$> strOption+ ( long "host"+ <> short 'a'+ <> metavar "HOSTNAME"+ <> help "Connect to the specified host. (requires -p)"+ )+ <*> option+ auto+ ( long "port"+ <> short 'p'+ <> metavar "PORT"+ <> help "Connect to the specified port. (requires -a)"+ )+ )+ <*> optional+ ( strOption+ ( long "unix"+ <> short 'u'+ <> help "Connect to the given unix domain socket."+ )+ )+ <*> switch+ ( long "environment"+ <> short 'e'+ <> help "Read connection information from $NVIM."+ )+ <*> optional+ ( (,)+ <$> strOption+ ( long "log-file"+ <> short 'l'+ <> help "File to log to."+ )+ <*> option+ auto+ ( long "log-level"+ <> short 'v'+ <> help ("Log level. Must be one of: " ++ (unwords . map show) logLevels)+ )+ )+ where+ -- [minBound..maxBound] would have been nice here.+ logLevels :: [Priority]+ logLevels = [DEBUG, INFO, NOTICE, WARNING, ERROR, CRITICAL, ALERT, EMERGENCY]++opts :: ParserInfo CommandLineOptions+opts =+ info+ (helper <*> optParser)+ ( fullDesc+ <> header "Start a neovim plugin provider for Haskell plugins."+ <> progDesc "This is still work in progress. Feel free to contribute."+ )++{- | This is essentially the main function for /nvim-hs/, at least if you want+ to use "Config.Dyre" for the configuration.+-}+neovim :: NeovimConfig -> IO ()+neovim = realMain standalone++{- | A 'TransitionHandler' function receives the 'ThreadId's of all running+ threads which have been started by the plugin provider as well as the+ 'Internal.Config' with the custom field set to 'RPCConfig'. These information+ can be used to properly clean up a session and then do something else.+ The transition handler is first called after the plugin provider has started.+-}+type TransitionHandler a = [Async ()] -> Internal.Config RPCConfig -> IO a++{- | This main functions can be used to create a custom executable without+ using the "Config.Dyre" library while still using the /nvim-hs/ specific+ configuration facilities.+-}+realMain ::+ TransitionHandler a ->+ NeovimConfig ->+ IO ()+realMain transitionHandler cfg = do+ os <- execParser opts+ maybe disableLogger (uncurry withLogger) (logOpts os <|> logOptions cfg) $ do+ debugM logger "Starting up neovim haskell plguin provider"+ void $ runPluginProvider os (Just cfg) transitionHandler++-- | Generic main function. Most arguments are optional or have sane defaults.+runPluginProvider ::+ -- | See /nvim-hs/ executables --help function or 'optParser'+ CommandLineOptions ->+ Maybe NeovimConfig ->+ TransitionHandler a ->+ IO a+runPluginProvider os mcfg transitionHandler = case (hostPort os, unix os) of+ (Just (h, p), _) ->+ createHandle (TCP p h) >>= \s -> run s s+ (_, Just fp) ->+ createHandle (UnixSocket fp) >>= \s -> run s s+ _+ | envVar os ->+ createHandle Environment >>= \s -> run s s+ _ ->+ run stdout stdin+ where+ run evHandlerHandle sockreaderHandle = do+ -- The plugins to register depend on the given arguments and may need+ -- special initialization methods.+ let allPlugins = maybe [] plugins mcfg++ conf <- Internal.newConfig (pure (providerName os)) newRPCConfig++ ehTid <-+ async $+ runEventHandler+ evHandlerHandle+ conf{Internal.pluginSettings = Nothing}++ srTid <- async $ runSocketReader sockreaderHandle conf++ let startupConf = Internal.retypeConfig () conf+ P.startPluginThreads startupConf allPlugins >>= \case+ Left e -> do+ errorM logger $ "Error initializing plugins: " <> show (oneLineErrorMessage e)+ putMVar (Internal.transitionTo conf) $ Internal.Failure e+ transitionHandler [ehTid, srTid] conf+ Right (funMapEntries, pluginTids) -> do+ atomically $+ putTMVar+ (Internal.globalFunctionMap conf)+ (Internal.mkFunctionMap funMapEntries)+ putMVar (Internal.transitionTo conf) Internal.InitSuccess+ transitionHandler (srTid : ehTid : pluginTids) conf++standalone :: TransitionHandler ()+standalone threads cfg =+ takeMVar (Internal.transitionTo cfg) >>= \case+ Internal.InitSuccess -> do+ debugM logger "Initialization Successful"+ standalone threads cfg+ Internal.Restart -> do+ errorM logger "Cannot restart"+ standalone threads cfg+ Internal.Failure e ->+ errorM logger . show $ oneLineErrorMessage e+ Internal.Quit ->+ return ()
+ src/Neovim/Plugin.hs view
@@ -0,0 +1,381 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++{- |+Module : Neovim.Plugin+Description : Plugin and functionality registration code+Copyright : (c) Sebastian Witte+License : Apache-2.0++Maintainer : woozletoff@gmail.com+Stability : experimental+Portability : GHC+-}+module Neovim.Plugin (+ startPluginThreads,+ wrapPlugin,+ NeovimPlugin,+ Plugin (..),+ Synchronous (..),+ CommandOption (..),+ addAutocmd,+ registerPlugin,+ registerFunctionality,+ getProviderName,+) where++import Neovim.API.String+ ( nvim_err_writeln, nvim_get_api_info, vim_call_function )+import Neovim.Classes+ ( (<+>),+ Doc,+ AnsiStyle,+ Pretty(pretty),+ NvimObject(toObject, fromObject),+ Dictionary,+ (+:) )+import Neovim.Context+ ( MonadIO(liftIO),+ NeovimException,+ newUniqueFunctionName,+ runNeovim,+ FunctionMapEntry,+ Neovim,+ err )+import Neovim.Context.Internal (+ FunctionType (..),+ runNeovimInternal,+ )+import qualified Neovim.Context.Internal as Internal+import Neovim.Plugin.Classes+ ( HasFunctionName(nvimMethod),+ FunctionName(..),+ NeovimEventId(NeovimEventId),+ Synchronous(..),+ CommandOption(..),+ CommandOptions(getCommandOptions),+ AutocmdOptions(AutocmdOptions),+ FunctionalityDescription(..),+ NvimMethod(..) )+import Neovim.Plugin.IPC.Classes+ ( Notification(Notification),+ Request(Request),+ Message(fromMessage),+ SomeMessage,+ readSomeMessage )+import Neovim.Plugin.Internal+ ( NeovimPlugin(..),+ Plugin(..),+ getDescription,+ getFunction,+ wrapPlugin )+import Neovim.RPC.FunctionCall ( respond )++import Control.Monad (foldM, void)+import Data.Foldable (forM_)+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Either (rights)+import Data.MessagePack ( Object )+import Data.Text (Text)+import Data.Traversable (forM)+import System.Log.Logger ( debugM, errorM )+import UnliftIO.Async (Async, async, race)+import UnliftIO.Concurrent (threadDelay)+import UnliftIO.Exception (SomeException, catch, try)+import UnliftIO.STM+ ( TVar,+ putTMVar,+ takeTMVar,+ tryReadTMVar,+ modifyTVar,+ TQueue,+ atomically,+ newTQueueIO,+ newTVarIO,+ readTVarIO )++import Prelude++logger :: String+logger = "Neovim.Plugin"++startPluginThreads ::+ Internal.Config () ->+ [Neovim () NeovimPlugin] ->+ IO (Either (Doc AnsiStyle) ([FunctionMapEntry], [Async ()]))+startPluginThreads cfg = runNeovimInternal return cfg . foldM go ([], [])+ where+ go ::+ ([FunctionMapEntry], [Async ()]) ->+ Neovim () NeovimPlugin ->+ Neovim () ([FunctionMapEntry], [Async ()])+ go (es, tids) iop = do+ NeovimPlugin p <- iop+ (es', tid) <- registerStatefulFunctionality p++ return (es ++ es', tid : tids)++{- | Call the vimL functions to define a function, command or autocmd on the+ neovim side. Returns 'True' if registration was successful.++ Note that this does not have any effect on the side of /nvim-hs/.+-}+registerWithNeovim :: FunctionalityDescription -> Neovim anyEnv Bool+registerWithNeovim = \case+ func@(Function (F functionName) s) -> do+ pName <- getProviderName+ let (defineFunction, host) =+ either+ (\n -> ("remote#define#FunctionOnHost", toObject n))+ (\c -> ("remote#define#FunctionOnChannel", toObject c))+ pName+ reportError (e :: NeovimException) = do+ liftIO . errorM logger $+ "Failed to register function: " ++ show functionName ++ show e+ return False+ logSuccess = do+ liftIO . debugM logger $+ "Registered function: " ++ show functionName+ return True++ flip catch reportError $ do+ void $+ vim_call_function defineFunction $+ host +: nvimMethodName (nvimMethod func) +: s +: functionName +: (Map.empty :: Dictionary) +: []+ logSuccess+ cmd@(Command (F functionName) copts) -> do+ let sync = case getCommandOptions copts of+ -- This works because CommandOptions are sorted and CmdSync is+ -- the smallest element in the sorting+ (CmdSync s : _) -> s+ _ -> Sync++ pName <- getProviderName+ let (defineFunction, host) =+ either+ (\n -> ("remote#define#CommandOnHost", toObject n))+ (\c -> ("remote#define#CommandOnChannel", toObject c))+ pName+ reportError (e :: NeovimException) = do+ liftIO . errorM logger $+ "Failed to register command: " ++ show functionName ++ show e+ return False+ logSuccess = do+ liftIO . debugM logger $+ "Registered command: " ++ show functionName+ return True+ flip catch reportError $ do+ void $+ vim_call_function defineFunction $+ host +: nvimMethodName (nvimMethod cmd) +: sync +: functionName +: copts +: []+ logSuccess+ Autocmd acmdType (F functionName) sync opts -> do+ pName <- getProviderName+ let (defineFunction, host) =+ either+ (\n -> ("remote#define#AutocmdOnHost", toObject n))+ (\c -> ("remote#define#AutocmdOnChannel", toObject c))+ pName+ reportError (e :: NeovimException) = do+ liftIO . errorM logger $+ "Failed to register autocmd: " ++ show functionName ++ show e+ return False+ logSuccess = do+ liftIO . debugM logger $+ "Registered autocmd: " ++ show functionName+ return True+ flip catch reportError $ do+ void $+ vim_call_function defineFunction $+ host +: functionName +: sync +: acmdType +: opts +: []+ logSuccess++{- | Return or retrive the provider name that the current instance is associated+ with on the neovim side.+-}+getProviderName :: Neovim env (Either String Int)+getProviderName = do+ mp <- Internal.asks' Internal.providerName+ (liftIO . atomically . tryReadTMVar) mp >>= \case+ Just p ->+ return p+ Nothing -> do+ api <- nvim_get_api_info+ case api of+ [] -> err "empty nvim_get_api_info"+ (i : _) -> do+ case fromObject i :: Either (Doc AnsiStyle) Int of+ Left _ ->+ err $+ "Expected an integral value as the first"+ <+> "argument of nvim_get_api_info"+ Right channelId -> do+ liftIO . atomically . putTMVar mp . Right $ fromIntegral channelId+ return . Right $ fromIntegral channelId++registerFunctionality ::+ FunctionalityDescription ->+ ([Object] -> Neovim env Object) ->+ Neovim env (Either (Doc AnsiStyle) FunctionMapEntry)+registerFunctionality d f = do+ Internal.asks' Internal.pluginSettings >>= \case+ Nothing -> do+ let msg = "Cannot register functionality in this context."+ liftIO $ errorM logger msg+ return $ Left $ pretty msg+ Just (Internal.StatefulSettings reg q m) ->+ reg d f q m >>= \case+ Just e -> do+ pure $ Right e+ Nothing ->+ pure $ Left ""++registerInGlobalFunctionMap :: FunctionMapEntry -> Neovim env ()+registerInGlobalFunctionMap e = do+ liftIO . debugM logger $ "Adding function to global function map." ++ show (fst e)+ funMap <- Internal.asks' Internal.globalFunctionMap+ liftIO . atomically $ do+ m <- takeTMVar funMap+ putTMVar funMap $ Map.insert ((nvimMethod . fst) e) e m+ liftIO . debugM logger $ "Added function to global function map." ++ show (fst e)++registerPlugin ::+ (FunctionMapEntry -> Neovim env ()) ->+ FunctionalityDescription ->+ ([Object] -> Neovim env Object) ->+ TQueue SomeMessage ->+ TVar (Map NvimMethod ([Object] -> Neovim env Object)) ->+ Neovim env (Maybe FunctionMapEntry)+registerPlugin reg d f q tm =+ registerWithNeovim d >>= \case+ True -> do+ let n = nvimMethod d+ e = (d, Stateful q)+ liftIO . atomically . modifyTVar tm $ Map.insert n f+ reg e+ return (Just e)+ False ->+ return Nothing++{- | Register an autocmd in the current context. This means that, if you are+ currently in a stateful plugin, the function will be called in the current+ thread and has access to the configuration and state of this thread. .++ Note that the function you pass must be fully applied.+-}+addAutocmd ::+ -- | The event to register to (e.g. BufWritePost)+ Text ->+ Synchronous ->+ AutocmdOptions ->+ -- | Fully applied function to register+ Neovim env () ->+ -- | A 'ReleaseKey' if the registration worked+ Neovim env (Either (Doc AnsiStyle) FunctionMapEntry)+addAutocmd event s opts@AutocmdOptions{} f = do+ n <- newUniqueFunctionName+ registerFunctionality (Autocmd event n s opts) (\_ -> toObject <$> f)++{- | Create a listening thread for events and add update the 'FunctionMap' with+ the corresponding 'TQueue's (i.e. communication channels).+-}+registerStatefulFunctionality ::+ Plugin env ->+ Neovim anyEnv ([FunctionMapEntry], Async ())+registerStatefulFunctionality (Plugin{environment = env, exports = fs}) = do+ messageQueue <- liftIO newTQueueIO+ route <- liftIO $ newTVarIO Map.empty+ subscribers <- liftIO $ newTVarIO []++ cfg <- Internal.ask'++ let startupConfig =+ cfg+ { Internal.customConfig = env+ , Internal.pluginSettings =+ Just $+ Internal.StatefulSettings+ (registerPlugin (\_ -> return ()))+ messageQueue+ route+ }+ res <- liftIO . runNeovimInternal return startupConfig . forM fs $ \f ->+ registerFunctionality (getDescription f) (getFunction f)+ es <- case res of+ Left e -> err e+ Right a -> return $ rights a++ let pluginThreadConfig =+ cfg+ { Internal.customConfig = env+ , Internal.pluginSettings =+ Just $+ Internal.StatefulSettings+ (registerPlugin registerInGlobalFunctionMap)+ messageQueue+ route+ }++ tid <- liftIO . async . void . runNeovim pluginThreadConfig $ do+ listeningThread messageQueue route subscribers++ return (es, tid) -- NB: dropping release functions/keys here+ where+ executeFunction ::+ ([Object] -> Neovim env Object) ->+ [Object] ->+ Neovim env (Either String Object)+ executeFunction f args =+ try (f args) >>= \case+ Left e -> return . Left $ show (e :: SomeException)+ Right res -> return $ Right res++ killAfterSeconds :: Word -> Neovim anyEnv ()+ killAfterSeconds seconds = threadDelay (fromIntegral seconds * 1000 * 1000)++ timeoutAndLog :: Word -> FunctionName -> Neovim anyEnv String+ timeoutAndLog seconds functionName = do+ killAfterSeconds seconds+ return . show $+ pretty functionName <+> "has been aborted after"+ <+> pretty seconds+ <+> "seconds"++ listeningThread ::+ TQueue SomeMessage ->+ TVar (Map NvimMethod ([Object] -> Neovim env Object)) ->+ TVar [Notification -> Neovim env ()] ->+ Neovim env ()+ listeningThread q route subscribers = do+ msg <- readSomeMessage q++ forM_ (fromMessage msg) $ \req@(Request fun@(F methodName) _ args) -> do+ let method = NvimMethod methodName+ route' <- liftIO $ readTVarIO route+ forM_ (Map.lookup method route') $ \f -> do+ respond req . either Left id+ =<< race+ (timeoutAndLog 10 fun)+ (executeFunction f args)++ forM_ (fromMessage msg) $ \notification@(Notification (NeovimEventId methodName) args) -> do+ let method = NvimMethod methodName+ route' <- liftIO $ readTVarIO route+ forM_ (Map.lookup method route') $ \f ->+ void . async $ do+ result <- either Left id <$> race+ (timeoutAndLog 600 (F methodName))+ (executeFunction f args)+ case result of+ Left message ->+ nvim_err_writeln message+ Right _ ->+ return ()++ subscribers' <- liftIO $ readTVarIO subscribers+ forM_ subscribers' $ \subscriber ->+ async $ void $ race (subscriber notification) (killAfterSeconds 10)++ listeningThread q route subscribers
+ src/Neovim/Plugin/Classes.hs view
@@ -0,0 +1,453 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++{- |+Module : Neovim.Plugin.Classes+Description : Classes and data types related to plugins+Copyright : (c) Sebastian Witte+License : Apache-2.0++Maintainer : woozletoff@gmail.com+Stability : experimental+Portability : GHC+-}+module Neovim.Plugin.Classes (+ FunctionalityDescription (..),+ FunctionName (..),+ NeovimEventId (..),+ SubscriptionId (..),+ Subscription (..),+ NvimMethod (..),+ Synchronous (..),+ CommandOption (..),+ CommandOptions,+ RangeSpecification (..),+ CommandArguments (..),+ getCommandOptions,+ mkCommandOptions,+ AutocmdOptions (..),+ HasFunctionName (..),+) where++import Neovim.Classes++import Control.Monad.Error.Class (MonadError (throwError))+import Data.Char (isDigit)+import Data.Default (Default (..))+import Data.List (groupBy, sort)+import qualified Data.Map as Map+import Data.Maybe (catMaybes, mapMaybe)+import Data.MessagePack (Object (..))+import Data.String (IsString (..))+import Data.Text (Text)+import Prettyprinter (cat, comma, lparen, rparen, viaShow)++import Prelude hiding (sequence)++-- | Essentially just a string.+newtype FunctionName = F Text+ deriving (Eq, Ord, Show, Read, Generic)+ deriving (NFData, Pretty) via Text++newtype NeovimEventId = NeovimEventId Text+ deriving (Eq, Ord, Show, Read, Generic)+ deriving (Pretty) via Text+ deriving (NFData) via Text++instance NvimObject NeovimEventId where+ toObject (NeovimEventId e) = toObject e+ fromObject o = NeovimEventId <$> fromObject o++newtype SubscriptionId = SubscriptionId Int64+ deriving (Eq, Ord, Show, Read)+ deriving (Enum) via Int64++data Subscription = Subscription+ { subId :: SubscriptionId+ , subEventId :: NeovimEventId+ , subAction :: [Object] -> IO ()+ }++{- | Functionality specific functional description entries.++ All fields which are directly specified in these constructors are not+ optional, but can partialy be generated via the Template Haskell functions.+ The last field is a data type that contains all relevant options with+ sensible defaults, hence 'def' can be used as an argument.+-}+data FunctionalityDescription+ = -- | Exported function. Callable via @call name(arg1,arg2)@.+ --+ -- * Name of the function (must start with an uppercase letter)+ -- * Option to indicate how neovim should behave when calling this function+ Function FunctionName Synchronous+ | -- | Exported Command. Callable via @:Name arg1 arg2@.+ --+ -- * Name of the command (must start with an uppercase letter)+ -- * Options to configure neovim's behavior for calling the command+ Command FunctionName CommandOptions+ | -- | Exported autocommand. Will call the given function if the type and+ -- filter match.+ --+ -- NB: Since we are registering this on the Haskell side of things, the+ -- number of accepted arguments should be 0.+ --+ -- * Type of the autocmd (e.g. \"BufWritePost\")+ -- * Name for the function to call+ -- * Whether to use rpcrequest or rpcnotify+ -- * Options for the autocmd (use 'def' here if you don't want to change anything)+ Autocmd Text FunctionName Synchronous AutocmdOptions+ deriving (Show, Read, Eq, Ord, Generic)++instance NFData FunctionalityDescription++instance Pretty FunctionalityDescription where+ pretty = \case+ Function fname s ->+ "Function" <+> pretty s <+> pretty fname+ Command fname copts ->+ "Command" <+> pretty copts <+> pretty fname+ Autocmd t fname s aopts ->+ "Autocmd"+ <+> pretty t+ <+> pretty s+ <+> pretty aopts+ <+> pretty fname++{- | This option detemines how neovim should behave when calling some+ functionality on a remote host.+-}+data Synchronous+ = -- | Call the functionality entirely for its side effects and do not wait+ -- for it to finish. Calling a functionality with this flag set is+ -- completely asynchronous and nothing is really expected to happen. This+ -- is why a call like this is called notification on the neovim side of+ -- things.+ Async+ | -- | Call the function and wait for its result. This is only synchronous on+ -- the neovim side. This means that the GUI will (probably) not+ -- allow any user input until a reult is received.+ Sync+ deriving (Show, Read, Eq, Ord, Enum, Generic)++instance NFData Synchronous++instance Pretty Synchronous where+ pretty = \case+ Async -> "async"+ Sync -> "sync"++instance IsString Synchronous where+ fromString = \case+ "sync" -> Sync+ "async" -> Async+ _ -> error "Only \"sync\" and \"async\" are valid string representations"++instance NvimObject Synchronous where+ toObject = \case+ Async -> toObject False+ Sync -> toObject True++ fromObject = \case+ ObjectBool True -> return Sync+ ObjectBool False -> return Async+ ObjectInt 0 -> return Async+ _ -> return Sync++{- | Options for commands.++ Some command can also be described by using the OverloadedString extensions.+ This means that you can write a literal 'String' inside your source file in+ place for a 'CommandOption' value. See the documentation for each value on+ how these strings should look like (Both versions are compile time checked.)+-}+data CommandOption+ = -- | Stringliteral "sync" or "async"+ CmdSync Synchronous+ | -- | Register passed to the command.+ --+ -- Stringliteral: @\"\\\"\"@+ CmdRegister+ | -- | Command takes a specific amount of arguments+ --+ -- Automatically set via template haskell functions. You+ -- really shouldn't use this option yourself unless you have+ -- to.+ CmdNargs String+ | -- | Determines how neovim passes the range.+ --+ -- Stringliterals: \"%\" for 'WholeFile', \",\" for line+ -- and \",123\" for 123 lines.+ CmdRange RangeSpecification+ | -- | Command handles a count. The argument defines the+ -- default count.+ --+ -- Stringliteral: string of numbers (e.g. "132")+ CmdCount Word+ | -- | Command handles a bang+ --+ -- Stringliteral: \"!\"+ CmdBang+ | -- | Verbatim string passed to the @-complete=@ command attribute+ CmdComplete String+ deriving (Eq, Ord, Show, Read, Generic)++instance NFData CommandOption++instance Pretty CommandOption where+ pretty = \case+ CmdSync s ->+ pretty s+ CmdRegister ->+ "\""+ CmdNargs n ->+ pretty n+ CmdRange rs ->+ pretty rs+ CmdCount c ->+ pretty c+ CmdBang ->+ "!"+ CmdComplete cs ->+ pretty cs++instance IsString CommandOption where+ fromString = \case+ "%" -> CmdRange WholeFile+ "\"" -> CmdRegister+ "!" -> CmdBang+ "sync" -> CmdSync Sync+ "async" -> CmdSync Async+ "," -> CmdRange CurrentLine+ ',' : ds | not (null ds) && all isDigit ds -> CmdRange (read ds)+ ds | not (null ds) && all isDigit ds -> CmdCount (read ds)+ _ -> error "Not a valid string for a CommandOptions. Check the docs!"++{- | Newtype wrapper for a list of 'CommandOption'. Any properly constructed+ object of this type is sorted and only contains zero or one object for each+ possible option.+-}+newtype CommandOptions = CommandOptions {getCommandOptions :: [CommandOption]}+ deriving (Eq, Ord, Show, Read, Generic)++instance NFData CommandOptions++instance Pretty CommandOptions where+ pretty (CommandOptions os) =+ cat $ map pretty os++{- | Smart constructor for 'CommandOptions'. This sorts the command options and+ removes duplicate entries for semantically the same thing. Note that the+ smallest option stays for whatever ordering is defined. It is best to simply+ not define the same thing multiple times.+-}+mkCommandOptions :: [CommandOption] -> CommandOptions+mkCommandOptions = CommandOptions . map head . groupBy constructor . sort+ where+ constructor a b = case (a, b) of+ _ | a == b -> True+ -- Only CmdSync and CmdNargs may fail for the equality check,+ -- so we just have to check those.+ (CmdSync _, CmdSync _) -> True+ (CmdRange _, CmdRange _) -> True+ -- Range and conut are mutually recursive.+ -- XXX Actually '-range=N' and '-count=N' are, but the code in+ -- remote#define#CommandOnChannel treats it exclusive as a whole.+ -- (see :h :command-range)+ (CmdRange _, CmdCount _) -> True+ (CmdNargs _, CmdNargs _) -> True+ _ -> False++instance NvimObject CommandOptions where+ toObject (CommandOptions opts) =+ (toObject :: Dictionary -> Object) . Map.fromList $ mapMaybe addOption opts+ where+ addOption = \case+ CmdRange r -> Just ("range", toObject r)+ CmdCount n -> Just ("count", toObject n)+ CmdBang -> Just ("bang", ObjectBinary "")+ CmdRegister -> Just ("register", ObjectBinary "")+ CmdNargs n -> Just ("nargs", toObject n)+ CmdComplete cs -> Just ("complete", toObject cs)+ _ -> Nothing++ fromObject o =+ throwError $+ "Did not expect to receive a CommandOptions object:" <+> viaShow o++-- | Specification of a range that acommand can operate on.+data RangeSpecification+ = -- | The line the cursor is at when the command is invoked.+ CurrentLine+ | -- | Let the command operate on every line of the file.+ WholeFile+ | -- | Let the command operate on each line in the given range.+ RangeCount Int+ deriving (Eq, Ord, Show, Read, Generic)++instance NFData RangeSpecification++instance Pretty RangeSpecification where+ pretty = \case+ CurrentLine ->+ mempty+ WholeFile ->+ "%"+ RangeCount c ->+ pretty c++instance NvimObject RangeSpecification where+ toObject = \case+ CurrentLine -> ObjectBinary ""+ WholeFile -> ObjectBinary "%"+ RangeCount n -> toObject n++ fromObject o =+ throwError $+ "Did not expect to receive a RangeSpecification object:" <+> viaShow o++{- | You can use this type as the first argument for a function which is+ intended to be exported as a command. It holds information about the special+ attributes a command can take.+-}+data CommandArguments = CommandArguments+ { bang :: Maybe Bool+ -- ^ 'Nothing' means that the function was not defined to handle a bang,+ -- otherwise it means that the bang was passed (@'Just' 'True'@) or that it+ -- was not passed when called (@'Just' 'False'@).+ , range :: Maybe (Int, Int)+ -- ^ Range passed from neovim. Only set if 'CmdRange' was used in the export+ -- declaration of the command.+ --+ -- Example:+ --+ -- * @Just (1,12)@+ , count :: Maybe Int+ -- ^ Count passed by neovim. Only set if 'CmdCount' was used in the export+ -- declaration of the command.+ , register :: Maybe String+ -- ^ Register that the command can\/should\/must use.+ }+ deriving (Eq, Ord, Show, Read, Generic)++instance NFData CommandArguments++instance Pretty CommandArguments where+ pretty CommandArguments{..} =+ cat $+ catMaybes+ [ (\b -> if b then "!" else mempty) <$> bang+ , ( \(s, e) ->+ lparen <> pretty s <> comma+ <+> pretty e <> rparen+ )+ <$> range+ , pretty <$> count+ , pretty <$> register+ ]++instance Default CommandArguments where+ def =+ CommandArguments+ { bang = Nothing+ , range = Nothing+ , count = Nothing+ , register = Nothing+ }++-- XXX This instance is used as a bit of a hack, so that I don't have to write+-- special code handling in the code generator and "Neovim.RPC.SocketReader".+instance NvimObject CommandArguments where+ toObject CommandArguments{..} =+ (toObject :: Dictionary -> Object)+ . Map.fromList+ . catMaybes+ $ [ bang >>= \b -> return ("bang", toObject b)+ , range >>= \r -> return ("range", toObject r)+ , count >>= \c -> return ("count", toObject c)+ , register >>= \r -> return ("register", toObject r)+ ]++ fromObject (ObjectMap m) = do+ let l key = mapM fromObject (Map.lookup (ObjectBinary key) m)+ bang <- l "bang"+ range <- l "range"+ count <- l "count"+ register <- l "register"+ return CommandArguments{..}+ fromObject ObjectNil = return def+ fromObject o =+ throwError $+ "Expected a map for CommandArguments object, but got: "+ <+> viaShow o++{- | Options that can be used to register an autocmd. See @:h :autocmd@ or any+ referenced neovim help-page from the fields of this data type.+-}+data AutocmdOptions = AutocmdOptions+ { acmdPattern :: String+ -- ^ Pattern to match on. (default: \"*\")+ , acmdNested :: Bool+ -- ^ Nested autocmd. (default: False)+ --+ -- See @:h autocmd-nested@+ , acmdGroup :: Maybe String+ -- ^ Group in which the autocmd should be registered.+ }+ deriving (Show, Read, Eq, Ord, Generic)++instance NFData AutocmdOptions++instance Pretty AutocmdOptions where+ pretty AutocmdOptions{..} =+ pretty acmdPattern+ <+> if acmdNested+ then "nested"+ else+ "unnested"+ <> maybe mempty (\g -> mempty <+> pretty g) acmdGroup++instance Default AutocmdOptions where+ def =+ AutocmdOptions+ { acmdPattern = "*"+ , acmdNested = False+ , acmdGroup = Nothing+ }++instance NvimObject AutocmdOptions where+ toObject AutocmdOptions{..} =+ (toObject :: Dictionary -> Object) . Map.fromList $+ [ ("pattern", toObject acmdPattern)+ , ("nested", toObject acmdNested)+ ]+ ++ catMaybes+ [ acmdGroup >>= \g -> return ("group", toObject g)+ ]+ fromObject o =+ throwError $+ "Did not expect to receive an AutocmdOptions object: " <+> viaShow o++newtype NvimMethod = NvimMethod {nvimMethodName :: Text}+ deriving (Eq, Ord, Show, Read, Generic)+ deriving (Pretty, NFData) via Text++-- | Conveniennce class to extract a name from some value.+class HasFunctionName a where+ name :: a -> FunctionName+ nvimMethod :: a -> NvimMethod++instance HasFunctionName FunctionalityDescription where+ name = \case+ Function n _ -> n+ Command n _ -> n+ Autocmd _ n _ _ -> n++ nvimMethod = \case+ Function (F n) _ -> NvimMethod $ n <> ":function"+ Command (F n) _ -> NvimMethod $ n <> ":command"+ Autocmd _ (F n) _ _ -> NvimMethod n+
+ src/Neovim/Plugin/IPC.hs view
@@ -0,0 +1,18 @@+{- |+Module : Neovim.Plugin.IPC+Description : Communication between Haskell processes/threads+Copyright : (c) Sebastian Witte+License : Apache-2.0++Maintainer : woozletoff@gmail.com+Stability : experimental++This module reexports publicly available means to communicate between different+plugins (or more generally threads running in the same plugin provider).+-}+module Neovim.Plugin.IPC (+ SomeMessage (..),+ fromMessage,+) where++import Neovim.Plugin.IPC.Classes
+ src/Neovim/Plugin/IPC/Classes.hs view
@@ -0,0 +1,168 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-}++{- |+Module : Neovim.Plugin.IPC.Classes+Description : Classes used for Inter Plugin Communication+Copyright : (c) Sebastian Witte+License : Apache-2.0++Maintainer : woozletoff@gmail.com+Stability : experimental+Portability : GHC+-}+module Neovim.Plugin.IPC.Classes (+ SomeMessage (..),+ Message (..),+ FunctionCall (..),+ Request (..),+ Notification (..),+ writeMessage,+ readSomeMessage,+ UTCTime,+ getCurrentTime,+ module Data.Int,+) where++import Neovim.Classes (+ Generic,+ Int64,+ NFData (..),+ Pretty (pretty),+ deepseq,+ (<+>),+ )+import Neovim.Plugin.Classes (FunctionName, NeovimEventId)++import Data.Data (cast)+import Data.Int (Int64)+import Data.MessagePack (Object)+import Data.Time (UTCTime, formatTime, getCurrentTime)+import Data.Time.Locale.Compat (defaultTimeLocale)+import Prettyprinter (hardline, nest, viaShow)+import UnliftIO (+ MonadIO (..),+ MonadUnliftIO,+ TMVar,+ TQueue,+ Typeable,+ atomically,+ evaluate,+ readTQueue,+ writeTQueue,+ )++import Prelude++{- | Taken from xmonad and based on ideas in /An Extensible Dynamically-Typed+ Hierarchy of Exceptions/, Simon Marlow, 2006.++ User-extensible messages must be put into a value of this type, so that it+ can be sent to other plugins.+-}+data SomeMessage = forall msg. Message msg => SomeMessage msg++{- | This class allows type safe casting of 'SomeMessage' to an actual message.+ The cast is successful if the type you're expecting matches the type in the+ 'SomeMessage' wrapper. This way, you can subscribe to an arbitrary message+ type withouth having to pattern match on the constructors. This also allows+ plugin authors to create their own message types without having to change the+ core code of /nvim-hs/.+-}+class (NFData message, Typeable message) => Message message where+ -- | Try to convert a given message to a value of the message type we are+ -- interested in. Will evaluate to 'Nothing' for any other type.+ fromMessage :: SomeMessage -> Maybe message+ fromMessage (SomeMessage message) = cast message++writeMessage :: (MonadUnliftIO m, Message message) => TQueue SomeMessage -> message -> m ()+writeMessage q message = liftIO $ do+ evaluate (rnf message)+ atomically $ writeTQueue q (SomeMessage message)++readSomeMessage :: MonadIO m => TQueue SomeMessage -> m SomeMessage+readSomeMessage q = liftIO $ atomically (readTQueue q)++-- | Haskell representation of supported Remote Procedure Call messages.+data FunctionCall+ = -- | Method name, parameters, callback, timestamp+ FunctionCall FunctionName [Object] (TMVar (Either Object Object)) UTCTime+ deriving (Typeable, Generic)++instance NFData FunctionCall where+ rnf (FunctionCall f os v t) = f `deepseq` os `deepseq` v `seq` t `deepseq` ()++instance Message FunctionCall++instance Pretty FunctionCall where+ pretty (FunctionCall fname args _ t) =+ nest 2 $+ "Function call for:"+ <+> pretty fname+ <> hardline+ <> "Arguments:"+ <+> viaShow args+ <> hardline+ <> "Timestamp:"+ <+> (viaShow . formatTime defaultTimeLocale "%H:%M:%S (%q)") t++{- | A request is a data type containing the method to call, its arguments and+ an identifier used to map the result to the function that has been called.+-}+data Request = Request+ { -- | Name of the function to call.+ reqMethod :: FunctionName+ , -- | Identifier to map the result to a function call invocation.+ reqId :: !Int64+ , -- | Arguments for the function.+ reqArgs :: [Object]+ }+ deriving (Eq, Ord, Show, Typeable, Generic)++instance NFData Request++instance Message Request++instance Pretty Request where+ pretty Request{..} =+ nest 2 $+ "Request"+ <+> "#"+ <> pretty reqId+ <> hardline+ <> "Method:"+ <+> pretty reqMethod+ <> hardline+ <> "Arguments:"+ <+> viaShow reqArgs++{- | A notification is similar to a 'Request'. It essentially does the same+ thing, but the function is only called for its side effects. This type of+ message is sent by neovim if the caller there does not care about the result+ of the computation.+-}+data Notification = Notification+ { -- | Event name of the notification.+ notEvent :: NeovimEventId+ , -- | Arguments for the function.+ notArgs :: [Object]+ }+ deriving (Eq, Ord, Show, Typeable, Generic)++instance NFData Notification++instance Message Notification++instance Pretty Notification where+ pretty Notification{..} =+ nest 2 $+ "Notification"+ <> hardline+ <> "Event:"+ <+> pretty notEvent+ <> hardline+ <> "Arguments:"+ <+> viaShow notEvent
+ src/Neovim/Plugin/Internal.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE ExistentialQuantification #-}++{- |+Module : Neovim.Plugin.Internal+Description : Split module that can import Neovim.Context without creating import circles+Copyright : (c) Sebastian Witte+License : Apache-2.0++Maintainer : woozletoff@gmail.com+Stability : experimental+Portability : GHC+-}+module Neovim.Plugin.Internal (+ ExportedFunctionality (..),+ getFunction,+ getDescription,+ NeovimPlugin (..),+ Plugin (..),+ wrapPlugin,+) where++import Neovim.Context (Neovim)+import Neovim.Plugin.Classes (+ FunctionalityDescription,+ HasFunctionName (..),+ )++import Data.MessagePack (Object)++{- | This data type is used in the plugin registration to properly register the+ functions.+-}+newtype ExportedFunctionality env+ = EF (FunctionalityDescription, [Object] -> Neovim env Object)++-- | Extract the description of an 'ExportedFunctionality'.+getDescription :: ExportedFunctionality env -> FunctionalityDescription+getDescription (EF (d, _)) = d++-- | Extract the function of an 'ExportedFunctionality'.+getFunction :: ExportedFunctionality env -> [Object] -> Neovim env Object+getFunction (EF (_, f)) = f++instance HasFunctionName (ExportedFunctionality env) where+ name = name . getDescription+ nvimMethod = nvimMethod . getDescription++-- | This data type contains meta information for the plugin manager.+data Plugin env = Plugin+ { environment :: env+ , exports :: [ExportedFunctionality env]+ }++{- | 'Plugin' values are wraped inside this data type via 'wrapPlugin' so that+ we can put plugins in an ordinary list.+-}+data NeovimPlugin = forall env. NeovimPlugin (Plugin env)++{- | Wrap a 'Plugin' in some nice blankets, so that we can put them in a simple+ list.+-}+wrapPlugin :: Applicative m => Plugin env -> m NeovimPlugin+wrapPlugin = pure . NeovimPlugin
+ src/Neovim/Quickfix.hs view
@@ -0,0 +1,212 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++{- |+Module : Neovim.Quickfix+Description : API for interacting with the quickfix list+Copyright : (c) Sebastian Witte+License : Apache-2.0++Maintainer : woozletoff@gmail.com+Stability : experimental+Portability : GHC+-}+module Neovim.Quickfix where++import Neovim.API.String ( vim_call_function )+import Neovim.Classes+ ( Generic,+ NFData,+ (<+>),+ Doc,+ AnsiStyle,+ NvimObject(toObject, fromObject),+ (+:) )+import Neovim.Context ( throwError, Neovim )+++import Control.Monad (void)+import Data.ByteString as BS (ByteString, all, elem)+import qualified Data.Map as Map+import Data.Maybe ( fromMaybe )+import Data.MessagePack ( Object(ObjectBinary, ObjectMap) )+import Prettyprinter (viaShow)+import Prelude++{- | This is a wrapper around neovim's @setqflist()@. @strType@ can be any+ string that you can append to (hence 'Monoid') that is also an instance+ of 'NvimObject'. You can e.g. use the plain old 'String'.+-}+setqflist ::+ (Monoid strType, NvimObject strType) =>+ [QuickfixListItem strType] ->+ QuickfixAction ->+ Neovim env ()+setqflist qs a =+ void $ vim_call_function "setqflist" $ qs +: a +: []++data ColumnNumber+ = VisualColumn Int+ | ByteIndexColumn Int+ | NoColumn+ deriving (Eq, Ord, Show, Generic)++instance NFData ColumnNumber++data SignLocation strType+ = LineNumber Int+ | SearchPattern strType+ deriving (Eq, Ord, Show, Generic)++instance (NFData strType) => NFData (SignLocation strType)++{- | Quickfix list item. The parameter names should mostly conform to those in+ @:h setqflist()@. Some fields are merged to explicitly state mutually+ exclusive elements or some other behavior of the fields.++ see 'quickfixListItem' for creating a value of this type without typing too+ much.+-}+data QuickfixListItem strType = QFItem+ { -- | Since the filename is only used if no buffer can be specified, this+ -- field is a merge of @bufnr@ and @filename@.+ bufOrFile :: Either Int strType+ , -- | Line number or search pattern to locate the error.+ lnumOrPattern :: Either Int strType+ , -- | A tuple of a column number and a boolean indicating which kind of+ -- indexing should be used. 'True' means that the visual column should be+ -- used. 'False' means to use the byte index.+ col :: ColumnNumber+ , -- | Error number.+ nr :: Maybe Int+ , -- | Description of the error.+ text :: strType+ , -- | Type of error.+ errorType :: QuickfixErrorType+ }+ deriving (Eq, Show, Generic)++instance (NFData strType) => NFData (QuickfixListItem strType)++-- | Simple error type enum.+data QuickfixErrorType = Warning | Error+ deriving (Eq, Ord, Show, Read, Enum, Bounded, Generic)++instance NFData QuickfixErrorType++instance NvimObject QuickfixErrorType where+ toObject = \case+ Warning -> ObjectBinary "W"+ Error -> ObjectBinary "E"++ fromObject o = case fromObject o :: Either (Doc AnsiStyle) String of+ Right "W" -> return Warning+ Right "E" -> return Error+ _ -> return Error++{- | Create a 'QuickfixListItem' by providing the minimal amount of arguments+ needed.+-}+quickfixListItem ::+ (Monoid strType) =>+ -- | buffer of file name+ Either Int strType ->+ -- | line number or pattern+ Either Int strType ->+ QuickfixListItem strType+quickfixListItem bufferOrFile lineOrPattern =+ QFItem+ { bufOrFile = bufferOrFile+ , lnumOrPattern = lineOrPattern+ , col = NoColumn+ , nr = Nothing+ , text = mempty+ , errorType = Error+ }++instance+ (Monoid strType, NvimObject strType) =>+ NvimObject (QuickfixListItem strType)+ where+ toObject QFItem{..} =+ (toObject :: Map.Map ByteString Object -> Object) . Map.fromList $+ [ either+ (\b -> ("bufnr", toObject b))+ (\f -> ("filename", toObject f))+ bufOrFile+ , either+ (\l -> ("lnum", toObject l))+ (\p -> ("pattern", toObject p))+ lnumOrPattern+ , ("type", toObject errorType)+ , ("text", toObject text)+ ]+ ++ case col of+ NoColumn -> []+ ByteIndexColumn i -> [("col", toObject i), ("vcol", toObject False)]+ VisualColumn i -> [("col", toObject i), ("vcol", toObject True)]++ fromObject objectMap@(ObjectMap _) = do+ m <- fromObject objectMap+ let l :: NvimObject o => ByteString -> Either (Doc AnsiStyle) o+ l key = case Map.lookup key m of+ Just o -> fromObject o+ Nothing -> throwError $ "Key not found."+ bufOrFile <- case (l "bufnr", l "filename") of+ (Right b, _) -> return $ Left b+ (_, Right f) -> return $ Right f+ _ -> throwError $ "No buffer number or file name inside quickfix list item."+ lnumOrPattern <- case (l "lnum", l "pattern") of+ (Right lnum, _) -> return $ Left lnum+ (_, Right pat) -> return $ Right pat+ _ -> throwError $ "No line number or search pattern inside quickfix list item."+ let l' :: NvimObject o => ByteString -> Either (Doc AnsiStyle) (Maybe o)+ l' key = case Map.lookup key m of+ Just o -> Just <$> fromObject o+ Nothing -> return Nothing+ nr <-+ l' "nr" >>= \case+ Just 0 -> return Nothing+ nr' -> return nr'+ c <- l' "col"+ v <- l' "vcol"+ let col = fromMaybe NoColumn $ do+ c' <- c+ v' <- v+ case (c', v') of+ (0, _) -> return NoColumn+ (_, True) -> return $ VisualColumn c'+ (_, False) -> return $ ByteIndexColumn c'+ text <- fromMaybe mempty <$> l' "text"+ errorType <- fromMaybe Error <$> l' "type"+ return QFItem{..}+ fromObject o =+ throwError $+ "Could not deserialize QuickfixListItem,"+ <+> "expected a map but received:"+ <+> viaShow o++data QuickfixAction+ = -- | Add items to the current list (or create a new one if none exists).+ Append+ | -- | Replace current list (or create a new one if none exists).+ Replace+ | -- | Create a new list.+ New+ deriving (Eq, Ord, Enum, Bounded, Show, Generic)++instance NFData QuickfixAction++instance NvimObject QuickfixAction where+ toObject = \case+ Append -> ObjectBinary "a"+ Replace -> ObjectBinary "r"+ New -> ObjectBinary ""++ fromObject o = case fromObject o of+ Right "a" -> return Append+ Right "r" -> return Replace+ Right s | BS.all (`BS.elem` " \t\n\r") s -> return New+ _ -> Left "Could not convert to QuickfixAction"
+ src/Neovim/RPC/Classes.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++{- |+Module : Neovim.RPC.Classes+Description : Data types and classes for the RPC components+Copyright : (c) Sebastian Witte+License : Apache-2.0++Maintainer : woozletoff@gmail.com+Stability : experimental+Portability : GHC++Import this module qualified as @MsgpackRPC@+-}+module Neovim.RPC.Classes (+ Message (..),+) where++import Neovim.Classes+import Neovim.Plugin.Classes (FunctionName (..), NeovimEventId (..))+import qualified Neovim.Plugin.IPC.Classes as IPC++import Control.Applicative+import Control.Monad.Error.Class+import Data.Data (Typeable)+import Data.MessagePack (Object (..))+import Prettyprinter (hardline, nest, viaShow)++import Prelude++{- | See https://github.com/msgpack-rpc/msgpack-rpc/blob/master/spec.md for+ details about the msgpack rpc specification.+-}+data Message+ = -- | Request in the sense of the msgpack rpc specification+ --+ -- Parameters+ -- * Message identifier that has to be put in the response to this request+ -- * Function name+ -- * Function arguments+ Request IPC.Request+ | -- | Response in the sense of the msgpack rpc specifcation+ --+ -- Parameters+ -- * Mesage identifier which matches a request+ -- * 'Either' an error 'Object' or a result 'Object'+ Response !Int64 (Either Object Object)+ | -- | Notification in the sense of the msgpack rpc specification+ Notification IPC.Notification+ deriving (Eq, Ord, Show, Typeable, Generic)++instance NFData Message++instance IPC.Message Message++instance NvimObject Message where+ toObject = \case+ Request (IPC.Request (F m) i ps) ->+ ObjectArray $ (0 :: Int64) +: i +: m +: ps +: []+ Response i (Left e) ->+ ObjectArray $ (1 :: Int64) +: i +: e +: () +: []+ Response i (Right r) ->+ ObjectArray $ (1 :: Int64) +: i +: () +: r +: []+ Notification (IPC.Notification (NeovimEventId eventId) ps) ->+ ObjectArray $ (2 :: Int64) +: eventId +: ps +: []++ fromObject = \case+ ObjectArray [ObjectInt 0, i, m, ps] -> do+ r <-+ IPC.Request+ <$> fmap F (fromObject m)+ <*> fromObject i+ <*> fromObject ps+ return $ Request r+ ObjectArray [ObjectInt 1, i, e, r] ->+ let eer = case e of+ ObjectNil -> Right r+ _ -> Left e+ in Response <$> fromObject i+ <*> pure eer+ ObjectArray [ObjectInt 2, m, ps] -> do+ n <-+ IPC.Notification+ <$> fmap NeovimEventId (fromObject m)+ <*> fromObject ps+ return $ Notification n+ o ->+ throwError $ "Not a known/valid msgpack-rpc message:" <+> viaShow o++instance Pretty Message where+ pretty = \case+ Request request ->+ pretty request+ Response i ret ->+ nest 2 $+ "Response" <+> "#" <> pretty i+ <> hardline+ <> either viaShow viaShow ret+ Notification notification ->+ pretty notification
+ src/Neovim/RPC/Common.hs view
@@ -0,0 +1,142 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE LambdaCase #-} ++{- |+Module : Neovim.RPC.Common+Description : Common functons for the RPC module+Copyright : (c) Sebastian Witte+License : Apache-2.0++Maintainer : woozletoff@gmail.com+Stability : experimental+-}+module Neovim.RPC.Common where++import Neovim.OS (getSocketUnix)++import Control.Applicative (Alternative ((<|>)))+import Control.Monad (unless)+import Data.Int (Int64)+import Data.Map (Map)+import Data.MessagePack (Object)+import Data.Streaming.Network (getSocketTCP)+import Data.String (IsString (fromString))+import Data.Time (UTCTime)+import Neovim.Compat.Megaparsec as P (+ MonadParsec (eof, try),+ Parser,+ anySingle,+ anySingleBut,+ many,+ parse,+ single,+ some,+ )+import Network.Socket as N (socketToHandle)+import System.Log.Logger (errorM, warningM)++import Data.List (intercalate)+import qualified Data.List as List+import Data.Maybe (catMaybes)+import qualified Text.Megaparsec.Char.Lexer as L+import UnliftIO.Environment (lookupEnv)+import UnliftIO++import Prelude++-- | Things shared between the socket reader and the event handler.+data RPCConfig = RPCConfig+ { recipients :: TVar (Map Int64 (UTCTime, TMVar (Either Object Object)))+ -- ^ A map from message identifiers (as per RPC spec) to a tuple with a+ -- timestamp and a 'TMVar' that is used to communicate the result back to+ -- the calling thread.+ , nextMessageId :: TVar Int64+ -- ^ Message identifier for the next message as per RPC spec.+ }++{- | Create a new basic configuration containing a communication channel for+ remote procedure call events and an empty lookup table for functions to+ mediate.+-}+newRPCConfig :: (Applicative io, MonadUnliftIO io) => io RPCConfig+newRPCConfig =+ RPCConfig+ <$> liftIO (newTVarIO mempty)+ <*> liftIO (newTVarIO 1)++-- | Simple data type defining the kind of socket the socket reader should use.+data SocketType+ = -- | Use the handle for receiving msgpack-rpc messages. This is+ -- suitable for an embedded neovim which is used in test cases.+ Stdout Handle+ | -- | Read the connection information from the environment+ -- variable @NVIM@.+ Environment+ | -- | Use a unix socket.+ UnixSocket FilePath+ | -- | Use an IP socket. First argument is the port and the+ -- second is the host name.+ TCP Int String++{- | Create a 'Handle' from the given socket description.++ The handle is not automatically closed.+-}+createHandle ::+ (Functor io, MonadUnliftIO io) =>+ SocketType ->+ io Handle+createHandle = \case+ Stdout h -> do+ liftIO $ hSetBuffering h (BlockBuffering Nothing)+ return h+ UnixSocket f ->+ liftIO $ createHandle . Stdout =<< flip socketToHandle ReadWriteMode =<< getSocketUnix f+ TCP p h ->+ createHandle . Stdout =<< createTCPSocketHandle p h+ Environment ->+ createHandle . Stdout =<< createSocketHandleFromEnvironment+ where+ createTCPSocketHandle :: (MonadUnliftIO io) => Int -> String -> io Handle+ createTCPSocketHandle p h =+ liftIO $+ getSocketTCP (fromString h) p+ >>= flip socketToHandle ReadWriteMode . fst++ createSocketHandleFromEnvironment = liftIO $ do+ -- NVIM_LISTEN_ADDRESS is for backwards compatibility+ envValues <- catMaybes <$> mapM lookupEnv ["NVIM", "NVIM_LISTEN_ADDRESS"]+ listenAdresses <- mapM parseNvimEnvironmentVariable envValues+ case listenAdresses of+ (s : _) -> createHandle s+ _ -> do+ let errMsg =+ unlines+ [ "Unhandled socket type from environment variable: "+ , "\t" <> intercalate ", " envValues+ ]+ liftIO $ errorM "createHandle" errMsg+ error errMsg++parseNvimEnvironmentVariable :: MonadFail m => String -> m SocketType+parseNvimEnvironmentVariable envValue =+ either (fail . show) pure $ parse (P.try pTcpAddress <|> pUnixSocket) envValue envValue++pUnixSocket :: P.Parser SocketType+pUnixSocket = UnixSocket <$> P.some anySingle <* P.eof++pTcpAddress :: P.Parser SocketType+pTcpAddress = do+ prefixes <- P.some (P.try (P.many (P.anySingleBut ':') <* P.single ':'))+ port <- L.lexeme P.eof L.decimal+ P.eof+ pure $ TCP port (List.intercalate ":" prefixes)++{- | Close the handle and print a warning if the conduit chain has been+ interrupted prematurely.+-}+cleanUpHandle :: (MonadUnliftIO io) => Handle -> Bool -> io ()+cleanUpHandle h completed = liftIO $ do+ hClose h+ unless completed $+ warningM "cleanUpHandle" "Cleanup called on uncompleted handle."
+ src/Neovim/RPC/EventHandler.hs view
@@ -0,0 +1,127 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}++{- |+Module : Neovim.RPC.EventHandler+Description : Event handling loop+Copyright : (c) Sebastian Witte+License : Apache-2.0++Maintainer : woozletoff@gmail.com+Stability : experimental+-}+module Neovim.RPC.EventHandler (+ runEventHandler,+) where++import Neovim.Classes (NvimObject (toObject))+import Neovim.Context (MonadIO (..), asks)+import qualified Neovim.Context.Internal as Internal+import Neovim.Plugin.IPC.Classes (+ FunctionCall (..),+ Message (fromMessage),+ Request (Request),+ SomeMessage,+ readSomeMessage,+ )+import qualified Neovim.RPC.Classes as MsgpackRPC+import Neovim.RPC.Common (RPCConfig (nextMessageId, recipients))+import Neovim.RPC.FunctionCall (atomically')++import Conduit as C (+ ConduitM,+ ConduitT,+ Flush (..),+ ResourceT,+ await,+ runConduit,+ runResourceT,+ sinkHandleFlush,+ yield,+ (.|),+ )+import Control.Monad.Reader (+ MonadReader,+ ReaderT (runReaderT),+ forever,+ )+import Data.ByteString (ByteString)+import qualified Data.Map as Map+import Data.Serialize (encode)+import System.IO (Handle)+import System.Log.Logger (debugM)+import UnliftIO (modifyTVar', readTVar)++import Prelude+import UnliftIO (MonadUnliftIO)++{- | This function will establish a connection to the given socket and write+ msgpack-rpc requests to it.+-}+runEventHandler ::+ Handle ->+ Internal.Config RPCConfig ->+ IO ()+runEventHandler writeableHandle env =+ runEventHandlerContext env . runConduit $ do+ eventHandlerSource+ .| eventHandler+ .| sinkHandleFlush writeableHandle++-- | Convenient monad transformer stack for the event handler+newtype EventHandler a+ = EventHandler (ResourceT (ReaderT (Internal.Config RPCConfig) IO) a)+ deriving+ ( Functor+ , Applicative+ , Monad+ , MonadIO+ , MonadUnliftIO+ , MonadReader (Internal.Config RPCConfig)+ )++runEventHandlerContext ::+ Internal.Config RPCConfig -> EventHandler a -> IO a+runEventHandlerContext env (EventHandler a) =+ runReaderT (runResourceT a) env++eventHandlerSource :: ConduitT () SomeMessage EventHandler ()+eventHandlerSource =+ asks Internal.eventQueue >>= \q ->+ forever $ yield =<< readSomeMessage q++eventHandler :: ConduitM SomeMessage EncodedResponse EventHandler ()+eventHandler =+ await >>= \case+ Nothing ->+ return () -- i.e. close the conduit -- TODO signal shutdown globally+ Just message -> do+ handleMessage (fromMessage message, fromMessage message)+ eventHandler++type EncodedResponse = C.Flush ByteString++yield' :: (MonadUnliftIO io) => MsgpackRPC.Message -> ConduitM i EncodedResponse io ()+yield' o = do+ liftIO . debugM "EventHandler" $ "Sending: " ++ show o+ yield . Chunk . encode $ toObject o+ yield Flush++handleMessage ::+ (Maybe FunctionCall, Maybe MsgpackRPC.Message) ->+ ConduitM i EncodedResponse EventHandler ()+handleMessage = \case+ (Just (FunctionCall fn params reply time), _) -> do+ cfg <- asks Internal.customConfig+ messageId <- atomically' $ do+ i <- readTVar (nextMessageId cfg)+ modifyTVar' (nextMessageId cfg) succ+ modifyTVar' (recipients cfg) $ Map.insert i (time, reply)+ return i+ yield' $ MsgpackRPC.Request (Request fn messageId params)+ (_, Just r@MsgpackRPC.Response{}) ->+ yield' r+ (_, Just n@MsgpackRPC.Notification{}) ->+ yield' n+ _ ->+ return () -- i.e. skip to next message
+ src/Neovim/RPC/FunctionCall.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE LambdaCase #-}++{- |+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,+ scall,+ scall',+ scallThrow,+ atomically',+ wait,+ wait',+ 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.Monad.Reader+import Data.MessagePack++import Prelude+import UnliftIO (STM, newEmptyTMVarIO, readTMVar, throwIO, atomically)++-- | 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 env (STM (Either NeovimException result))+acall fn parameters = do+ q <- Internal.asks' Internal.eventQueue+ mv <- liftIO newEmptyTMVarIO+ timestamp <- liftIO getCurrentTime+ writeMessage q $ FunctionCall fn parameters mv timestamp+ return $ convertObject <$> readTMVar mv+ where+ convertObject ::+ (NvimObject result) =>+ Either Object Object ->+ Either NeovimException result+ convertObject = \case+ Left e -> Left $ ErrorResult (pretty fn) e+ Right o -> case fromObject o of+ Left e -> Left $ ErrorMessage e+ Right r -> Right r++{- | Call a neovim function synchronously. This function blocks until the+ result is available.+-}+scall ::+ (NvimObject result) =>+ FunctionName ->+ -- | Parameters in an 'Object' array+ [Object] ->+ -- | result value of the call or the thrown exception+ Neovim env (Either NeovimException result)+scall fn parameters = acall fn parameters >>= atomically'++-- | Similar to 'scall', but throw a 'NeovimException' instead of returning it.+scallThrow ::+ (NvimObject result) =>+ FunctionName ->+ [Object] ->+ Neovim env result+scallThrow fn parameters = scall fn parameters >>= either throwIO return++{- | Helper function similar to 'scall' that throws a runtime exception if the+ result is an error object.+-}+scall' :: NvimObject result => FunctionName -> [Object] -> Neovim env result+scall' fn = either throwIO pure <=< 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 env (STM result) -> Neovim env result+wait = (=<<) atomically'++-- | Variant of 'wait' that discards the result.+wait' :: Neovim env (STM result) -> Neovim env ()+wait' = void . wait++-- | Send the result back to the neovim instance.+respond :: (NvimObject result) => Request -> Either String result -> Neovim env ()+respond Request{..} result = do+ q <- Internal.asks' Internal.eventQueue+ writeMessage q . MsgpackRPC.Response reqId $+ either (Left . toObject) (Right . toObject) result
+ src/Neovim/RPC/SocketReader.hs view
@@ -0,0 +1,210 @@+{-# LANGUAGE LambdaCase #-}+{- |+Module : Neovim.RPC.SocketReader+Description : The component which reads RPC messages from the neovim instance+Copyright : (c) Sebastian Witte+License : Apache-2.0++Maintainer : woozletoff@gmail.com+Stability : experimental+-}+module Neovim.RPC.SocketReader (+ runSocketReader,+ parseParams,+) where++import Neovim.Classes ( Int64, NvimObject(toObject, fromObject) )+import Neovim.Context ( MonadIO(liftIO), asks, Neovim, runNeovim )+import qualified Neovim.Context.Internal as Internal+import Neovim.Plugin.Classes (+ CommandArguments (..),+ CommandOption (..),+ FunctionName (..),+ FunctionalityDescription (..),+ NeovimEventId (..),+ NvimMethod (..),+ Subscription (..),+ getCommandOptions,+ )+import Neovim.Plugin.IPC.Classes+ ( getCurrentTime,+ Notification(Notification),+ Request(Request),+ writeMessage )+import qualified Neovim.RPC.Classes as MsgpackRPC+import Neovim.RPC.Common ( RPCConfig(recipients) )+import Neovim.RPC.FunctionCall ( atomically' )++import Conduit as C+ ( Void,+ MonadTrans(lift),+ sourceHandle,+ (.|),+ awaitForever,+ runConduit,+ ConduitT )+import Control.Monad (void)+import Data.Conduit.Cereal (conduitGet2)+import Data.Default (def)+import Data.Foldable (foldl', forM_)+import qualified Data.Map as Map+import Data.Maybe (fromMaybe)+import Data.MessagePack ( Object(ObjectArray) )+import qualified Data.Serialize (get)+import System.IO (Handle)+import System.Log.Logger ( debugM, errorM, warningM )+import UnliftIO (atomically, timeout, readTVarIO, modifyTVar', putTMVar, readTMVar, async, newEmptyTMVarIO, modifyTVar)++import Prelude++logger :: String+logger = "Socket Reader"++type SocketHandler = Neovim RPCConfig++{- | This function will establish a connection to the given socket and read+ msgpack-rpc events from it.+-}+runSocketReader ::+ Handle ->+ Internal.Config RPCConfig ->+ IO ()+runSocketReader readableHandle cfg =+ void . runNeovim (Internal.retypeConfig (Internal.customConfig cfg) cfg) . runConduit $ do+ sourceHandle readableHandle+ .| conduitGet2 Data.Serialize.get+ .| messageHandlerSink++{- | Sink that delegates the messages depending on their type.+ <https://github.com/msgpack-rpc/msgpack-rpc/blob/master/spec.md>+-}+messageHandlerSink :: ConduitT Object Void SocketHandler ()+messageHandlerSink = awaitForever $ \rpc -> do+ liftIO . debugM logger $ "Received: " <> show rpc+ case fromObject rpc of+ Right (MsgpackRPC.Request (Request fn i ps)) ->+ handleRequest i fn ps+ Right (MsgpackRPC.Response i r) ->+ handleResponse i r+ Right (MsgpackRPC.Notification (Notification eventId args)) ->+ handleNotification eventId args+ Left e ->+ liftIO . errorM logger $ "Unhandled rpc message: " <> show e++handleResponse :: Int64 -> Either Object Object -> ConduitT a Void SocketHandler ()+handleResponse i result = do+ answerMap <- asks recipients+ mReply <- Map.lookup i <$> liftIO (readTVarIO answerMap)+ case mReply of+ Nothing ->+ liftIO $ warningM logger "Received response but could not find a matching recipient."+ Just (_, reply) -> do+ atomically' . modifyTVar' answerMap $ Map.delete i+ atomically' $ putTMVar reply result++lookupFunction ::+ Internal.Config RPCConfig ->+ FunctionName ->+ IO (Maybe (FunctionalityDescription, Internal.FunctionType))+lookupFunction rpc (F functionName) = do+ functionMap <- atomically $ readTMVar (Internal.globalFunctionMap rpc)+ pure $ Map.lookup (NvimMethod functionName) functionMap++handleRequest :: Int64 -> FunctionName -> [Object] -> ConduitT a Void SocketHandler ()+handleRequest requestId functionToCall params = do+ cfg <- lift Internal.ask'+ void . liftIO . async $ timeout (10 * 1000 * 1000) (handle cfg)+ return ()+ where+ handle :: Internal.Config RPCConfig -> IO ()+ handle rpc =+ lookupFunction rpc functionToCall >>= \case+ Nothing -> do+ let errM = "No provider for: " <> show functionToCall+ debugM logger errM+ writeMessage (Internal.eventQueue rpc) $+ MsgpackRPC.Response requestId (Left (toObject errM))+ Just (copts, Internal.Stateful c) -> do+ now <- liftIO getCurrentTime+ reply <- liftIO newEmptyTMVarIO+ let q = (recipients . Internal.customConfig) rpc+ liftIO . debugM logger $ "Executing stateful function with ID: " <> show requestId+ atomically' . modifyTVar q $ Map.insert requestId (now, reply)+ writeMessage c $ Request functionToCall requestId (parseParams copts params)++handleNotification :: NeovimEventId -> [Object] -> ConduitT a Void SocketHandler ()+handleNotification eventId@(NeovimEventId str) args = do+ cfg <- lift Internal.ask'+ liftIO (lookupFunction cfg (F str)) >>= \case+ Just (copts, Internal.Stateful c) -> liftIO $ do+ debugM logger $ "Executing function asynchronously: " <> show str+ writeMessage c $ Notification eventId (parseParams copts args)+ Nothing -> do+ liftIO $ debugM logger $ "Handling event: " <> show str+ subscriptions' <- lift $ Internal.asks' Internal.subscriptions+ subscribers <- liftIO $+ atomically $ do+ s <- readTMVar subscriptions'+ pure $ fromMaybe [] $ Map.lookup eventId (Internal.byEventId s)+ forM_ subscribers $ \subscription -> liftIO $ subAction subscription args++parseParams :: FunctionalityDescription -> [Object] -> [Object]+parseParams (Function _ _) args = case args of+ -- Defining a function on the remote host creates a function that, that+ -- passes all arguments in a list. At the time of this writing, no other+ -- arguments are passed for such a function.+ --+ -- The function generating the function on neovim side is called:+ -- @remote#define#FunctionOnHost@+ [ObjectArray fArgs] -> fArgs+ _ -> args+parseParams cmd@(Command _ opts) args = case args of+ (ObjectArray _ : _) ->+ let cmdArgs = filter isPassedViaRPC (getCommandOptions opts)+ (c, args') = foldl' createCommandArguments (def, []) $ zip cmdArgs args+ in toObject c : args'+ _ -> parseParams cmd [ObjectArray args]+ where+ isPassedViaRPC :: CommandOption -> Bool+ isPassedViaRPC = \case+ CmdSync{} -> False+ _ -> True++ -- Neovim passes arguments in a special form, depending on the+ -- CommandOption values used to export the (command) function (e.g. via+ -- 'command' or 'command'').+ createCommandArguments ::+ (CommandArguments, [Object]) ->+ (CommandOption, Object) ->+ (CommandArguments, [Object])+ createCommandArguments old@(c, args') = \case+ (CmdRange _, o) ->+ either (const old) (\r -> (c{range = Just r}, args')) $ fromObject o+ (CmdCount _, o) ->+ either (const old) (\n -> (c{count = Just n}, args')) $ fromObject o+ (CmdBang, o) ->+ either (const old) (\b -> (c{bang = Just b}, args')) $ fromObject o+ (CmdNargs "*", ObjectArray os) ->+ -- CommandArguments -> [String] -> Neovim r st a+ (c, os)+ (CmdNargs "+", ObjectArray (o : os)) ->+ -- CommandArguments -> String -> [String] -> Neovim r st a+ (c, o : [ObjectArray os])+ (CmdNargs "?", ObjectArray [o]) ->+ -- CommandArguments -> Maybe String -> Neovim r st a+ (c, [toObject (Just o)])+ (CmdNargs "?", ObjectArray []) ->+ -- CommandArguments -> Maybe String -> Neovim r st a+ (c, [toObject (Nothing :: Maybe Object)])+ (CmdNargs "0", ObjectArray []) ->+ -- CommandArguments -> Neovim r st a+ (c, [])+ (CmdNargs "1", ObjectArray [o]) ->+ -- CommandArguments -> String -> Neovim r st a+ (c, [o])+ (CmdRegister, o) ->+ either (const old) (\r -> (c{register = Just r}, args')) $ fromObject o+ _ -> old+parseParams Autocmd{} args = case args of+ [ObjectArray fArgs] -> fArgs+ _ -> args
+ src/Neovim/Test.hs view
@@ -0,0 +1,214 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++{- |+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 (+ runInEmbeddedNeovim,+ runInEmbeddedNeovim',+ Seconds (..),+ TestConfiguration (..),+ -- deprecated+ testWithEmbeddedNeovim,+) where++import Neovim+import Neovim.API.Text (nvim_command, vim_command)+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 Data.Default (Default)+import Data.Text (pack)+import GHC.IO.Exception (ioe_filename)+import Neovim.Plugin (startPluginThreads)+import Neovim.Util (oneLineErrorMessage)+import Prettyprinter (annotate, vsep)+import Prettyprinter.Render.Terminal (Color (..), color)+import System.Process.Typed (+ ExitCode (ExitFailure, ExitSuccess),+ Process,+ createPipe,+ getExitCode,+ getStdin,+ getStdout,+ proc,+ setStdin,+ setStdout,+ startProcess,+ stopProcess,+ waitExitCode,+ )+import UnliftIO (Handle, IOException, async, atomically, cancel, catch, newEmptyMVar, putMVar, putTMVar, throwIO, timeout)+import UnliftIO.Concurrent (takeMVar, threadDelay)++-- | Type synonym for 'Word'.+newtype Seconds = Seconds Word+ deriving (Show)++microSeconds :: Integral i => Seconds -> i+microSeconds (Seconds s) = fromIntegral s * 1000 * 1000++newtype TestConfiguration = TestConfiguration+ { cancelAfter :: Seconds+ }+ deriving (Show)++instance Default TestConfiguration where+ def =+ TestConfiguration+ { cancelAfter = Seconds 2+ }++{- | Run a neovim process with @-n --clean --embed@ and execute the+ given action that will have access to the started instance.++The 'TestConfiguration' contains sensible defaults.++'env' is the state of your function that you want to test.+-}+runInEmbeddedNeovim :: TestConfiguration -> Plugin env -> Neovim env a -> IO ()+runInEmbeddedNeovim TestConfiguration{..} plugin action =+ warnIfNvimIsNotOnPath runTest+ where+ runTest = do+ resultMVar <- newEmptyMVar+ let action' = do+ result <- action+ q <- Internal.asks' Internal.transitionTo+ putMVar q Internal.Quit+ -- vim_command isn't asynchronous, so we need to avoid waiting+ -- for the result of the operation by using 'async' since+ -- neovim cannot send a result if it has quit.+ _ <- async . void $ vim_command "qa!"+ putMVar resultMVar result+ (nvimProcess, cleanUp) <- startEmbeddedNvim cancelAfter plugin action'++ result <- timeout (microSeconds cancelAfter) (takeMVar resultMVar)++ waitExitCode nvimProcess >>= \case+ ExitFailure i ->+ fail $ "Neovim returned with an exit status of: " ++ show i+ ExitSuccess -> case result of+ Nothing -> fail "Test timed out"+ Just _ -> pure ()+ cleanUp++type TransitionHandler a = Internal.Config RPCConfig -> IO a++testTransitionHandler :: IO a -> TransitionHandler ()+testTransitionHandler onInitAction cfg =+ takeMVar (Internal.transitionTo cfg) >>= \case+ Internal.InitSuccess -> do+ void onInitAction+ testTransitionHandler onInitAction cfg+ Internal.Restart -> do+ fail "Restart unexpected"+ Internal.Failure e -> do+ fail . show $ oneLineErrorMessage e+ Internal.Quit -> do+ return ()++runInEmbeddedNeovim' :: TestConfiguration -> Neovim () a -> IO ()+runInEmbeddedNeovim' testCfg = runInEmbeddedNeovim testCfg Plugin{environment = (), exports = []}++{-# DEPRECATED testWithEmbeddedNeovim "Use \"runInEmbeddedNeovim def env action\" and open files with nvim_command \"edit file\"" #-}++{- | The same as 'runInEmbeddedNeovim' with the given file opened via @nvim_command "edit file"@.+ - This method is kept for backwards compatibility.+-}+testWithEmbeddedNeovim ::+ -- | Optional path to a file that should be opened+ Maybe FilePath ->+ -- | Maximum time (in seconds) that a test is allowed to run+ Seconds ->+ -- | Read-only configuration+ env ->+ -- | Test case+ Neovim env a ->+ IO ()+testWithEmbeddedNeovim file timeoutAfter env action =+ runInEmbeddedNeovim+ def{cancelAfter = timeoutAfter}+ Plugin{environment = env, exports = []}+ (openTestFile <* action)+ where+ openTestFile = case file of+ Nothing -> pure ()+ Just f -> nvim_command $ pack $ "edit " ++ f++warnIfNvimIsNotOnPath :: IO a -> IO ()+warnIfNvimIsNotOnPath test = void test `catch` \(e :: IOException) -> case ioe_filename e of+ Just "nvim" ->+ putDoc . annotate (color Red) $+ vsep+ [ "The neovim executable 'nvim' is not on the PATH."+ , "You may not be testing fully!"+ ]+ _ ->+ throwIO e++startEmbeddedNvim ::+ Seconds ->+ Plugin env ->+ Neovim env () ->+ IO (Process Handle Handle (), IO ())+startEmbeddedNvim timeoutAfter plugin (Internal.Neovim action) = do+ nvimProcess <-+ startProcess $+ setStdin createPipe $+ setStdout createPipe $+ proc "nvim" ["-n", "--clean", "--embed"]++ cfg <- Internal.newConfig (pure Nothing) newRPCConfig++ socketReader <-+ async . void $+ runSocketReader+ (getStdout nvimProcess)+ (cfg{Internal.pluginSettings = Nothing})++ eventHandler <-+ async . void $+ runEventHandler+ (getStdin nvimProcess)+ (cfg{Internal.pluginSettings = Nothing})++ let actionCfg = Internal.retypeConfig (environment plugin) cfg+ action' = runReaderT action actionCfg+ pluginHandlers <-+ startPluginThreads (Internal.retypeConfig () cfg) [wrapPlugin plugin] >>= \case+ Left e -> do+ putMVar (Internal.transitionTo cfg) $ Internal.Failure e+ pure []+ Right (funMapEntries, pluginTids) -> do+ atomically $+ putTMVar+ (Internal.globalFunctionMap cfg)+ (Internal.mkFunctionMap funMapEntries)+ putMVar (Internal.transitionTo cfg) Internal.InitSuccess+ pure pluginTids++ transitionHandler <- async . void $ do+ testTransitionHandler action' cfg+ timeoutAsync <- async . void $ do+ threadDelay $ microSeconds timeoutAfter+ getExitCode nvimProcess >>= maybe (stopProcess nvimProcess) (\_ -> pure ())++ let cleanUp =+ mapM_ cancel $+ [socketReader, eventHandler, timeoutAsync, transitionHandler]+ ++ pluginHandlers++ pure (nvimProcess, cleanUp)
+ src/Neovim/Util.hs view
@@ -0,0 +1,32 @@+{- |+Module : Neovim.Util+Description : Utility functions+Copyright : (c) Sebastian Witte+License : Apache-2.0++Maintainer : woozletoff@gmail.com+Stability : experimental+Portability : GHC+-}+module Neovim.Util (+ whenM,+ unlessM,+ oneLineErrorMessage,+) where++import Control.Monad (unless, when)+import qualified Data.Text as T+import Neovim.Context++-- | 'when' with a monadic predicate.+whenM :: (Monad m) => m Bool -> m () -> m ()+whenM mp a = mp >>= \p -> when p a++-- | 'unless' with a monadic predicate.+unlessM :: (Monad m) => m Bool -> m () -> m ()+unlessM mp a = mp >>= \p -> unless p a++oneLineErrorMessage :: Doc AnsiStyle -> T.Text+oneLineErrorMessage d = case T.lines $ docToText d of+ (x : _) -> x+ [] -> mempty
− test-suite/AsyncFunctionSpec.hs
@@ -1,34 +0,0 @@-module AsyncFunctionSpec where--import Neovim-import Neovim.API.Text-import Neovim.Plugin (registerFunctionality)-import Neovim.Plugin.Classes (FunctionName (..), FunctionalityDescription (..))-import Neovim.Plugin.Internal (ExportedFunctionality (..))-import Neovim.Test--import Test.Hspec--import Neovim.Log-import UnliftIO-import UnliftIO.Concurrent--spec :: Spec-spec = do- describe "an asynchronous function" $ do- it "is callable" $ do- called <- newEmptyMVar- let myAsyncTestFunction = do- Plugin- { environment = ()- , exports =- [ EF- ( Function (F "MyAsyncTestFunction") Async- , \args -> toObject <$> putMVar called ()- )- ]- }- runInEmbeddedNeovim def{cancelAfter = Seconds 3} myAsyncTestFunction $ do- nvim_call_function "MyAsyncTestFunction" mempty-- liftIO $ readMVar called `shouldReturn` ()
− test-suite/Neovim/API/THSpec.hs
@@ -1,117 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}--module Neovim.API.THSpec where--import Neovim.API.THSpecFunctions--import Neovim.API.TH hiding (function)-import qualified Neovim.API.TH as TH-import Neovim.Context-import qualified Neovim.Context.Internal as Internal-import Neovim.Plugin.Classes-import Neovim.Plugin.Internal--import Data.Default-import qualified Data.Map as Map--import Test.Hspec-import Test.QuickCheck--call ::- ([Object] -> Neovim () Object) ->- [Object] ->- IO Object-call f args = do- cfg <- Internal.newConfig (pure Nothing) (pure ())- res <- runNeovim cfg (f args)- case res of- Right x -> return x- Left e -> (throwIO . ErrorMessage) e--isNeovimException :: NeovimException -> Bool-isNeovimException _ = True--spec :: Spec-spec = do- describe "calling function without an argument" $ do- let EF (Function fname _, testFun) = $(TH.function "TestFunction0" 'testFunction0) Sync- it "should have a capitalized prefix" $- fname `shouldBe` F "TestFunction0"-- it "should return the consant value" $- call testFun [] `shouldReturn` ObjectInt 42-- it "should fail if supplied an argument" $- call testFun [ObjectNil] `shouldThrow` isNeovimException-- describe "calling testFunction with two arguments" $ do- let EF (Function fname _, testFun) = $(function' 'testFunction2) Sync- it "should have a capitalized prefix" $- fname `shouldBe` F "TestFunction2"-- it "should return 2 for proper arguments" $- call- testFun- [ ObjectNil- , ObjectString "ignored"- , ObjectArray [ObjectString "42"]- ]- `shouldReturn` ObjectDouble 2-- it "should throw an exception for the wrong number of arguments" $- call testFun [ObjectNil] `shouldThrow` isNeovimException-- it "should throw an exception for incompatible types" $- call testFun [ObjectNil, ObjectBinary "ignored", ObjectString "42"]- `shouldThrow` isNeovimException-- it "should cast arguments to similar types" $- call testFun [ObjectNil, ObjectString "ignored", ObjectArray []]- `shouldReturn` ObjectDouble 2-- describe "generating a command from the two argument test function" $ do- let EF (Command fname _, _) = $(command' 'testFunction2) []- it "should capitalize the first character" $- fname `shouldBe` F "TestFunction2"-- describe "generating the test successor functions" $ do- let EF (Function fname _, testFun) = $(function' 'testSucc) Sync- it "should be named TestSucc" $- fname `shouldBe` F "TestSucc"-- it "should return the old value + 1" . property $- \x -> call testFun [ObjectInt x] `shouldReturn` ObjectInt (x + 1)-- describe "calling test function with a map argument" $ do- let EF (Function fname _, testFun) = $(TH.function "TestFunctionMap" 'testFunctionMap) Sync- it "should capitalize the first letter" $- fname `shouldBe` F "TestFunctionMap"-- it "should fail for the wrong number of arguments" $- call testFun [] `shouldThrow` isNeovimException-- it "should fail for the wrong type of arguments" $- call testFun [ObjectInt 7, ObjectString "FOO"] `shouldThrow` isNeovimException-- it "should return Nothing for an empty map" $- call testFun [toObject (Map.empty :: Map.Map String Int), ObjectString "FOO"]- `shouldReturn` ObjectNil-- it "should return just the value for the singletion entry" $- call testFun [toObject (Map.singleton "FOO" 7 :: Map.Map String Int), ObjectString "FOO"]- `shouldReturn` ObjectInt 7-- describe "Calling function with an optional argument" $ do- let EF (Command cname _, testFun) = $(command' 'testCommandOptArgument) []- defCmdArgs = toObject (def :: CommandArguments)- it "should capitalize the first letter" $- cname `shouldBe` F "TestCommandOptArgument"-- it "should return \"default\" when passed no argument" $ do- call testFun [defCmdArgs] `shouldReturn` toObject ("default" :: String)-- it "should return what is passed otherwise" . property $ do- \str ->- call testFun [defCmdArgs, toObject str]- `shouldReturn` toObject (str :: String)
− test-suite/Neovim/API/THSpecFunctions.hs
@@ -1,21 +0,0 @@-module Neovim.API.THSpecFunctions where--import qualified Data.Map as Map-import Neovim--testFunction0 :: Neovim env Int-testFunction0 = return 42--testFunction2 :: CommandArguments -> String -> [String] -> Neovim env Double-testFunction2 _ _ _ = return 2--testFunctionMap :: Map.Map String Int -> String -> Neovim env (Maybe Int)-testFunctionMap m k = return $ Map.lookup k m--testSucc :: Int -> Neovim env Int-testSucc = return . succ--testCommandOptArgument :: CommandArguments -> Maybe String -> Neovim env String-testCommandOptArgument _ ms = case ms of- Just x -> return x- Nothing -> return "default"
− test-suite/Neovim/EmbeddedRPCSpec.hs
@@ -1,88 +0,0 @@-{-# LANGUAGE LambdaCase #-}--module Neovim.EmbeddedRPCSpec where--import Test.HUnit-import Test.Hspec--import Neovim-import Neovim.API.Text-import Neovim.Context (docToText)-import qualified Neovim.Context.Internal as Internal-import Neovim.Quickfix-import Neovim.RPC.Common-import Neovim.RPC.EventHandler-import Neovim.RPC.FunctionCall (atomically')-import Neovim.RPC.SocketReader-import Neovim.Test--import Control.Concurrent-import Control.Concurrent.STM-import Control.Monad.Reader (runReaderT)-import Control.Monad.State (runStateT)-import qualified Data.Map as Map-import qualified GHC.IO.Device as Path-import Path-import Path.IO-import System.Exit (ExitCode (..))-import System.Process.Typed--{- | Tests in here should always be wrapped in 'runInEmbeddedNeovim' def' because they- don't fail if neovim isn't installed. This is particularly helpful to run- tests on stackage and be notified if non-neovim-dependent tests fail.- Basically everybody else who runs these tests has neovim installed and would- see the test failing.--}-spec :: Spec-spec = parallel $ do- describe "Read hello test file" $- it "should match 'Hello, World!'" . runInEmbeddedNeovim' def $ do- nvim_command "edit test-files/hello"- bs <- vim_get_buffers- l <- vim_get_current_line- liftIO $ l `shouldBe` "Hello, World!"- liftIO $ length bs `shouldBe` 1-- describe "New empty buffer test" $ do- it "should contain the test text" . runInEmbeddedNeovim' def $ do- cl0 <- vim_get_current_line- liftIO $ cl0 `shouldBe` ""- bs <- vim_get_buffers- liftIO $ length bs `shouldBe` 1-- let testContent = "Test on empty buffer"- vim_set_current_line testContent- cl1 <- vim_get_current_line- liftIO $ cl1 `shouldBe` testContent-- it "should create a new buffer" . runInEmbeddedNeovim' def $ do- bs0 <- vim_get_buffers- liftIO $ length bs0 `shouldBe` 1- vim_command "new"- bs1 <- vim_get_buffers- liftIO $ length bs1 `shouldBe` 2- vim_command "new"- bs2 <- vim_get_buffers- liftIO $ length bs2 `shouldBe` 3-- it "should set the quickfix list" . runInEmbeddedNeovim' def $ do- let q = quickfixListItem (Left 1) (Left 0) :: QuickfixListItem String- setqflist [q] Replace- q' <- vim_eval "getqflist()"- liftIO $ fromObjectUnsafe q' `shouldBe` [q]-- it "throws NeovimException with function that failed as Doc" . runInEmbeddedNeovim' def $ do- let getVariableValue = False <$ vim_get_var "notDefined"- hasTrhownNeovimExceptionWithFunctionName <-- getVariableValue `catchNeovimException` \case- ErrorResult f _ -> pure $ docToText f == "vim_get_var"- _ -> pure False- liftIO $ hasTrhownNeovimExceptionWithFunctionName `shouldBe` True-- it "catches" . runInEmbeddedNeovim' def $ do- let getUndefinedVariable = vim_get_var "notDefined"- functionThatFailed <-- getUndefinedVariable `catchNeovimException` \case- ErrorResult f _ -> pure . toObject $ docToText f- _ -> pure ObjectNil- liftIO $ functionThatFailed `shouldBe` toObject ("vim_get_var" :: String)
− test-suite/Neovim/EventSubscriptionSpec.hs
@@ -1,63 +0,0 @@-{-# LANGUAGE OverloadedLists #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}--module Neovim.EventSubscriptionSpec where--import Neovim-import Neovim.API.String-import Neovim.Test--import Test.Hspec--import UnliftIO (newEmptyMVar, putMVar, readMVar)--data BufLinesEvent = BufLinesEvent- { bleBuffer :: Buffer- , bleFirstLine :: Int- , bleLastLine :: Int- , bleLines :: [String]- , bleMore :: Bool- }- deriving (Eq, Show)--parseBufLinesEvent :: [Object] -> Either (Doc AnsiStyle) BufLinesEvent-parseBufLinesEvent event = case event of- [buf, _changedTick, firstline, lastline, linedata, more] -> do- bleBuffer <- fromObject buf- bleFirstLine <- fromObject firstline- bleLastLine <- fromObject lastline- bleLines <- fromObject linedata- bleMore <- fromObject more- pure BufLinesEvent{..}- _ -> Left . pretty $ "Unexpected nvim_buf_lines_event: " ++ show event--spec :: Spec-spec = parallel $ do- describe "Attaching to a buffer" $ do- it "receives nvim_buf_lines_event" . runInEmbeddedNeovim' def $ do- received <- newEmptyMVar- subscribe "nvim_buf_lines_event" $ putMVar received . parseBufLinesEvent- buf <- nvim_create_buf True False- isOk <- nvim_buf_attach buf True []-- liftIO $ do- isOk `shouldBe` True- Right BufLinesEvent{..} <- readMVar received- bleBuffer `shouldBe` buf- bleFirstLine `shouldBe` 0- bleLastLine `shouldBe` -1- bleLines `shouldBe` [""]- bleMore `shouldBe` False-- it "receives nvim_buf_detach_event" . runInEmbeddedNeovim' def $ do- received <- newEmptyMVar- subscribe "nvim_buf_detach_event" $ putMVar received- buf <- nvim_create_buf True False- isOk <- nvim_buf_attach buf False []- nvim_buf_detach buf-- liftIO $ do- isOk `shouldBe` True- [buf'] <- readMVar received- fromObjectUnsafe buf' `shouldBe` buf
− test-suite/Neovim/Plugin/ClassesSpec.hs
@@ -1,64 +0,0 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE RecordWildCards #-}--module Neovim.Plugin.ClassesSpec where--import Neovim-import Neovim.Plugin.Classes--import Test.Hspec-import Test.QuickCheck--newtype RandomCommandArguments = RCA {getRandomCommandArguments :: CommandArguments}- deriving (Eq, Ord, Show, Read)--instance Arbitrary RandomCommandArguments where- arbitrary = do- bang <- arbitrary- range <- arbitrary- count <- arbitrary- register <- fmap (fmap getNonEmpty) arbitrary- return . RCA $ CommandArguments{..}--newtype RandomCommandOption = RCO {getRandomCommandOption :: CommandOption}- deriving (Eq, Ord, Show, Read)--instance Arbitrary RandomCommandOption where- arbitrary = do- a <- choose (0, 5) :: Gen Int- o <- case a of- -- XXX Most constructor arguments are not tested anyway, so they are- -- hardcoded for now.- 0 -> CmdSync <$> elements [Sync, Async]- 1 -> return CmdRegister- 2 -> return $ CmdNargs ""- 3 -> CmdRange <$> elements [CurrentLine, WholeFile, RangeCount 1]- 4 -> CmdCount <$> arbitrary- _ -> return CmdBang- return $ RCO o--newtype RandomCommandOptions = RCOs {getRandomCommandOptions :: CommandOptions}- deriving (Eq, Ord, Show, Read)--instance Arbitrary RandomCommandOptions where- arbitrary = do- l <- choose (0, 20)- RCOs . mkCommandOptions . map getRandomCommandOption <$> vectorOf l arbitrary--spec :: Spec-spec = do- describe "Deserializing and serializing" $ do- it "should be id for CommandArguments" . property $ do- \args ->- (fromObjectUnsafe . toObject . getRandomCommandArguments) args- `shouldBe` getRandomCommandArguments args-- describe "If a sync option is set for commands" $ do- let isSyncOption = \case- CmdSync _ -> True- _ -> False- it "must be at the head of the list" . property $ do- \(RCOs opts) ->- any isSyncOption (getCommandOptions opts) ==> do- length (filter isSyncOption (getCommandOptions opts)) `shouldBe` 1- head (getCommandOptions opts) `shouldSatisfy` isSyncOption
− test-suite/Neovim/RPC/CommonSpec.hs
@@ -1,20 +0,0 @@-module Neovim.RPC.CommonSpec where--import Neovim.RPC.Common--import Test.Hspec--spec :: Spec-spec = do- describe "Parsing of $NVIM environment variable" $ do- it "is a UnixSocket if it doesn't contain a colon" $ do- UnixSocket actual <- parseNvimEnvironmentVariable "/some/file"- actual `shouldBe` "/some/file"- it "is a tcp connection if it contains a colon" $ do- TCP actualPort actualHostname <- parseNvimEnvironmentVariable "localhost:12345"- actualPort `shouldBe` 12345- actualHostname `shouldBe` "localhost"- it "the last number after many colons is the port" $ do- TCP actualPort actualHostname <- parseNvimEnvironmentVariable "the:cake:is:a:lie:777"- actualPort `shouldBe` 777- actualHostname `shouldBe` "the:cake:is:a:lie"
− test-suite/Neovim/RPC/SocketReaderSpec.hs
@@ -1,77 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Neovim.RPC.SocketReaderSpec where--import Neovim-import Neovim.Plugin.Classes-import Neovim.RPC.SocketReader (parseParams)--import Test.Hspec--spec :: Spec-spec = do- describe "parseParams" $ do- it "should pass the inner argument list as is for functions" $ do- parseParams (Function (F "") Sync) [ObjectArray [ObjectNil, ObjectBinary "ABC"]]- `shouldBe` [ObjectNil, ObjectBinary "ABC"]- parseParams (Function (F "") Sync) [ObjectNil, ObjectBinary "ABC"]- `shouldBe` [ObjectNil, ObjectBinary "ABC"]- parseParams (Function (F "") Sync) []- `shouldBe` []-- let defCmdArgs = def :: CommandArguments- it "should filter out implicit arguments" $ do- parseParams- (Command (F "") (mkCommandOptions [CmdSync Sync, CmdNargs "*"]))- [ObjectArray []]- `shouldBe` [toObject defCmdArgs]- parseParams- (Command (F "") (mkCommandOptions [CmdSync Sync, CmdNargs "*"]))- [ObjectArray [ObjectBinary "7", ObjectInt 7]]- `shouldBe` [toObject defCmdArgs, ObjectBinary "7", ObjectInt 7]-- it "should set the CommandOptions argument as expected" $ do- parseParams- ( Command- (F "")- ( mkCommandOptions- [CmdRange WholeFile, CmdBang, CmdNargs "*"]- )- )- [ ObjectArray [ObjectBinary "7", ObjectBinary "8", ObjectNil]- , ObjectArray [ObjectInt 1, ObjectInt 12]- , ObjectInt 1- ]- `shouldBe` [ toObject (defCmdArgs{bang = Just True, range = Just (1, 12)})- , ObjectBinary "7"- , ObjectBinary "8"- , ObjectNil- ]-- it "should pass this test" $ do- parseParams- (Command (F "") (mkCommandOptions [CmdNargs "+", CmdRange WholeFile, CmdBang]))- [ ObjectArray- [ ObjectBinary "me"- , ObjectBinary "up"- , ObjectBinary "before"- , ObjectBinary "you"- , ObjectBinary "go"- , ObjectBinary "go"- ]- , ObjectArray- [ ObjectInt 1- , ObjectInt 27- ]- , ObjectInt 0- ]- `shouldBe` [ toObject (defCmdArgs{bang = Just False, range = Just (1, 27)})- , ObjectBinary "me"- , ObjectArray- [ ObjectBinary "up"- , ObjectBinary "before"- , ObjectBinary "you"- , ObjectBinary "go"- , ObjectBinary "go"- ]- ]
− test-suite/Spec.hs
@@ -1,1 +0,0 @@-{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ tests/API/THSpec.hs view
@@ -0,0 +1,118 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++module API.THSpec where++import API.THSpecFunctions++import Neovim.API.TH hiding (function)+import qualified Neovim.API.TH as TH+import Neovim.Context+import qualified Neovim.Context.Internal as Internal+import Neovim.Plugin.Classes+import Neovim.Plugin.Internal++import Data.Default+import qualified Data.Map as Map++import Test.Hspec+import Test.QuickCheck++call ::+ ([Object] -> Neovim () Object) ->+ [Object] ->+ IO Object+call f args = do+ cfg <- Internal.newConfig (pure Nothing) (pure ())+ res <- runNeovim cfg (f args)+ case res of+ Right x -> return x+ Left e -> (throwIO . ErrorMessage) e++isNeovimException :: NeovimException -> Bool+isNeovimException _ = True++spec :: Spec+spec = do+ describe "calling function without an argument" $ do+ let EF (Function fname _, testFun) = $(TH.function "TestFunction0" 'testFunction0) Sync+ it "should have a capitalized prefix" $+ fname `shouldBe` F "TestFunction0"++ it "should return the consant value" $+ call testFun [] `shouldReturn` ObjectInt 42++ it "should fail if supplied an argument" $+ call testFun [ObjectNil] `shouldThrow` isNeovimException++ describe "calling testFunction with two arguments" $ do+ let EF (Function fname _, testFun) = $(function' 'testFunction2) Sync+ it "should have a capitalized prefix" $+ fname `shouldBe` F "TestFunction2"++ it "should return 2 for proper arguments" $+ call+ testFun+ [ ObjectNil+ , ObjectString "ignored"+ , ObjectArray [ObjectString "42"]+ ]+ `shouldReturn` ObjectDouble 2++ it "should throw an exception for the wrong number of arguments" $+ call testFun [ObjectNil] `shouldThrow` isNeovimException++ it "should throw an exception for incompatible types" $+ call testFun [ObjectNil, ObjectBinary "ignored", ObjectString "42"]+ `shouldThrow` isNeovimException++ it "should cast arguments to similar types" $+ call testFun [ObjectNil, ObjectString "ignored", ObjectArray []]+ `shouldReturn` ObjectDouble 2++ describe "generating a command from the two argument test function" $ do+ let EF (Command fname _, _) = $(command' 'testFunction2) []+ it "should capitalize the first character" $+ fname `shouldBe` F "TestFunction2"++ describe "generating the test successor functions" $ do+ let EF (Function fname _, testFun) = $(function' 'testSucc) Sync+ it "should be named TestSucc" $+ fname `shouldBe` F "TestSucc"++ it "should return the old value + 1" . property $+ \x -> call testFun [ObjectInt x] `shouldReturn` ObjectInt (x + 1)++ describe "calling test function with a map argument" $ do+ let EF (Function fname _, testFun) = $(TH.function "TestFunctionMap" 'testFunctionMap) Sync+ it "should capitalize the first letter" $+ fname `shouldBe` F "TestFunctionMap"++ it "should fail for the wrong number of arguments" $+ call testFun [] `shouldThrow` isNeovimException++ it "should fail for the wrong type of arguments" $+ call testFun [ObjectInt 7, ObjectString "FOO"] `shouldThrow` isNeovimException++ it "should return Nothing for an empty map" $+ call testFun [toObject (Map.empty :: Map.Map String Int), ObjectString "FOO"]+ `shouldReturn` ObjectNil++ it "should return just the value for the singletion entry" $+ call testFun [toObject (Map.singleton "FOO" 7 :: Map.Map String Int), ObjectString "FOO"]+ `shouldReturn` ObjectInt 7++ describe "Calling function with an optional argument" $ do+ let EF (Command cname _, testFun) = $(command' 'testCommandOptArgument) []+ defCmdArgs = toObject (def :: CommandArguments)+ it "should capitalize the first letter" $+ cname `shouldBe` F "TestCommandOptArgument"++ it "should return \"default\" when passed no argument" $ do+ call testFun [defCmdArgs] `shouldReturn` toObject ("default" :: String)++ it "should return what is passed otherwise" . property $ do+ \str ->+ call testFun [defCmdArgs, toObject str]+ `shouldReturn` toObject (str :: String)
+ tests/API/THSpecFunctions.hs view
@@ -0,0 +1,21 @@+module API.THSpecFunctions where++import qualified Data.Map as Map+import Neovim++testFunction0 :: Neovim env Int+testFunction0 = return 42++testFunction2 :: CommandArguments -> String -> [String] -> Neovim env Double+testFunction2 _ _ _ = return 2++testFunctionMap :: Map.Map String Int -> String -> Neovim env (Maybe Int)+testFunctionMap m k = return $ Map.lookup k m++testSucc :: Int -> Neovim env Int+testSucc = return . succ++testCommandOptArgument :: CommandArguments -> Maybe String -> Neovim env String+testCommandOptArgument _ ms = case ms of+ Just x -> return x+ Nothing -> return "default"
+ tests/AsyncFunctionSpec.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE OverloadedStrings #-}+module AsyncFunctionSpec where++import Neovim+import Neovim.API.Text+import Neovim.Plugin.Classes (FunctionName (..), FunctionalityDescription (..))+import Neovim.Plugin.Internal (ExportedFunctionality (..))+import Neovim.Test++import Test.Hspec++import UnliftIO++spec :: Spec+spec = do+ describe "an asynchronous function" $ do+ it "is callable" $ do+ called <- newEmptyMVar+ let myAsyncTestFunction = do+ Plugin+ { environment = ()+ , exports =+ [ EF+ ( Function (F "MyAsyncTestFunction") Async+ , \_args -> toObject <$> putMVar called ()+ )+ ]+ }+ runInEmbeddedNeovim def{cancelAfter = Seconds 3} myAsyncTestFunction $ do+ void $ nvim_call_function "MyAsyncTestFunction" mempty++ liftIO $ readMVar called `shouldReturn` ()
+ tests/EmbeddedRPCSpec.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module EmbeddedRPCSpec where++import Test.Hspec++import Neovim+import Neovim.API.Text+import Neovim.Context (docToText)+import Neovim.Quickfix+import Neovim.Test++{- | Tests in here should always be wrapped in 'runInEmbeddedNeovim' def' because they+ don't fail if neovim isn't installed. This is particularly helpful to run+ tests on stackage and be notified if non-neovim-dependent tests fail.+ Basically everybody else who runs these tests has neovim installed and would+ see the test failing.+-}+spec :: Spec+spec = parallel $ do+ describe "Read hello test file" $+ it "should match 'Hello, World!'" . runInEmbeddedNeovim' def $ do+ nvim_command "edit test-files/hello"+ bs <- vim_get_buffers+ l <- vim_get_current_line+ liftIO $ l `shouldBe` "Hello, World!"+ liftIO $ length bs `shouldBe` 1++ describe "New empty buffer test" $ do+ it "should contain the test text" . runInEmbeddedNeovim' def $ do+ cl0 <- vim_get_current_line+ liftIO $ cl0 `shouldBe` ""+ bs <- vim_get_buffers+ liftIO $ length bs `shouldBe` 1++ let testContent = "Test on empty buffer"+ vim_set_current_line testContent+ cl1 <- vim_get_current_line+ liftIO $ cl1 `shouldBe` testContent++ it "should create a new buffer" . runInEmbeddedNeovim' def $ do+ bs0 <- vim_get_buffers+ liftIO $ length bs0 `shouldBe` 1+ vim_command "new"+ bs1 <- vim_get_buffers+ liftIO $ length bs1 `shouldBe` 2+ vim_command "new"+ bs2 <- vim_get_buffers+ liftIO $ length bs2 `shouldBe` 3++ it "should set the quickfix list" . runInEmbeddedNeovim' def $ do+ let q = quickfixListItem (Left 1) (Left 0) :: QuickfixListItem String+ setqflist [q] Replace+ q' <- vim_eval "getqflist()"+ liftIO $ fromObjectUnsafe q' `shouldBe` [q]++ it "throws NeovimException with function that failed as Doc" . runInEmbeddedNeovim' def $ do+ let getVariableValue = False <$ vim_get_var "notDefined"+ hasTrhownNeovimExceptionWithFunctionName <-+ getVariableValue `catchNeovimException` \case+ ErrorResult f _ -> pure $ docToText f == "vim_get_var"+ _ -> pure False+ liftIO $ hasTrhownNeovimExceptionWithFunctionName `shouldBe` True++ it "catches" . runInEmbeddedNeovim' def $ do+ let getUndefinedVariable = vim_get_var "notDefined"+ functionThatFailed <-+ getUndefinedVariable `catchNeovimException` \case+ ErrorResult f _ -> pure . toObject $ docToText f+ _ -> pure ObjectNil+ liftIO $ functionThatFailed `shouldBe` toObject ("vim_get_var" :: String)
+ tests/EventSubscriptionSpec.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module EventSubscriptionSpec where++import Neovim+import Neovim.API.String+import Neovim.Test++import Test.Hspec++import UnliftIO (newEmptyMVar, putMVar, readMVar)++data BufLinesEvent = BufLinesEvent+ { bleBuffer :: Buffer+ , bleFirstLine :: Int+ , bleLastLine :: Int+ , bleLines :: [String]+ , bleMore :: Bool+ }+ deriving (Eq, Show)++parseBufLinesEvent :: [Object] -> Either (Doc AnsiStyle) BufLinesEvent+parseBufLinesEvent event = case event of+ [buf, _changedTick, firstline, lastline, linedata, more] -> do+ bleBuffer <- fromObject buf+ bleFirstLine <- fromObject firstline+ bleLastLine <- fromObject lastline+ bleLines <- fromObject linedata+ bleMore <- fromObject more+ pure BufLinesEvent{..}+ _ -> Left . pretty $ "Unexpected nvim_buf_lines_event: " ++ show event++spec :: Spec+spec = parallel $ do+ describe "Attaching to a buffer" $ do+ it "receives nvim_buf_lines_event" . runInEmbeddedNeovim' def $ do+ received <- newEmptyMVar+ subscription <- subscribe "nvim_buf_lines_event" $ putMVar received . parseBufLinesEvent+ buf <- nvim_create_buf True False+ isOk <- nvim_buf_attach buf True []++ liftIO $ do+ isOk `shouldBe` True+ Right BufLinesEvent{..} <- readMVar received+ bleBuffer `shouldBe` buf+ bleFirstLine `shouldBe` 0+ bleLastLine `shouldBe` -1+ bleLines `shouldBe` [""]+ bleMore `shouldBe` False+ unsubscribe subscription++ it "receives nvim_buf_detach_event" . runInEmbeddedNeovim' def $ do+ received <- newEmptyMVar+ subscription <- subscribe "nvim_buf_detach_event" $ putMVar received+ buf <- nvim_create_buf True False+ isOk <- nvim_buf_attach buf False []+ void $ nvim_buf_detach buf++ liftIO $ do+ isOk `shouldBe` True+ [buf'] <- readMVar received+ fromObjectUnsafe buf' `shouldBe` buf+ unsubscribe subscription
+ tests/Plugin/ClassesSpec.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}++module Plugin.ClassesSpec where++import Neovim+import Neovim.Plugin.Classes++import Test.Hspec+import Test.QuickCheck++newtype RandomCommandArguments = RCA {getRandomCommandArguments :: CommandArguments}+ deriving (Eq, Ord, Show, Read)++instance Arbitrary RandomCommandArguments where+ arbitrary = do+ bang <- arbitrary+ range <- arbitrary+ count <- arbitrary+ register <- fmap (fmap getNonEmpty) arbitrary+ return . RCA $ CommandArguments{..}++newtype RandomCommandOption = RCO {getRandomCommandOption :: CommandOption}+ deriving (Eq, Ord, Show, Read)++instance Arbitrary RandomCommandOption where+ arbitrary = do+ a <- choose (0, 5) :: Gen Int+ o <- case a of+ -- XXX Most constructor arguments are not tested anyway, so they are+ -- hardcoded for now.+ 0 -> CmdSync <$> elements [Sync, Async]+ 1 -> return CmdRegister+ 2 -> return $ CmdNargs ""+ 3 -> CmdRange <$> elements [CurrentLine, WholeFile, RangeCount 1]+ 4 -> CmdCount <$> arbitrary+ _ -> return CmdBang+ return $ RCO o++newtype RandomCommandOptions = RCOs {getRandomCommandOptions :: CommandOptions}+ deriving (Eq, Ord, Show, Read)++instance Arbitrary RandomCommandOptions where+ arbitrary = do+ l <- choose (0, 20)+ RCOs . mkCommandOptions . map getRandomCommandOption <$> vectorOf l arbitrary++spec :: Spec+spec = do+ describe "Deserializing and serializing" $ do+ it "should be id for CommandArguments" . property $ do+ \args ->+ (fromObjectUnsafe . toObject . getRandomCommandArguments) args+ `shouldBe` getRandomCommandArguments args++ describe "If a sync option is set for commands" $ do+ let isSyncOption = \case+ CmdSync _ -> True+ _ -> False+ it "must be at the head of the list" . property $ do+ \(RCOs opts) ->+ any isSyncOption (getCommandOptions opts) ==> do+ length (filter isSyncOption (getCommandOptions opts)) `shouldBe` 1+ head (getCommandOptions opts) `shouldSatisfy` isSyncOption
+ tests/RPC/CommonSpec.hs view
@@ -0,0 +1,20 @@+module RPC.CommonSpec where++import Neovim.RPC.Common++import Test.Hspec++spec :: Spec+spec = do+ describe "Parsing of $NVIM environment variable" $ do+ it "is a UnixSocket if it doesn't contain a colon" $ do+ UnixSocket actual <- parseNvimEnvironmentVariable "/some/file"+ actual `shouldBe` "/some/file"+ it "is a tcp connection if it contains a colon" $ do+ TCP actualPort actualHostname <- parseNvimEnvironmentVariable "localhost:12345"+ actualPort `shouldBe` 12345+ actualHostname `shouldBe` "localhost"+ it "the last number after many colons is the port" $ do+ TCP actualPort actualHostname <- parseNvimEnvironmentVariable "the:cake:is:a:lie:777"+ actualPort `shouldBe` 777+ actualHostname `shouldBe` "the:cake:is:a:lie"
+ tests/RPC/SocketReaderSpec.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE OverloadedStrings #-}++module RPC.SocketReaderSpec where++import Neovim+import Neovim.Plugin.Classes+import Neovim.RPC.SocketReader (parseParams)++import Test.Hspec++spec :: Spec+spec = do+ describe "parseParams" $ do+ it "should pass the inner argument list as is for functions" $ do+ parseParams (Function (F "") Sync) [ObjectArray [ObjectNil, ObjectBinary "ABC"]]+ `shouldBe` [ObjectNil, ObjectBinary "ABC"]+ parseParams (Function (F "") Sync) [ObjectNil, ObjectBinary "ABC"]+ `shouldBe` [ObjectNil, ObjectBinary "ABC"]+ parseParams (Function (F "") Sync) []+ `shouldBe` []++ let defCmdArgs = def :: CommandArguments+ it "should filter out implicit arguments" $ do+ parseParams+ (Command (F "") (mkCommandOptions [CmdSync Sync, CmdNargs "*"]))+ [ObjectArray []]+ `shouldBe` [toObject defCmdArgs]+ parseParams+ (Command (F "") (mkCommandOptions [CmdSync Sync, CmdNargs "*"]))+ [ObjectArray [ObjectBinary "7", ObjectInt 7]]+ `shouldBe` [toObject defCmdArgs, ObjectBinary "7", ObjectInt 7]++ it "should set the CommandOptions argument as expected" $ do+ parseParams+ ( Command+ (F "")+ ( mkCommandOptions+ [CmdRange WholeFile, CmdBang, CmdNargs "*"]+ )+ )+ [ ObjectArray [ObjectBinary "7", ObjectBinary "8", ObjectNil]+ , ObjectArray [ObjectInt 1, ObjectInt 12]+ , ObjectInt 1+ ]+ `shouldBe` [ toObject (defCmdArgs{bang = Just True, range = Just (1, 12)})+ , ObjectBinary "7"+ , ObjectBinary "8"+ , ObjectNil+ ]++ it "should pass this test" $ do+ parseParams+ (Command (F "") (mkCommandOptions [CmdNargs "+", CmdRange WholeFile, CmdBang]))+ [ ObjectArray+ [ ObjectBinary "me"+ , ObjectBinary "up"+ , ObjectBinary "before"+ , ObjectBinary "you"+ , ObjectBinary "go"+ , ObjectBinary "go"+ ]+ , ObjectArray+ [ ObjectInt 1+ , ObjectInt 27+ ]+ , ObjectInt 0+ ]+ `shouldBe` [ toObject (defCmdArgs{bang = Just False, range = Just (1, 27)})+ , ObjectBinary "me"+ , ObjectArray+ [ ObjectBinary "up"+ , ObjectBinary "before"+ , ObjectBinary "you"+ , ObjectBinary "go"+ , ObjectBinary "go"+ ]+ ]
+ tests/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}