diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,202 @@ +Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "{}" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright {yyyy} {name of copyright owner} + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain diff --git a/TestPlugins.hs b/TestPlugins.hs new file mode 100644 --- /dev/null +++ b/TestPlugins.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE OverloadedStrings #-} +import Neovim +import Neovim.Main (realMain) +import Neovim.Plugin.Classes + +import System.Log.Logger + +-- The script `TestPlugins.vim` comments how these functions should behave. + +main :: IO () +main = realMain def + { plugins = [ randPlugin ] + } + +randPlugin :: IO NeovimPlugin +randPlugin = do + -- This plugin was intended to use a real random number generator, but + -- unfortunately a Travis build with other GHC versions failed to reproduce + -- the same numbers. So we just chose from these three numbers. You better + -- don't use this for cryptography! + let randomNumbers = cycle [42,17,-666] :: [Int16] + wrapPlugin Plugin + { exports = [ EF (Function "Randoom" Sync, randoom) + , EF (Function "Const42" Sync, const42) + , EF (Function "PingNvimhs" Sync, pingNvimhs) + ] + , statefulExports = + [((), randomNumbers, + [ EF (Function "Random" Sync, rf) + , EF (Function "InjectNumber" Sync, inj) + ]) + ] + } + +rf :: [Object] -> Neovim cfg [Int16] Object +rf _ = do + r <- gets head + modify tail + return $ ObjectInt (fromIntegral r) + +inj :: [Object] -> Neovim cfg [Int16] Object +inj [x] = case fromObject x of + Right n -> do + liftIO . debugM "TestPlugins.hs" $ "updating map" + modify (n:) + startofints <- gets (take 10) + liftIO . debugM "TestPlugins.hs" $ "Updated map to: " <> show startofints + return ObjectNil + Left _ -> liftIO (debugM "TestPlugin.hs" ("wrong argument type " ++ show x)) >> return ObjectNil +inj x = liftIO (debugM "TestPlugin.hs" ("wrong argument form " ++ show x)) >> return ObjectNil + +randoom :: [Object] -> Neovim cfg st Object +randoom _ = err "Function not supported" + +const42 :: [Object] -> Neovim cfg st Object +const42 _ = return $ ObjectInt 42 + +pingNvimhs :: [Object] -> Neovim cfg st Object +pingNvimhs _ = return $ ObjectString "Pong" diff --git a/TestPlugins.vim b/TestPlugins.vim new file mode 100644 --- /dev/null +++ b/TestPlugins.vim @@ -0,0 +1,60 @@ +" This script tests the intoroperability with all plugins defined in +" TestPlugins.hs +" +" TODO Define functions that return error messages for the assertions. +" For now, if the tests fail you should check the test log file for error +" messages (something like dist/test/nvim-hs-0.0.1-hspec.log). + +" Initialize the plugin provider +call remote#host#Register('test', "*.l\?hs", rpcstart('./nvim-hs.sh', ['test'])) +let haskellChannel = remote#host#Require('test') +" We need to issue a synchornous request to make sure that the function +" hooks are registered before we try to call them. Issueing this as late as +" possible will improve startup time because this is a blocking operation. +" TODO think about hooking into a general undefined function autocmd. +try + if "Pong" != rpcrequest(haskellChannel, 'PingNvimhs', []) + echom 'Ping function not properly registered' + cq! + endif +catch + echom 'Functions not properly registered aborting' + cq! +endtry + +if haskellChannel < 1 + echom 'Failure to initialize the haskell channel for remote procedure calls' + cq! +endif + +" The test plugin random number generator is initialized with a static seed +if Random() != 42 + echom 'Expected Value of 42 but got: ' . Random() + cq! +endif +if Random() != 17 + echom 'Expected Value of 17 but got: ' . Random() + cq! +endif +if Random() != -666 + echom 'Expected Value of -666 but got: ' . Random() + cq! +endif + +" Test notifications +call InjectNumber(7) +if Random() != 7 + echom 'Expected Value of 7 but got: ' . Random() + cq! +endif + + +let notsorandomvalue = Const42() +if notsorandomvalue != 42 + echom 'Expected the ultimate answer, but got: ' . notsorandomvalue + cq! +endif + +" Everything works, exit normally +q! + diff --git a/executable/Main.hs b/executable/Main.hs new file mode 100644 --- /dev/null +++ b/executable/Main.hs @@ -0,0 +1,17 @@ +{- | +Module : Main +Description : Main module for the haskell plugin provider +Copyright : (c) Sebastian Witte +License : Apache-2.0 + +Maintainer : woozletoff@gmail.com +Stability : experimental + +-} +module Main where + +import Data.Default +import Neovim (neovim) + +main :: IO () +main = neovim def diff --git a/library/Neovim.hs b/library/Neovim.hs new file mode 100644 --- /dev/null +++ b/library/Neovim.hs @@ -0,0 +1,485 @@ +{- | +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 enable you to write plugins. +The chapters in this module start with a tl;dr paragraph that sums things up, +which is useful to get an idea whether you should actually read the chapter and +which will reduce your reading time if you just want to refresh your memory. +-} +module Neovim ( + -- * Installation + -- ** tl;dr + -- $tldrinstallation + + -- ** Explained + -- $explainedinstallation + + -- * Tutorial + -- ** tl;dr + -- $tldrtutorial + Neovim, + Neovim', + neovim, + NeovimConfig(..), + def, + + -- ** Using existing plugins + -- $existingplugins + + -- ** Creating a plugin + -- $creatingplugins + NeovimPlugin(..), + Plugin(..), + NvimObject, + Dictionary, + Object(..), + toObject, + fromObject, + wrapPlugin, + function, + function', + command, + command', + autocmd, + Synchronous(..), + CommandOptions(..), + AutocmdOptions(..), + + -- TODO make Neovim a newtype wrapper with MonadReader and MonadState + -- implementation? + ask, + asks, + put, + get, + gets, + modify, + + -- ** Creating a stateful plugin + -- $statefulplugin + + -- ** Calling remote functions + -- $remote + wait, + wait', + waitErr, + waitErr', + err, + -- ** Generated functions for neovim interaction + module Neovim.API.String, + + -- * 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, + module Control.Applicative, + module Data.Monoid, + module Data.Int, + + ) where + +import Control.Applicative +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.Text () +import Neovim.API.String +import Neovim.API.TH (autocmd, command, command', function, + function') +import Neovim.Classes (Dictionary, NvimObject (..)) +import Neovim.Config (NeovimConfig (..)) +import Neovim.Context (Neovim, Neovim', ask, asks, err, get, + gets, modify, put) +import Neovim.Main (neovim) +import Neovim.Plugin.Classes (AutocmdOptions (..), + CommandOptions (..), + NeovimPlugin (..), Plugin (..), + Synchronous (..), wrapPlugin) +import Neovim.RPC.FunctionCall (wait, wait', waitErr, waitErr') + +-- Installation {{{1 +-- tl;dr installation {{{2 +{- $tldrinstallation + +Since this is still very volatile, I recommend using a sandbox. + +__Make sure that neovim's executable (@nvim@) is on your @\$PATH@ during the following steps!__ + +Install `nvim-hs` from git (example assumes you clone to @\$HOME\/git\/nvim-hs@) +using a sandbox: + +@ +\$ mkdir -p ~\/git ; cd ~\/git +\$ git clone https:\/\/github.com\/saep\/nvim-hs +\$ cd nvim-hs +\$ git sandbox init +\$ cabal install +@ + +Create this executable script (e.g. @\$HOME\/bin\/nvim-hs@): + +@ +\#!\/bin\/sh + +sandbox_directory=\$HOME\/git\/nvim-hs +old_pwd="`pwd`" +cd "$sandbox_directory" +env CABAL_SANDBOX_CONFIG="$sandbox_directory"\/cabal.sandbox.config cabal \\ + exec "$sandbox_directory\/.cabal-sandbox\/bin\/nvim-hs" -- "$@" +cd "$old_pwd" +@ + +Put this in your neovim config file (typically @~\/.nvimrc@ or @~\/.nvim\/nvimrc@): + +@ +if has(\'nvim\') \" This way you can also put it in your vim config file + function! s:RequireHaskellHost(name) + \" If the nvim-hs script/executable is not on your path, you should give the full path here + return rpcstart(\'nvim-hs\', [a:name.name]) + endfunction + + \" You can replace \'haskell\' in the following lines with any name you like. + call remote\#host\#Register(\'haskell\', \'*.[cl]\\?hs\', function(\'s:RequireHaskellHost\')) + \" Blocks until nvim-hs has started (optional) + call rpcrequest(remote\#host\#Require(\'haskell\'), + \\ \'PingNvimhs\', []) +endif +@ + +-} +-- 2}}} + +-- Explained {{{2 +{- $explainedinstallation + +You essentially have to follow the instructions of the tl;dr subsection above, +but this subsections tells you why you need those steps and it gives you the +required knowledge do deviate from those instructions. + +If you want to use or write plugins written in haskell for /nvim-hs/, you first +have to make sure that neovim is installed and that it is available on your +@\$PATH@ during the compilation of /nvim-hs/. Neovim emits information about its +remotely callable API if you call it with the `--api-info` argument. This output +is used to generate the API functions you desperately need to create useful +plugins. Also, some internal functionality requires some of these functions. + +The instructions to install /nvim-hs/ should be self-explanatory. In any case, I +(saep) recommend using a sandbox for now since there is no stable hackage +release yet and a few librarier are newer than what is currently in stackage +(namely mtl, which is a big deal). Using a sandbox requires you to install all +the libraries you want or have to use in your plugins to be installed inside the +sandbox! Some Vim plugins (e.g. ghc-mod) may show weird errors inside neovim for +your configuration file because the sandbox is not inside your configuration folder. +For /nvim-hs/ you don't need to worry about that, though, because it has a +builtin plugin which puts all compile-errors in the quickfix +list automatically after you save your configuration file, so you don't need +another plugin to detect compile time errors here. But we will discuss this +later in more detail. The executable script sets up the build environment for +/nvim-hs/ to use the sandbox. You should only have to adjust the path for the +`sandbox_directory` variable there if you did not install /nvim-hs/ in a sandbox +located at `\$HOME\/git\/nvim-hs`. + +The Vim-script snippet is a bit lengthy, but the comments should explain how it +works. In any case, the snippet can be put anywhere in your neovim configuration +file and the last call of `rpcrequest` is not needed if you don't call any +functionality before /nvim-hs/ has started properly. Removing the call can +improve the startup time. If you only need some functionality for haskell source +files, you could move those last (or the last two) lines at the top of +@\$HOME\/.nvim\/ftplugin\/haskell.vim@. You may wonder why we have to explicitly +call 'PingNvimhs' with the function `rpcrequest` here. The short answer is: +The internals for registering functions from a remote host require this. The +longer answer is as follows: Registering functions from a remote host does not +define a function directly. It instead installs a hook via an autocmd that +defines the function. This way, only functions that are actually used are +registered and this probably was implemented this way for performance reasons. +Buf, if we try to call a function from a remote host too early, the hooks may +not yet be in place and we receive error messages. Since we do not generate any +Vim-script files which contain those hooks, /nvim-hs/ must be started and +initialized and create those hooks. So the best way to make sure that /nvim-hs/ +is initialized is to try to call some functionon the msgpack-rpc channel that +/nvim-hs/ listens on. The function must not even exist, but not throwing an +error message is probably nicer, so /nvim-hs/ provides a function \"PingNvimhs\" +which takes no arguments and returns @\"Pong\"@. + +Using /nvim-hs/ essentially means to use a static binary that incorporates all +plugins. It is generated using the 'Dyre' library and the binary itself is found +in @\$XDG_CACHE_DIR\/nvim@ (usually @~\/.cache\/nvim). The 'Dyre' library makes +it feel more like a scripting language, because the binary is automatically +created and executed without having to restart neovim. + +-} +-- 2}}} +-- 1}}} + +-- Tutorial {{{1 +-- tl;dr {{{2 +{- $tldrgettingstarted +Create a file called @nvim.hs@ in @\$XDG_CONFIG_HOME\/nvim@ (usually +@~\/.config\/nvim@ with the following content: + +@ +\{\-\# LANGUAGE TemplateHaskell \#\-\} +import Neovim + +main = 'neovim' 'def' +@ + +Adjust the fields in @def@ according to the the parameters in 'NeovimConfig'. + +-} +-- 2}}} + +-- Existing Plugins {{{2 +{- $existingplugins +/nvim-hs/ is all about importing and creating plugins. This is done following +simple and 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 +configuration would then look like this: + +@ +\{\-\# LANGUAGE TemplateHaskell \#\-\} + +import TestPlugin.ExamplePlugin (examplePlugin) + +main = 'neovim' 'def' + { plugins = [examplePlugin] + } +@ + +That's all you have to do! Multiple plugins are simply imported and put in a +list. + +If the plugin is not packaged, you can also put the source files of the plugin +inside @\$XDG_CONFIG_HOME\/nvim\/lib@ (usually @~\/.config\/nvim\/lib@). +Assuming the same module name and plugin name, you can use the same configuration +file. The source for the plugin must be located at +@\$XDG_CONFIG_HOME\/nvim\/lib\/TestPlugin\/ExamplePlugin.hs@ and all source +files it depends on must follow the same structure. This is the standard way +how Haskell modules are defined in cabal projects. Having all plugins as source +files can increase the compilation times, so plugins should be put in a cabal +project once they are mature enough. This also makes them easy to share! + +-} +-- 2}}} +-- Creating a plugin {{{2 +{- $creatingplugins +Creating plugins isn't difficult either. You just have to follow a simple API +and not be surprised about 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, we must define +our functions in a different module than @\$XDG_CONFIG_HOME\/nvim\/nvim.hs@. +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\/MyFirstPlugin.hs@ + +@ +module MyFirstPlugin + ( fibonacci + ) where + +import Neovim + +fibonacci :: 'Int' -> Neovim' 'String' +fibonacci n = 'show' $ fibs !! n + where + fibs :: ['Integer'] + fibs = 1:1:'scanl1' (+) fibs +@ + +File @~\/.config\/nvim\/nvim.hs@: + +@ +\{\-\# LANGUAGE TemplateHaskell \#\-\} + +import MyFirstPlugin (fibonacci) + +fibonacciPlugin = 'wrapPlugin' + { 'exports' = [ $('function'' 'fibonacci) 'Sync' ] + } + +main = 'neovim' 'def' + { 'plugins' = [fibonacciPlugin] + } +@ + +Let's analyze how it works. The module @MyFirstPlugin@ 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' r st 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 @fibonacciPlugin@ +in @~\/.config\/nvim\/nvim.hs@, shows what a plugin is. It is essentially two +lists of stateless and stateful functionality. A functionality can currently be one +of three things: a function, a command and an autocmd in the context of vim +terminology. In the end, all of those functionalities map to a function at the side +of /nvim-hs/. If you really want to know what the distinction between those, 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 distinction +between __stateful__ and __stateless__. A stateless function can be called at any +time and it does not share any of its internals with other functions. A stateful +function on the other hand can share a well-defined amount of state with other +functions and in the next section I will show you a simple example for that. +Anyhow, if you take a look at the type alias for 'Neovim', you notice the two +type variables @r@ and @st@. These can be accessed with different semantics +each. A value of type @r@ can only be read. It is more or less a static value +you can query with 'ask' or 'asks' if you +are inside a 'Neovim' environment. The value @st@ can be changed and those +changes will be available to other functions which run in the same environment. +You can get the current value with 'get', you can replace an existing value with +'put' and you can also apply a function to the current state with 'modify'. +Notice how 'Neovim'' is just a specialization of 'Neovim' with its @r@ and +@st@ set to @()@. + +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 from of function names that are passed in a splice. + +If you compile this (which should happen automatically if you have put those +files at the appropriate places), you can calculate the 287323rd Fibonacci number +like this: + +@ +:echo Fibonacci(287323) +@ + +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: + +@ +\=Fibonacci(287323) +@ + +-} +-- 2}}} +-- Creating a stateful plugin {{{2 +{- $remote +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\/MyRandomNumberGenerator.hs@: + +@ +module MyRandomNumberGenerator + ( nextRand + , setNextNumber + ) where + +nextRand :: 'Neovim' r ['Int16'] Int16 +nextRand = do + r <- gets head + modify tail + return r + +setNextNumber :: Int16 -> 'Neovim' r ['Int16'] () +setNextNumber n = modify (n:) +@ + +File @~\/.config\/nvim\/nvim.hs@: + +@ +\{\-\# LANGUAGE TemplateHaskell \#\-\} + +import MyRandomNumberGenerator (nextRand, setNextNumber) +import System.Random (newStdGen, randoms) + +randPlugin = do + g <- newStdGen -- initialize with a random seed + let randomNumbers = randoms g -- an infite list of random numbers + 'wrapPlugin' + { 'statefulExports' = + [ ((), randomNumbers, + [ $('function'' 'nextRand) 'Sync' + , $('function'' 'setNextNumber) 'Async' + ]) + ] + } + +main = 'neovim' 'def' + { 'plugins' = [randPlugin] + } +@ + +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. The only slightly tedious thing was to define the 'statefulExpors' +field because it is a list of triples which has a list of exported functionality +as its third argument. + +-} +-- 2}}} +-- Calling remote functions {{{2 +{- $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' r st () +inspectBuffer = do + cb <- 'vim_get_current_buffer' + isValid <- 'buffer_is_valid' cb + when isValid $ do + let newName = "magic" + retval <- 'wait'' $ 'buffer_set_name' cb newName + case retval of + Right cbName | cbName == newName -> 'return' () + Right _ -> 'err' $ "Renaming the current buffer failed!" + Left e -> 'err' $ 'show' e +@ + +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. Since it is not unusual to +not know what to do if the remote function call failed, the functions 'waitErr' +and 'waitErr'' can save you from some typing and deeply nested case expressions. + +That's pretty much all there is to it. +-} +-- 2}}} +-- 1}}} + +-- vim: foldmethod=marker diff --git a/library/Neovim/API/Parser.hs b/library/Neovim/API/Parser.hs new file mode 100644 --- /dev/null +++ b/library/Neovim/API/Parser.hs @@ -0,0 +1,192 @@ +{-# LANGUAGE OverloadedStrings #-} +{- | +Module : Neovim.API.Parser +Description : 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 Control.Applicative +import Control.Exception.Lifted +import Control.Monad.Except +import qualified Data.ByteString as B +import qualified Data.ByteString.UTF8 as U +import Data.Map (Map) +import qualified Data.Map as Map +import Data.MessagePack +import Data.Monoid +import Data.Serialize +import System.IO (hClose) +import System.Process +import Text.Parsec as P + +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 + { name :: String + -- ^ function name + , parameters :: [(NeovimType, String)] + -- ^ A list of type name and variable name. + , canFail :: Bool + -- ^ Indicator whether the function can fail/throws exceptions. + , deferred :: Bool + -- ^ Indicator whether the this function is asynchronous. + , returnType :: NeovimType + -- ^ Functions return type. + } + deriving (Show) + +-- | This data type represents the top-level structure of the @nvim --api-info@ +-- output. +data NeovimAPI + = NeovimAPI + { errorTypes :: [(String, Int64)] + -- ^ The error types are defined by a name and an identifier. + , customTypes :: [(String, Int64)] + -- ^ Extension types defined by neovim. + , functions :: [NeovimFunction] + -- ^ The remotely executable functions provided by the neovim api. + } + deriving (Show) + +-- | Run @nvim --api-info@ and parse its output. +parseAPI :: IO (Either String NeovimAPI) +parseAPI = join . fmap (runExcept . extractAPI) <$> runExceptT decodeAPI + +extractAPI :: Object -> Except String NeovimAPI +extractAPI apiObj = NeovimAPI + <$> extractErrorTypes apiObj + <*> extractCustomTypes apiObj + <*> extractFunctions apiObj + +decodeAPI :: ExceptT String IO Object +decodeAPI = bracket queryNeovimAPI clean $ \(out, _) -> + either throwError return =<< decode <$> lift (B.hGetContents out) + + where + queryNeovimAPI = do + (_, Just out, _, ph) <- lift . createProcess $ + (proc "nvim" ["--api-info"]) { std_out = CreatePipe } + return (out, ph) + + clean (out, ph) = lift $ do + hClose out + terminateProcess ph + +oMap :: Object -> Except String (Map Object Object) +oMap o = case o of + ObjectMap m -> return m + _ -> throwError $ "Object is not a map: " ++ show o + +oLookup :: Object -> Object -> Except String Object +oLookup qry o = oMap o + >>= maybe (throwError ("No entry for" <> show qry)) return + . Map.lookup qry + +oLookupDefault :: Object -> Object -> Object -> Except String Object +oLookupDefault d qry o = oMap o + >>= maybe (return d) return . Map.lookup qry + +-- | Extract a 'String' from on 'Object'. +-- +-- Works on @ObjectBinary@ and @ObjectString@ constructor. +oToString :: Object -> Except String String +oToString o = case o of + ObjectBinary bs -> return $ U.toString bs + ObjectString t -> return $ U.toString t + _ -> throwError $ show o <> " is not convertible to a String." + +-- | Extract an 'Int64' from an @Object@. +-- +oInt :: Object -> Except String Int64 +oInt o = case o of + ObjectInt i -> return i + _ -> throwError $ show o <> " is not an Int64." + +oArr :: Object -> Except String [Object] +oArr o = case o of + ObjectArray os -> return os + _ -> throwError $ show o <> " is not an Array." + +oToBool :: Object -> Except String Bool +oToBool o = case o of + ObjectBool b -> return b + _ -> throwError $ show o <> " is not a boolean." + +extractErrorTypes :: Object -> Except String [(String, Int64)] +extractErrorTypes objAPI = + extractTypeNameAndID =<< oLookup (ObjectBinary "error_types") objAPI + +extractTypeNameAndID :: Object -> Except String [(String, Int64)] +extractTypeNameAndID m = do + types <- Map.toList <$> oMap m + forM types $ \(errName, idMap) -> do + n <- oToString errName + i <- oInt =<< oLookup (ObjectBinary "id") idMap + return (n,i) + +extractCustomTypes :: Object -> Except String [(String, Int64)] +extractCustomTypes objAPI = + extractTypeNameAndID =<< oLookup (ObjectBinary "types") objAPI + +extractFunctions :: Object -> Except String [NeovimFunction] +extractFunctions objAPI = do + funList <- oArr =<< oLookup (ObjectBinary "functions") objAPI + forM funList extractFunction + +toParameterlist :: [Object] -> Except String [(NeovimType, String)] +toParameterlist ps = forM ps $ \p -> do + [t, n] <- mapM oToString =<< oArr p + t' <- parseType t + return (t', n) + +extractFunction :: Object -> Except String NeovimFunction +extractFunction funDefMap = NeovimFunction + <$> (oLookup (ObjectBinary "name") funDefMap >>= oToString) + <*> (oLookup (ObjectBinary "parameters") funDefMap + >>= oArr >>= toParameterlist) + <*> (oLookupDefault (ObjectBool False) (ObjectBinary "can_fail") funDefMap + >>= oToBool) + <*> (oLookup (ObjectBinary "deferred") funDefMap >>= oToBool) + <*> (oLookup (ObjectBinary "return_type") funDefMap + >>= oToString >>= parseType) + +parseType :: String -> Except String NeovimType +parseType s = either (throwError . show) return $ parse (pType <* eof) s s + +pType :: Parsec String u NeovimType +pType = pArray P.<|> pVoid P.<|> pSimple + +pVoid :: Parsec String u NeovimType +pVoid = const Void <$> (P.try (string "void") <* eof) + +pSimple :: Parsec String u NeovimType +pSimple = SimpleType <$> many1 (noneOf ",)") + +pArray :: Parsec String u NeovimType +pArray = NestedType <$> (P.try (string "ArrayOf(") *> pType) + <*> optionMaybe pNum <* char ')' + +pNum :: Parsec String u Int +pNum = read <$> (P.try (char ',') *> spaces *> many1 (oneOf ['0'..'9'])) + diff --git a/library/Neovim/API/String.hs b/library/Neovim/API/String.hs new file mode 100644 --- /dev/null +++ b/library/Neovim/API/String.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} +{- | +Module : Neovim.API.String +Description : String based API +Copyright : (c) Sebastian Witte +License : Apache-2.0 + +Maintainer : woozletoff@gmail.com +Stability : experimental + +-} +module Neovim.API.String + where + +import Neovim.API.TH + +$(generateAPI defaultAPITypeToHaskellTypeMap) + diff --git a/library/Neovim/API/TH.hs b/library/Neovim/API/TH.hs new file mode 100644 --- /dev/null +++ b/library/Neovim/API/TH.hs @@ -0,0 +1,366 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# 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 + , defaultAPITypeToHaskellTypeMap + , module Control.Exception.Lifted + , module Neovim.Classes + , module Data.Data + , module Data.MessagePack + ) where + +import Neovim.API.Parser +import Neovim.Classes +import Neovim.Context +import Neovim.Plugin.Classes (CommandOptions (..), + ExportedFunctionality (..), + FunctionalityDescription (..)) +import Neovim.RPC.FunctionCall + +import Language.Haskell.TH + +import Control.Applicative +import Control.Arrow +import Control.Concurrent.STM (STM) +import Control.Exception +import Control.Exception.Lifted +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 Data.Text (pack) + +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 :: Map String (Q Type) -> Q [Dec] +generateAPI typeMap = do + api <- either fail return =<< runIO parseAPI + let exceptionName = mkName "NeovimExceptionGen" + exceptions = (\(n,i) -> (mkName ("Neovim" <> n), i)) <$> errorTypes api + customTypesN = first mkName <$> customTypes api + join <$> sequence + [ fmap return . createDataTypeWithByteStringComponent exceptionName $ fst <$> exceptions + , exceptionInstance exceptionName + , customTypeInstance exceptionName exceptions + , mapM (\n -> createDataTypeWithByteStringComponent n [n]) $ fst <$> customTypesN + , join <$> mapM (\(n,i) -> customTypeInstance n [(n,i)]) customTypesN + , fmap join . mapM (createFunction typeMap) $ functions api + ] + + +-- | Default type mappings for the requested API. +defaultAPITypeToHaskellTypeMap :: Map String (Q Type) +defaultAPITypeToHaskellTypeMap = Map.fromList + [ ("Boolean" , [t|Bool|]) + , ("Integer" , [t|Int64|]) + , ("Float" , [t|Double|]) + , ("Array" , [t|[Object]|]) + , ("Dictionary", [t|Map Object Object|]) + , ("void" , [t|()|]) + ] + + +apiTypeToHaskellType :: Map String (Q Type) -> NeovimType -> Q Type +apiTypeToHaskellType typeMap at = case at of + Void -> [t|()|] + NestedType t Nothing -> + appT listT $ 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 typeMap + + +-- | 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 :: Map String (Q Type) -> NeovimFunction -> Q [Dec] +createFunction typeMap nf = do + let withDeferred | deferred nf = appT [t|STM|] + | otherwise = id + withException | canFail nf = appT [t|Either Object|] + | otherwise = id + + callFn | deferred nf && canFail nf = [|acall|] + | deferred nf = [|acall'|] + | canFail nf = [|scall|] + | otherwise = [|scall'|] + + functionName = (mkName . name) nf + toObjVar v = [|toObject $(varE v)|] + + + ret <- let (r,st) = (mkName "r", mkName "st") + in forallT [PlainTV r, PlainTV st] (return []) + . appT ([t|Neovim $(varT r) $(varT st) |]) + . withDeferred . withException + . apiTypeToHaskellType typeMap $ returnType nf + + vars <- mapM (\(t,n) -> (,) <$> apiTypeToHaskellType typeMap t + <*> newName n) + $ parameters nf + sequence + [ sigD functionName . return + . foldr (AppT . AppT ArrowT) ret $ map fst vars + , funD functionName + [ clause + (map (varP . snd) vars) + (normalB (callFn + `appE` ([| 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|] + dataD + (return []) + nme + [] + (map (\n-> normalC n [return (IsStrict, tObject)]) cs) + (mkName <$> ["Typeable", "Eq", "Show"]) + + +-- | If the first parameter is @mkName NeovimException@, this function will +-- generate @instance Exception NeovimException"@. +exceptionInstance :: Name -> Q [Dec] +exceptionInstance exceptionName = return <$> + instanceD + (return []) + ([t|Exception|] `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 = + let fromObjectClause :: Name -> Int64 -> Q Clause + fromObjectClause n i = newName "bs" >>= \bs -> + clause + [ conP (mkName "ObjectExt") + [(litP . integerL . fromIntegral) i,varP bs] + ] + (normalB [|return $ $(conE n) $(varE bs)|]) + [] + fromObjectErrorClause :: Q Clause + fromObjectErrorClause = do + o <- newName "o" + let n = nameBase typeName + clause + [ varP o ] + (normalB [|Left $ "Object is not convertible to: " <> n <> " Received: " <> show $(varE o)|]) + [] + + toObjectClause :: Name -> Int64 -> Q Clause + toObjectClause n i = newName "bs" >>= \bs -> + clause + [conP n [varP bs]] + (normalB [|ObjectExt $((litE . integerL . fromIntegral) i) $(varE bs)|]) + [] + + in return <$> instanceD + (return []) + ([t|NvimObject|] `appT` conT typeName) + [ funD (mkName "toObject") $ map (uncurry toObjectClause) nis + , funD (mkName "fromObject") + $ map (uncurry fromObjectClause) nis + <> [fromObjectErrorClause] + ] + + +-- | Define an exported function by providing a cutom name and referencing the +-- function you want to export. +-- +-- Note that the name must start with an upper case letter. +-- +-- Example: @ $(function "MyExportedFunction" 'myDefinedFunction) def @ +function :: String -> Name -> Q Exp +function [] _ = error "Empty names are not allowed for exported functions." +function customName@(c:_) functionName + | (not . isUpper) c = error $ "Custom function name must start with a capiatl letter: " <> show customName + | otherwise = do + (_, fun) <- functionImplementation functionName + [|\funOpts -> EF (Function (pack $(litE (StringL customName))) funOpts, $(return fun)) |] + + +-- | 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 = + let (c:cs) = nameBase functionName + in function (toUpper c:cs) functionName + + +-- | 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. +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 capiatl letter: " <> show customFunctionName + | otherwise = do + (nargs, fun) <- functionImplementation functionName + [|\copts -> EF (Command (pack $(litE (StringL customFunctionName))) (copts { cmdNargs = nargs }), $(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 = + let (c:cs) = nameBase functionName + in command (toUpper c:cs) functionName + + +-- | Define an autocmd. 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 functions and pass it as an arguments. +autocmd :: Name -> Q Exp +autocmd functionName = + let (c:cs) = nameBase functionName + in do + (_, fun) <- functionImplementation functionName + [|\t acmdOpts -> EF (Autocmd t (pack $(litE (StringL (toUpper c : cs)))) acmdOpts, $(return fun))|] + + +-- | 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 (Int, Exp) +functionImplementation functionName = do + fInfo <- reify functionName + -- We only need the number of arguments to generate the appropriate function + let nargs = 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 -> Int + determineNumberOfArguments ft = case ft of + ForallT _ _ t -> determineNumberOfArguments t + AppT (AppT ArrowT _) r -> 1 + determineNumberOfArguments r + _ -> 0 + -- \args -> case args of ... + topLevelCase :: Int -> Q Exp + topLevelCase n = newName "args" >>= \args -> + lamE [varP args] (caseE (varE args) [matchingCase n, errorCase]) + + -- _ -> err "Wrong number of arguments" + errorCase :: Q Match + errorCase = match wildP + (normalB [|err $ "Wrong number of arguments for function: " + ++ $(litE (StringL (nameBase functionName))) |]) [] + + -- [x,y] -> case pure add <*> fromObject x <*> fromObject y of ... + matchingCase :: Int -> Q Match + matchingCase n = mapM (\_ -> newName "x") [1..n] >>= \vars -> + match (listP (map varP vars)) + (normalB + (caseE + (foldl genArgumentCast [|pure $(varE functionName)|] + (zip vars (repeat [|(<*>)|]))) + [successfulEvaluation, failedEvaluation])) + [] + + genArgumentCast :: Q Exp -> (Name, Q Exp) -> Q Exp + genArgumentCast e (v,op) = infixE (Just e) op (Just [|fromObject $(varE v)|]) + + successfulEvaluation :: Q Match + successfulEvaluation = newName "action" >>= \action -> + match (conP (mkName "Right") [varP action]) + (normalB [|toObject <$> $(varE action)|]) + [] + failedEvaluation :: Q Match + failedEvaluation = newName "e" >>= \e -> + match (conP (mkName "Left") [varP e]) + (normalB [|err $(varE e)|]) + [] + diff --git a/library/Neovim/Classes.hs b/library/Neovim/Classes.hs new file mode 100644 --- /dev/null +++ b/library/Neovim/Classes.hs @@ -0,0 +1,256 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverlappingInstances #-} +{-# 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 + + , module Data.Int + ) where + +import Neovim.Context + +import Control.Applicative +import Control.Arrow +import Control.Monad.Except +import Data.ByteString (ByteString) +import Data.Int (Int16, Int32, Int64) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.MessagePack +import Data.Monoid +import Data.Text as Text (Text) +import Data.Traversable hiding (forM, mapM) + +import Prelude + +-- FIXME saep 2014-11-28 Is assuming UTF-8 reasonable? +import qualified Data.ByteString.UTF8 as U (fromString, toString) +import Data.Text.Encoding (decodeUtf8, encodeUtf8) + + +-- | 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 = Map ByteString Object + + +-- | Conversion from 'Object' files to Haskell types and back with respect +-- to neovim's interpretation. +class NvimObject o where + toObject :: o -> Object + fromObjectUnsafe :: Object -> o + fromObjectUnsafe o = case fromObject o of + Left e -> error $ unwords + [ "Not the expected object:" + , show o , "(", e, ")" + ] + Right obj -> obj + fromObject :: (NvimObject o) => Object -> Either String o + fromObject = return . fromObjectUnsafe + +-- Instances for NvimObject {{{1 +instance NvimObject () where + toObject _ = ObjectNil + fromObject ObjectNil = return () + fromObject o = throwError $ "Expected ObjectNil, but got " <> show 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 ObjectNil = 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 o = throwError $ "Expected ObjectDouble, but got " <> show o + +instance NvimObject Integer where + toObject = ObjectInt . fromIntegral + fromObject (ObjectInt o) = return $ toInteger o + fromObject (ObjectDouble o) = return $ round o + fromObject (ObjectFloat o) = return $ round o + fromObject o = throwError $ "Expected ObjectInt, but got " <> show o + +instance NvimObject Int64 where + toObject = ObjectInt + fromObject (ObjectInt i) = return i + fromObject (ObjectDouble o) = return $ round o + fromObject (ObjectFloat o) = return $ round o + fromObject o = throwError $ "Expected any Integer value, but got " <> show o + +instance NvimObject Int32 where + toObject = ObjectInt . fromIntegral + fromObject (ObjectInt 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 " <> show o + +instance NvimObject Int16 where + toObject = ObjectInt . fromIntegral + fromObject (ObjectInt 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 " <> show o + +instance NvimObject Int where + toObject = ObjectInt . fromIntegral + fromObject (ObjectInt 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 " <> show o + +instance NvimObject Char where + toObject c = ObjectBinary . U.fromString $ [c] + fromObject str = case fromObject str of + Right [c] -> return c + _ -> throwError $ "Expected one element string but got: " <> show str + +instance NvimObject [Char] where + toObject = ObjectBinary . U.fromString + fromObject (ObjectBinary o) = return $ U.toString o + fromObject (ObjectString o) = return $ U.toString o + fromObject o = throwError $ "Expected ObjectBinary, but got " <> show o + +instance NvimObject o => NvimObject [o] where + toObject = ObjectArray . map toObject + fromObject (ObjectArray os) = return $ map fromObjectUnsafe os + fromObject o = throwError $ "Expected ObjectArray, but got " <> show 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 (Ord key, NvimObject key, NvimObject val) + => NvimObject (Map key val) where + toObject = ObjectMap + . Map.fromList . map (toObject *** toObject) . Map.toList + fromObject (ObjectMap om) = Map.fromList <$> + (sequenceA + . map (uncurry (liftA2 (,)) + . (fromObject *** fromObject)) + . Map.toList) om + + fromObject o = throwError $ "Expected ObjectMap, but got " <> show 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 " <> show o + +instance NvimObject ByteString where + toObject = ObjectBinary + fromObject (ObjectBinary o) = return o + fromObject o = throwError $ "Expected ObjectBinary, but got " <> show o + +instance NvimObject Object where + toObject = id + fromObject = return + fromObjectUnsafe = id + +-- By the magic of vim, i will create these. +instance NvimObject o => NvimObject (o, o) where + toObject (o1, o2) = ObjectArray $ map toObject [o1, o2] + fromObject (ObjectArray [o1, o2]) = (,) + <$> fromObject o1 + <*> fromObject o2 + fromObject o = throwError $ "Expected ObjectArray, but got " <> show o + +instance NvimObject o => NvimObject (o, o, o) where + toObject (o1, o2, o3) = ObjectArray $ map toObject [o1, o2, o3] + fromObject (ObjectArray [o1, o2, o3]) = (,,) + <$> fromObject o1 + <*> fromObject o2 + <*> fromObject o3 + fromObject o = throwError $ "Expected ObjectArray, but got " <> show o + +instance NvimObject o => NvimObject (o, o, o, o) where + toObject (o1, o2, o3, o4) = ObjectArray $ map toObject [o1, o2, o3, o4] + fromObject (ObjectArray [o1, o2, o3, o4]) = (,,,) + <$> fromObject o1 + <*> fromObject o2 + <*> fromObject o3 + <*> fromObject o4 + fromObject o = throwError $ "Expected ObjectArray, but got " <> show o + +instance NvimObject o => NvimObject (o, o, o, o, o) where + toObject (o1, o2, o3, o4, o5) = ObjectArray $ map toObject [o1, o2, o3, o4, 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 " <> show o + +instance NvimObject o => NvimObject (o, o, o, o, o, o) where + toObject (o1, o2, o3, o4, o5, o6) = ObjectArray $ map toObject [o1, o2, o3, o4, o5, 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 " <> show o + +instance NvimObject o => NvimObject (o, o, o, o, o, o, o) where + toObject (o1, o2, o3, o4, o5, o6, o7) = ObjectArray $ map toObject [o1, o2, o3, o4, o5, o6, 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 " <> show o + +instance NvimObject o => NvimObject (o, o, o, o, o, o, o, o) where + toObject (o1, o2, o3, o4, o5, o6, o7, o8) = ObjectArray $ map toObject [o1, o2, o3, o4, o5, o6, o7, 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 " <> show o + +instance NvimObject o => NvimObject (o, o, o, o, o, o, o, o, o) where + toObject (o1, o2, o3, o4, o5, o6, o7, o8, o9) = ObjectArray $ map toObject [o1, o2, o3, o4, o5, o6, o7, o8, 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 " <> show o + +-- 1}}} diff --git a/library/Neovim/Config.hs b/library/Neovim/Config.hs new file mode 100644 --- /dev/null +++ b/library/Neovim/Config.hs @@ -0,0 +1,44 @@ +{- | +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 Data.Default, + module System.Log, + ) where + +import Neovim.Plugin.Classes (NeovimPlugin) + +import qualified Config.Dyre as Dyre +import Data.Default (Default (def)) +import System.Log (Priority (..)) + +data NeovimConfig = Config + { plugins :: [IO NeovimPlugin] + -- ^ 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'. + , errorMessage :: Maybe String + -- ^ Used by 'Dyre' for storing compilation errors. + , logOptions :: Maybe (FilePath, Priority) + -- ^ Set the general logging options. + , dyreParams :: Maybe (Dyre.Params NeovimConfig) + -- ^ Parmaeters used by 'Dyre'. This is only used for the + -- "Neovim.Plugin.ConfigHelper" plugin. + } + +instance Default NeovimConfig where + def = Config + { plugins = [] + , errorMessage = Nothing + , logOptions = Nothing + , dyreParams = Nothing + } + diff --git a/library/Neovim/Context.hs b/library/Neovim/Context.hs new file mode 100644 --- /dev/null +++ b/library/Neovim/Context.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# 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 ( + asks, + ask, + eventQueue, + + get, + put, + modify, + gets, + + Neovim, + Neovim', + NeovimException(..), + ConfigWrapper(..), + runNeovim, + forkNeovim, + err, + restart, + quit, + QuitAction(..), + + throwError, + module Control.Monad.IO.Class, + ) where + + +import Control.Concurrent (MVar, ThreadId, forkIO, putMVar) +import Control.Concurrent.STM +import Control.Exception +import Control.Monad.Except +import Control.Monad.IO.Class +import Control.Monad.Reader hiding (ask, asks) +import qualified Control.Monad.Reader as R +import Control.Monad.State +import Data.Data (Typeable) +import Neovim.Plugin.IPC (SomeMessage) +import System.Log.Logger + + +-- | A wrapper for a reader value that contains extra fields required to +-- communicate with the messagepack-rpc components. +data ConfigWrapper a = ConfigWrapper + { _eventQueue :: TQueue SomeMessage + -- ^ A queue of messages that the event handler will propagate to + -- appropriate threads and handlers. + , _quit :: MVar QuitAction + -- ^ 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 + -- 'QuitAction'. + , _providerName :: String + -- ^ Name that is used to identify this provider. Assigning such a name is + -- done in the neovim config (e.g. ~\/.nvim\/nvimrc). + , customConfig :: a + -- ^ Plugin author supplyable custom configuration. It can be queried via + -- 'myConf'. + } + + +data QuitAction = Quit + -- ^ Quit the plugin provider. + | Restart + -- ^ Restart the plugin provider. + deriving (Show, Read, Eq, Ord, Enum, Bounded) + + +eventQueue :: Neovim r st (TQueue SomeMessage) +eventQueue = R.asks _eventQueue + + +-- | This is the environment in which all plugins are initially started. +-- Stateless functions use '()' for the static configuration and the mutable +-- state and there is another type alias for that case: 'Neovim''. +-- +-- 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. +type Neovim r st = StateT st (ReaderT (ConfigWrapper r) IO) + + +-- | Convenience alias for @'Neovim' () ()@. +type Neovim' = Neovim () () + + +-- | Initialize a 'Neovim' context by supplying an 'InternalEnvironment'. +runNeovim :: ConfigWrapper r + -> st + -> Neovim r st a + -> IO (Either String (a, st)) +runNeovim r st a = (try . runReaderT (runStateT a st)) r >>= \case + Left e -> do + liftIO . errorM "Context" $ "Converting Exception to Error message: " ++ show e + return . Left $ show (e :: SomeException) + Right res -> return $ Right res + + +-- | Fork a neovim thread with the given custom config value and a custom +-- state. The result of the thread is discarded and only the 'ThreadId' is +-- returend immediately. +forkNeovim :: ir -> ist -> Neovim ir ist a -> Neovim r st ThreadId +forkNeovim r st a = do + cfg <- R.ask + liftIO . forkIO . void $ runNeovim (cfg { customConfig = r }) st a + + +data NeovimException + = ErrorMessage String + deriving (Typeable, Show) + +instance Exception NeovimException + + +-- | @throw . ErrorMessage@ +err :: String -> Neovim r st a +err = throw . ErrorMessage + + +-- | Retrieve something from the configuration with respect to the first +-- function. Works exactly like 'R.asks'. +asks :: (r -> a) -> Neovim r st a +asks q = R.asks (q . customConfig) + + +-- | Retrieve the Cunfiguration (i.e. read-only state) from the 'Neovim' +-- context. +ask :: Neovim r st r +ask = R.asks customConfig + + +-- | Initiate a restart of the plugin provider. +restart :: Neovim r st () +restart = liftIO . flip putMVar Restart =<< R.asks _quit + + +-- | Initiate the termination of the plugin provider. +quit :: Neovim r st () +quit = liftIO . flip putMVar Quit =<< R.asks _quit + diff --git a/library/Neovim/Debug.hs b/library/Neovim/Debug.hs new file mode 100644 --- /dev/null +++ b/library/Neovim/Debug.hs @@ -0,0 +1,56 @@ +{- | +Module : Neovim.Debug +Description : Debugging facilities +Copyright : (c) Sebastian Witte +License : Apache-2.0 + +Maintainer : woozletoff@gmail.com +Stability : experimental + +-} +module Neovim.Debug ( + 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' diff --git a/library/Neovim/Main.hs b/library/Neovim/Main.hs new file mode 100644 --- /dev/null +++ b/library/Neovim/Main.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE LambdaCase #-} +{- | +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 Neovim.Plugin as P +import qualified Neovim.Plugin.ConfigHelper as ConfigHelper + +import qualified Config.Dyre as Dyre +import qualified Config.Dyre.Relaunch as Dyre +import Control.Concurrent +import Control.Concurrent.STM +import Data.Monoid +import Neovim.Context +import Neovim.Debug +import Neovim.RPC.Common as RPC +import Neovim.RPC.EventHandler +import Neovim.RPC.SocketReader +import Options.Applicative +import System.IO (stdin, stdout) + +data CommandLineOptions = + Opt { providerName :: String + , hostPort :: Maybe (String, Int) + , unix :: Maybe FilePath + , env :: Bool + , logOpts :: Maybe (FilePath, Priority) + } + +optParser :: Parser CommandLineOptions +optParser = Opt + <$> strArgument + (metavar "NAME" + <> help "Name that associates the plugin provider with neovim") + <*> 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_LISTEN_ADDRESS.") + <*> 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 the "Config.Dyre" for the configuration.. +neovim :: NeovimConfig -> IO () +neovim conf = + let params = Dyre.defaultParams + { Dyre.showError = \cfg errM -> cfg { errorMessage = Just errM } + , Dyre.projectName = "nvim" + , Dyre.realMain = realMain + , Dyre.statusOut = debugM "Dyre" + , Dyre.ghcOpts = ["-threaded", "-rtsopts", "-with-rtsopts=-N"] + } + in Dyre.wrapMain params (conf { dyreParams = Just params }) + +realMain :: NeovimConfig -> IO () +realMain cfg = do + os <- execParser opts + maybe disableLogger (uncurry withLogger) (logOpts os <|> logOptions cfg) $ do + logM "Neovim.Main" DEBUG "Starting up neovim haskell plguin provider" + runPluginProvider os cfg + +runPluginProvider :: CommandLineOptions -> NeovimConfig -> IO () +runPluginProvider os = case (hostPort os, unix os) of + (Just (h,p), _) -> let s = TCP p h in run s s + (_, Just fp) -> let s = UnixSocket fp in run s s + _ | env os -> run Environment Environment + _ -> run (Stdout stdout) (Stdout stdin) + + where + run evHandlerSocket sockreaderSocket cfg = do + rpcConfig <- newRPCConfig + q <- newTQueueIO + quitter <- newEmptyMVar + let conf = ConfigWrapper q quitter (providerName os) () + allPlugins = maybe id ((:) . ConfigHelper.plugin) (dyreParams cfg) $ plugins cfg + startPluginThreads (conf { customConfig = RPC.functions rpcConfig }) allPlugins >>= \case + Left e -> errorM "Neovim.Main" $ "Error initializing plugins: " <> e + Right pluginTidsWithQueues -> do + let rpcEnv = conf { customConfig = rpcConfig } + ehTid <- forkIO $ runEventHandler evHandlerSocket rpcEnv + _ <- forkIO $ register (conf { customConfig = RPC.functions rpcConfig }) pluginTidsWithQueues + let pluginTids = concatMap (map fst . snd) pluginTidsWithQueues + rTid <- forkIO $ runSocketReader sockreaderSocket rpcEnv + debugM "Neovim.Main" "Waiting for threads to finish." + finish (rTid:ehTid:pluginTids) =<< readMVar quitter + +finish :: [ThreadId] -> QuitAction -> IO () +finish threads = \case + Restart -> do + debugM "Neovim.Main" "Trying to restart nvim-hs" + mapM_ killThread threads + Dyre.relaunchMaster Nothing + Quit -> return () diff --git a/library/Neovim/Plugin.hs b/library/Neovim/Plugin.hs new file mode 100644 --- /dev/null +++ b/library/Neovim/Plugin.hs @@ -0,0 +1,141 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} +{- | +Module : Neovim.Plugin +Description : +Copyright : (c) Sebastian Witte +License : Apache-2.0 + +Maintainer : woozletoff@gmail.com +Stability : experimental +Portability : GHC + +-} +module Neovim.Plugin ( + startPluginThreads, + register, + wrapPlugin, + NeovimPlugin, + Plugin(..), + Synchronous(..), + CommandOptions(..), + ) where + +import Neovim.API.String +import Neovim.Classes +import Neovim.Context +import Neovim.Plugin.Classes +import Neovim.Plugin.IPC +import Neovim.Plugin.IPC.Internal +import Neovim.RPC.Common +import Neovim.RPC.FunctionCall + +import Control.Arrow (first, (&&&)) +import Control.Concurrent (ThreadId) +import Control.Concurrent.STM +import Control.Exception.Lifted (SomeException, try) +import Control.Monad (foldM, forM, void) +import qualified Control.Monad.Reader as R +import Data.ByteString (ByteString) +import Data.Foldable (forM_) +import qualified Data.Map as Map +import Data.MessagePack +import Data.Text (unpack) +import System.Log.Logger + +logger :: String +logger = "Neovim.Plugin" + +startPluginThreads :: ConfigWrapper r + -> [IO NeovimPlugin] + -> IO (Either String [(NeovimPlugin, [(ThreadId, [(FunctionalityDescription, FunctionType)])])]) +startPluginThreads cfg = fmap (fmap fst) . runNeovim cfg () . foldM go [] + where + go :: [(NeovimPlugin, [(ThreadId, [(FunctionalityDescription, FunctionType)])])] + -> IO NeovimPlugin + -> Neovim r () [(NeovimPlugin, [(ThreadId, [(FunctionalityDescription, FunctionType)])])] + go pluginThreads iop = do + NeovimPlugin p <- liftIO iop + tids <- mapM registerStatefulFunctionality (statefulExports p) + return $ (NeovimPlugin p, tids) : pluginThreads + +register :: ConfigWrapper (TMVar FunctionMap) + -> [(NeovimPlugin, [(ThreadId, [(FunctionalityDescription, FunctionType)])])] + -> IO () +register (cfg@ConfigWrapper{ customConfig = sem }) ps = void . runNeovim cfg () $ do + registeredFunctions <- forM ps $ \(NeovimPlugin p, fs) -> do + let statefulFunctionsToRegister = concatMap snd fs + statelessFunctionsToRegister = + map (getDescription &&& Stateless . getFunction) $ exports p + functionsToRegister = statefulFunctionsToRegister ++ statelessFunctionsToRegister + mapM_ (registerWithNeovim . fst) functionsToRegister + return $ map (first name) functionsToRegister + liftIO . atomically . putTMVar sem . Map.fromList $ concat registeredFunctions + +registerWithNeovim :: FunctionalityDescription -> Neovim customConfig () () +registerWithNeovim = \case + Function functionName s -> do + pName <- R.asks _providerName + ret <- wait $ vim_call_function "remote#define#FunctionOnHost" + [ toObject pName, toObject functionName, toObject s + , toObject functionName, toObject (Map.empty :: Map.Map ByteString Object) + ] + case ret of + Left e -> liftIO . errorM logger $ + "Failed to register function: " ++ unpack functionName ++ show e + Right _ -> liftIO . debugM logger $ + "Registered function: " ++ unpack functionName + Command functionName copts -> do + pName <- R.asks _providerName + ret <- wait $ vim_call_function "remote#define#CommandOnHost" + [ toObject pName, toObject functionName, toObject (cmdSync copts) + , toObject functionName, toObject copts + ] + case ret of + Left e -> liftIO . errorM logger $ + "Failed to register command: " ++ unpack functionName ++ show e + Right _ -> liftIO . debugM logger $ + "Registered command: " ++ unpack functionName + Autocmd acmdType functionName opts -> do + pName <- R.asks _providerName + ret <- wait $ vim_call_function "remote#define#AutocmdOnHost" + [ toObject pName, toObject functionName, toObject (acmdSync opts) + , toObject acmdType , toObject opts + ] + case ret of + Left e -> liftIO . errorM logger $ + "Failed to register autocmd: " ++ unpack functionName ++ show e + Right _ -> liftIO . debugM logger $ + "Registered autocmd: " ++ unpack functionName + +-- | Create a listening thread for events and add update the 'FunctionMap' with +-- the corresponding 'TQueue's (i.e. communication channels). +registerStatefulFunctionality + :: (r, st, [ExportedFunctionality r st]) + -> Neovim customcConfig () (ThreadId, [(FunctionalityDescription, FunctionType)]) +registerStatefulFunctionality (r, st, fs) = do + q <- liftIO newTQueueIO + tid <- forkNeovim r st (listeningThread q) + return (tid, map (\n -> (getDescription n, Stateful q)) fs) + where + functionRoutes = foldr updateRoute Map.empty fs + updateRoute = uncurry Map.insert . (name &&& getFunction) + + executeFunction + :: ([Object] -> Neovim r st Object) + -> [Object] + -> Neovim r st (Either String Object) + executeFunction f args = try (f args) >>= \case + Left e -> let e' = e :: SomeException + in return . Left $ show e' + Right res -> return $ Right res + listeningThread q = do + msg <- liftIO . atomically $ readTQueue q + forM_ (fromMessage msg) $ \req@Request{..} -> + forM_ (Map.lookup reqMethod functionRoutes) $ \f -> + respond req =<< executeFunction f reqArgs + forM_ (fromMessage msg) $ \Notification{..} -> + forM_ (Map.lookup notMethod functionRoutes) $ \f -> + void $ executeFunction f notArgs + listeningThread q + diff --git a/library/Neovim/Plugin/Classes.hs b/library/Neovim/Plugin/Classes.hs new file mode 100644 --- /dev/null +++ b/library/Neovim/Plugin/Classes.hs @@ -0,0 +1,238 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# 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 ( + ExportedFunctionality(..), + getFunction, + getDescription, + FunctionalityDescription(..), + FunctionName(..), + NeovimPlugin(..), + Plugin(..), + wrapPlugin, + Synchronous(..), + CommandOptions(..), + AutocmdOptions(..), + ) where + +import Neovim.Classes +import Neovim.Context + +import Data.Default +import qualified Data.Map as Map +import Data.Maybe +import Data.MessagePack +import Data.Text (Text) + +-- | This data type is used in the plugin registration to properly register the +-- functions. +newtype ExportedFunctionality r st + = EF (FunctionalityDescription, [Object] -> Neovim r st Object) + + +-- | Extract the description of an 'ExportedFunctionality'. +getDescription :: ExportedFunctionality r st -> FunctionalityDescription +getDescription (EF (d,_)) = d + + +-- | Extract the function of an 'ExportedFunctionality'. +getFunction :: ExportedFunctionality r st -> [Object] -> Neovim r st Object +getFunction (EF (_, f)) = f + + +-- | 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 + = Function Text Synchronous + -- ^ 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 + + | Command Text CommandOptions + -- ^ 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 + + | Autocmd Text Text AutocmdOptions + -- ^ 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. + -- TODO Should this be enforced somehow? Possibly via the TH generator. + -- + -- * Type of the autocmd (e.g. \"BufWritePost\") + -- * Name for the function to call + + deriving (Show, Read, Eq, Ord) + + +-- | This option detemines how neovim should behave when calling some +-- functionality on a remote host. +data Synchronous + = Async + -- ^ 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. + + | Sync + -- ^ Call the function and wait for its result. This is only synchronous on + -- the neovim side. For comands it means that the GUI will (probably) not + -- allow any user input until a reult is received. Functions run + -- asynchronously inside neovim (or in one of its plugin providers) can use + -- these functions concurrently. + deriving (Show, Read, Eq, Ord, Enum) + + +instance Default Synchronous where + def = Sync + +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 that can be optionally set for commands. +-- +-- TODO Determine which of these make sense, how they are transmitted back and +-- which options are still missing. +-- (see remote#define#CommandOnHost in runtime\/autoload\/remote\/define.vim)) +data CommandOptions = CommandOptions + { cmdSync :: Synchronous + -- ^ Option to indicate whether vim shuould block until the command has + -- completed. (default: 'Sync') + + , cmdRange :: Maybe Text + -- ^ Vim expression for the range (or count). (default: \"\") + + , cmdCount :: Bool + -- ^ If true, + + , cmdNargs :: Int + -- ^ Number of arguments. Note that all arguments have to be a string type. + -- + -- TODO Check this in the Template Haskell functions. + -- + -- If you're using the template haskell functions for registering commands, + -- this field is overridden by it. + + , cmdBang :: Bool + -- ^ Behavior changes when using a bang. + } + deriving (Show, Read, Eq, Ord) + + +instance Default CommandOptions where + def = CommandOptions + { cmdSync = Sync + , cmdRange = Nothing + , cmdCount = False + , cmdNargs = 0 + , cmdBang = False + } + + +instance NvimObject CommandOptions where + toObject (CommandOptions{..}) = + (toObject :: Dictionary -> Object) . Map.fromList . catMaybes $ + [ cmdRange >>= \r -> Just ("range", toObject r) + , if cmdCount then Just ("count", toObject True) else Nothing + , if cmdNargs > 0 then Just ("nargs", toObject cmdNargs) else Nothing + , if cmdBang then Just ("bang", toObject True) else Nothing + ] + fromObject o = throwError $ + "Did not expect to receive a CommandOptions object: " ++ show o + + +data AutocmdOptions = AutocmdOptions + { acmdSync :: Synchronous + -- ^ Option to indicate whether vim shuould block until the function has + -- completed. (default: 'Sync') + + , acmdPattern :: Text + -- ^ Pattern to match on. (default: \"*\") + + , acmdNested :: Bool + -- ^ Nested autocmd. (default: False) + -- + -- See @:h autocmd-nested@ + } + deriving (Show, Read, Eq, Ord) + + +instance Default AutocmdOptions where + def = AutocmdOptions + { acmdSync = Sync + , acmdPattern = "*" + , acmdNested = False + } + + +instance NvimObject AutocmdOptions where + toObject (AutocmdOptions{..}) = + (toObject :: Dictionary -> Object) . Map.fromList $ + [ ("pattern", toObject acmdPattern) + , ("nested", toObject acmdNested) + ] + fromObject o = throwError $ + "Did not expect to receive an AutocmdOptions object: " ++ show o + +-- | Conveniennce class to extract a name from some value. +class FunctionName a where + name :: a -> Text + + +instance FunctionName FunctionalityDescription where + name = \case + Function n _ -> n + Command n _ -> n + Autocmd _ n _ -> n + + +instance FunctionName (ExportedFunctionality r st) where + name = name . getDescription + + +-- | This data type contains meta information for the plugin manager. +-- +data Plugin r st = Plugin + { exports :: [ExportedFunctionality () ()] + , statefulExports :: [(r, st, [ExportedFunctionality r st])] + } + + +data NeovimPlugin = forall r st. NeovimPlugin (Plugin r st) + + +-- | Wrap a 'Plugin' in some nice blankets, so that we can put them in a simple +-- list. +wrapPlugin :: Monad m => Plugin r st -> m NeovimPlugin +wrapPlugin = return . NeovimPlugin + diff --git a/library/Neovim/Plugin/ConfigHelper.hs b/library/Neovim/Plugin/ConfigHelper.hs new file mode 100644 --- /dev/null +++ b/library/Neovim/Plugin/ConfigHelper.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{- | +Module : Neovim.Plugin.ConfigHelper +Description : Helper plugin to ease recompiling the nvim-hs config +Copyright : (c) Sebastian Witte +License : Apache-2.0 + +Maintainer : woozletoff@gmail.com +Stability : experimental +Portability : GHC + +-} +module Neovim.Plugin.ConfigHelper + where + +import Config.Dyre (Params) +import Config.Dyre.Paths (getPaths) +import Neovim.API.TH +import Neovim.Config +import Neovim.Plugin.Classes +import Neovim.Plugin.ConfigHelper.Internal +import Data.Text (pack) + +-- | Note that you cannot really use this plugin by hand. It is automatically +-- loaded for all Neovim instances. +plugin :: Params NeovimConfig -> IO NeovimPlugin +plugin params = do + (_, _, cfgFile, _, libsDir) <- getPaths params + wrapPlugin Plugin + { exports = + [ $(function' 'pingNvimhs) Sync + , $(command' 'restartNvimhs) def { cmdSync = Async } + ] + , statefulExports = + [ (params, [], + [ $(autocmd 'recompileNvimhs) "BufWritePost" def + { acmdSync = Async + , acmdPattern = pack cfgFile + } + , $(autocmd 'recompileNvimhs) "BufWritePost" def + { acmdSync = Async + , acmdPattern = pack (libsDir++"/.*") + } + ]) + ] + } diff --git a/library/Neovim/Plugin/ConfigHelper/Internal.hs b/library/Neovim/Plugin/ConfigHelper/Internal.hs new file mode 100644 --- /dev/null +++ b/library/Neovim/Plugin/ConfigHelper/Internal.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE LambdaCase #-} +{- | +Module : Neovim.Plugin.ConfigHelper.Internal +Description : Internals for a config helper plugin that helps recompiling nvim-hs +Copyright : (c) Sebastian Witte +License : Apache-2.0 + +Maintainer : woozletoff@gmail.com +Stability : experimental +Portability : GHC + +-} +module Neovim.Plugin.ConfigHelper.Internal + where + +import Neovim.API.String (vim_command) +import Neovim.Config +import Neovim.Context +import Neovim.Quickfix +import Neovim.RPC.FunctionCall + +import Config.Dyre (Params) +import Config.Dyre.Compile +import Control.Applicative hiding (many, (<|>)) +import Control.Monad (void) +import Data.Char +import Text.Parsec +import Text.Parsec.String + +-- | Simple function that will return @"Pong"@ if the plugin provider is +-- running. +pingNvimhs :: Neovim' String +pingNvimhs = return "Pong" + +-- | Recompile the plugin provider and put comile errors in the quickfix list. +recompileNvimhs :: Neovim (Params NeovimConfig) [QuickfixListItem String] () +recompileNvimhs = do + cfg <- ask + mErrString <- liftIO (customCompile cfg >> getErrorString cfg) + let qs = maybe [] parseQuickfixItems mErrString + put qs + setqflist qs Replace + wait' $ vim_command "cwindow" + +-- | Note that restarting the plugin provider implies compilation because Dyre +-- does this automatically. However, if the recompilation fails, the previously +-- compiled bynary is executed. This essentially means that restarting may take +-- more time then you might expect. +restartNvimhs :: Neovim r st () +restartNvimhs = restart + +-- See the tests in @test-suite\/Neovim\/Plugin\/ConfigHelperSpec.hs@ on how the +-- error messages look like. +parseQuickfixItems :: String -> [QuickfixListItem String] +parseQuickfixItems s = + case parse (many pQuickfixListItem) "Quickfix parser" s of + Right qs -> qs + Left _ -> [] + +pQuickfixListItem :: Parser (QuickfixListItem String) +pQuickfixListItem = do + _ <- many blankLine + (f,l,c) <- pLocation + desc <- try pShortDesrciption <|> pLongDescription + return $ (quickfixListItem (Right f) (Left l)) + { col = Just (c, True) + , text = desc + , errorType = "E" -- TODO determine actual type + } + +pShortDesrciption :: Parser String +pShortDesrciption = (:) + <$> (many spaceChar *> notFollowedBy blankLine *> anyChar) + <*> anyChar `manyTill` (void (many1 blankLine) <|> eof) + +pLongDescription :: Parser String +pLongDescription = anyChar `manyTill` (blank <|> eof) + where + blank = try (try newline *> try blankLine) + +spaceChar :: Parser Char +spaceChar = satisfy $ \c -> c == ' ' || c == '\t' + +blankLine :: Parser () +blankLine = void . try $ many spaceChar >> newline + +-- | Skip anything until the next location information appears. +-- +-- The result will be a triple of filename, line number and column + +-- | Try to parse location information. +-- +-- @\/some\/path\/to\/a\/file.hs:42:88:@ +pLocation :: Parser (String, Int, Int) +pLocation = (,,) + <$> many1 (noneOf ":\n\t\r") <* char ':' + <*> pInt <* char ':' + <*> pInt <* char ':' <* many spaceChar + +pInt :: Parser Int +pInt = read <$> many1 (satisfy isDigit) diff --git a/library/Neovim/Plugin/IPC.hs b/library/Neovim/Plugin/IPC.hs new file mode 100644 --- /dev/null +++ b/library/Neovim/Plugin/IPC.hs @@ -0,0 +1,20 @@ +{- | +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 + diff --git a/library/Neovim/Plugin/IPC/Classes.hs b/library/Neovim/Plugin/IPC/Classes.hs new file mode 100644 --- /dev/null +++ b/library/Neovim/Plugin/IPC/Classes.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE ExistentialQuantification #-} +{- | +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 + where + +import Data.Data (Typeable, cast) + +-- | 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 + +class 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 + diff --git a/library/Neovim/Plugin/IPC/Internal.hs b/library/Neovim/Plugin/IPC/Internal.hs new file mode 100644 --- /dev/null +++ b/library/Neovim/Plugin/IPC/Internal.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{- | +Module : Neovim.Plugin.IPC.Internal +Description : Internally used parts of the inter plugin communication +Copyright : (c) Sebastian Witte +License : Apache-2.0 + +Maintainer : woozletoff@gmail.com +Stability : experimental +Portability : GHC + +-} +module Neovim.Plugin.IPC.Internal + ( RPCMessage(..) + , Request(..) + , Notification(..) + + , module Data.Int + , module Data.Time + ) where + +import Control.Concurrent.STM +import Data.Data (Typeable) +import Data.Int (Int64) +import Data.MessagePack +import Data.Text (Text) +import Data.Time +import Neovim.Plugin.IPC.Classes + +-- | Haskell representation of supported Remote Procedure Call messages. +data RPCMessage + = FunctionCall Text [Object] (TMVar (Either Object Object)) UTCTime + -- ^ Method name, parameters, callback, timestamp + | Response !Int64 Object Object + -- ^ Response sent to indicate the result of a function call. + -- + -- * identfier of the message as 'Word32' + -- * Error value + -- * Result value + | NotificationCall Text [Object] + -- ^ Method name and parameters. + deriving (Typeable) + +instance Message RPCMessage + +-- | 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 + { reqMethod :: Text + -- ^ Name of the function to call. + , reqId :: !Int64 + -- ^ Identifier to map the result to a function call invocation. + , reqArgs :: [Object] + -- ^ Arguments for the function. + } deriving (Typeable) + +instance Message Request + +-- | 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 + { notMethod :: Text + -- ^ Name of the function to call. + , notArgs :: [Object] + -- ^ Argumentse for the function. + } deriving (Typeable) + +instance Message Notification + diff --git a/library/Neovim/Quickfix.hs b/library/Neovim/Quickfix.hs new file mode 100644 --- /dev/null +++ b/library/Neovim/Quickfix.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# 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 Neovim.API.String +import Neovim.Classes +import Neovim.Context +import Neovim.RPC.FunctionCall + +setqflist :: (Monoid strType, NvimObject strType) + => [QuickfixListItem strType] -> QuickfixAction -> Neovim r st () +setqflist qs a = + void . wait' $ vim_call_function "setqflist" [toObject qs, toObject a] + +-- | 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 + { bufOrFile :: Either Int strType + -- ^ Since the filename is only used if no buffer can be specified, this + -- field is a merge of @bufnr@ and @filename@. + , lnumOrPattern :: Either Int strType + -- ^ Line number or search pattern to locate the error. + , col :: Maybe (Int, Bool) + -- ^ 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. + , nr :: Maybe Int + -- ^ Error number. + , text :: strType + -- ^ Description of the error. + , errorType :: strType + -- ^ TODO replace with enum, but too lazy for now. + } deriving (Eq, Show) + +-- | Create a 'QuickfixListItem' by providing the minimal amount of arguments +-- needed. +quickfixListItem :: (Monoid strType) + => Either Int strType -- ^ buffer of file name + -> Either Int strType -- ^ line number or pattern + -> QuickfixListItem strType +quickfixListItem bufferOrFile lineOrPattern = QFItem + { bufOrFile = bufferOrFile + , lnumOrPattern = lineOrPattern + , col = Nothing + , nr = Nothing + , text = mempty + , errorType = mempty + } + +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) + ] ++ catMaybes + [ (\n -> ("nr", toObject n)) <$> nr + , (\(c,_) -> ("col", toObject c)) <$> col + , (\(_,t) -> ("vcol", toObject t)) <$> col + ] + + fromObject objectMap@(ObjectMap _) = do + m <- fromObject objectMap + let l :: NvimObject o => ByteString -> Either String o + l key = case Map.lookup key m of + Just o -> fromObject o + Nothing -> Left "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 of search pattern inside quickfix list item." + let l' :: NvimObject o => ByteString -> Either String (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 = do + c' <- c + v' <- v + case c' of + 0 -> Nothing + _ -> Just (c',v') + text <- fromMaybe mempty <$> l' "text" + errorType <- fromMaybe mempty <$> l' "type" + return QFItem{..} + fromObject o = throwError $ "Could not deserialize QuickfixListItem, expected a map but received: " ++ show o + +data QuickfixAction + = Append -- ^ Add items to the current list (or create a new one if none exists). + | Replace -- ^ Replace current list (or create a new one if none exists). + | New -- ^ Create a new list. + deriving (Eq, Ord, Enum, Bounded, Show) + +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" + diff --git a/library/Neovim/RPC/Common.hs b/library/Neovim/RPC/Common.hs new file mode 100644 --- /dev/null +++ b/library/Neovim/RPC/Common.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# 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.Context + +import Control.Applicative +import Control.Concurrent.STM +import Control.Monad +import Data.Int (Int64) +import Data.Map +import Data.MessagePack +import Data.Monoid +import Data.Streaming.Network +import Data.String +import Data.Text (Text) +import Data.Time +import Neovim.Plugin.IPC +import Network.Socket as N hiding (SocketType) +import System.Environment (getEnv) +import System.IO (BufferMode (..), Handle, IOMode, + hClose, hSetBuffering) +import System.Log.Logger + +import Prelude + +-- | 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 Text FunctionType + +data FunctionType + = Stateless ([Object] -> Neovim' Object) + | Stateful (TQueue SomeMessage) + +-- | 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. + , functions :: TMVar FunctionMap + -- ^ A map that contains the function names which are registered to this + -- plugin manager. Putting the map in a 'TMVar' ensures that all + -- functionality is registered properly before answering to requests send + -- by neovim. + } + +-- | 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, MonadIO io) => io RPCConfig +newRPCConfig = RPCConfig + <$> liftIO (newTVarIO mempty) + <*> liftIO newEmptyTMVarIO + +-- | Simple data type defining the kind of socket the socket reader should use. +data SocketType = Stdout Handle + -- ^ Use the handle for receiving msgpack-rpc messages. This is + -- suitable for an embedded neovim which is used in test cases. + | Environment + -- ^ Read the connection information from the environment + -- variable @NVIM_LISTEN_ADDRESS@. + | UnixSocket FilePath + -- ^ Use a unix socket. + | TCP Int String + -- ^ Use an IP socket. First argument is the port and the + -- second is the host name. + +-- | Create a 'Handle' from the given socket description. +-- +-- The handle is not automatically closed. +createHandle :: (Functor io, MonadIO io) + => IOMode + -> SocketType + -> io Handle +createHandle ioMode socketType = case socketType of + Stdout h -> do + liftIO $ hSetBuffering h (BlockBuffering Nothing) + return h + UnixSocket f -> createHandle ioMode . Stdout + =<< createUnixSocketHandle f + TCP p h -> createHandle ioMode . Stdout + =<< createTCPSocketHandle p h + Environment -> createHandle ioMode . Stdout + =<< createSocketHandleFromEnvironment + + where + createUnixSocketHandle :: (MonadIO io) => FilePath -> io Handle + createUnixSocketHandle f = + liftIO $ getSocketUnix f >>= flip socketToHandle ioMode + + createTCPSocketHandle :: (Functor io, MonadIO io) => Int -> String -> io Handle + createTCPSocketHandle p h = liftIO $ getSocketTCP (fromString h) p + >>= flip socketToHandle ioMode . fst + + createSocketHandleFromEnvironment = do + listenAddress <- liftIO (getEnv "NVIM_LISTEN_ADDRESS") + case words listenAddress of + [unixSocket] -> createHandle ioMode (UnixSocket unixSocket) + [h,p] -> createHandle ioMode (TCP (read p) h) + _ -> do + let errMsg = unlines + [ "Unhandled socket type from environment variable: " + , "\t" <> listenAddress + ] + liftIO $ errorM "createHandle" errMsg + error errMsg + + +cleanUpHandle :: (MonadIO io) => Handle -> Bool -> io () +cleanUpHandle h completed = liftIO $ do + hClose h + unless completed $ + warningM "cleanUpHandle" "Cleanup called on uncompleted handle." diff --git a/library/Neovim/RPC/EventHandler.hs b/library/Neovim/RPC/EventHandler.hs new file mode 100644 --- /dev/null +++ b/library/Neovim/RPC/EventHandler.hs @@ -0,0 +1,97 @@ +{-# 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 +import Neovim.Context hiding (ask, asks) +import Neovim.Plugin.IPC +import Neovim.Plugin.IPC.Internal +import Neovim.RPC.Common +import Neovim.RPC.FunctionCall + +import Control.Applicative +import Control.Concurrent.STM hiding (writeTQueue) +import Control.Monad.Reader +import Control.Monad.State.Strict +import Control.Monad.Trans.Resource +import Data.ByteString (ByteString) +import Data.Conduit as C +import Data.Conduit.Binary (sinkHandle) +import qualified Data.Map as Map +import Data.MessagePack +import Data.Serialize (encode) +import System.IO (IOMode (WriteMode)) + +import Prelude + +-- | This function will establish a connection to the given socket and write +-- msgpack-rpc requests to it. +runEventHandler :: SocketType + -> ConfigWrapper RPCConfig + -> IO () +runEventHandler socketType env = + runEventHandlerContext env $ do + h <- createHandle WriteMode socketType + eventHandlerSource + $= eventHandler + $$ addCleanup (cleanUpHandle h) (sinkHandle h) + +-- | Convenient monad transformer stack for the event handler +newtype EventHandler a = + EventHandler (ResourceT (ReaderT (ConfigWrapper RPCConfig) (StateT Int64 IO)) a) + deriving ( Functor, Applicative, Monad, MonadState Int64, MonadIO + , MonadReader (ConfigWrapper RPCConfig)) + +runEventHandlerContext :: ConfigWrapper RPCConfig -> EventHandler a -> IO a +runEventHandlerContext env (EventHandler a) = + evalStateT (runReaderT (runResourceT a) env) 1 + +eventHandlerSource :: Source EventHandler SomeMessage +eventHandlerSource = asks _eventQueue >>= \q -> + forever $ yield =<< atomically' (readTQueue q) + +eventHandler :: ConduitM SomeMessage ByteString EventHandler () +eventHandler = await >>= \case + Nothing -> return () -- i.e. close the conduit -- TODO signal shutdown globally + Just message -> handleMessage (fromMessage message) >> eventHandler + +handleMessage :: Maybe RPCMessage -> ConduitM i ByteString EventHandler () +handleMessage = \case + Just (FunctionCall fn params reply time) -> do + i <- get + modify succ + rs <- asks (recipients . customConfig) + atomically' . modifyTVar rs $ Map.insert i (time, reply) + yield . encode $ ObjectArray + [ toObject (0 :: Int64) + , ObjectInt i + , toObject fn + , toObject params + ] + Just (Response i e res) -> + yield . encode $ ObjectArray + [ toObject (1 :: Int64) + , ObjectInt i + , toObject e + , toObject res + ] + Just (NotificationCall fn params) -> + yield . encode $ ObjectArray + [ ObjectInt 2 + , toObject fn + , toObject params + ] + Nothing -> return () -- i.e. skip to next message + diff --git a/library/Neovim/RPC/FunctionCall.hs b/library/Neovim/RPC/FunctionCall.hs new file mode 100644 --- /dev/null +++ b/library/Neovim/RPC/FunctionCall.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} +{- | +Module : Neovim.RPC.FunctionCall +Description : Functions for calling functions +Copyright : (c) Sebastian Witte +License : Apache-2.0 + +Maintainer : woozletoff@gmail.com +Stability : experimental + +-} +module Neovim.RPC.FunctionCall ( + acall, + acall', + scall, + scall', + atomically', + wait, + wait', + waitErr, + waitErr', + respond, + ) where + +import Neovim.Classes +import Neovim.Context +import Neovim.Plugin.IPC +import Neovim.Plugin.IPC.Internal + +import Control.Applicative +import Control.Concurrent.STM +import Control.Monad.Reader as R +import Data.MessagePack +import Data.Monoid +import Data.Text + +unexpectedException :: String -> err -> a +unexpectedException fn _ = error $ + "Function threw an exception even though it was declared not to throw one: " + <> fn + + +withIgnoredException :: (Functor f, NvimObject result) + => Text -- ^ Function name for better error messages + -> f (Either err result) + -> f result +withIgnoredException fn = fmap (either ((unexpectedException . unpack) fn) id) + + +-- | Helper function that concurrently puts a 'Message' in the event queue +-- and returns an 'STM' action that returns the result. +acall :: (NvimObject result) + => Text + -> [Object] + -> Neovim r st (STM (Either Object result)) +acall fn parameters = do + q <- eventQueue + mv <- liftIO newEmptyTMVarIO + timestamp <- liftIO getCurrentTime + atomically' . writeTQueue q . SomeMessage $ FunctionCall fn parameters mv timestamp + return $ convertObject <$> readTMVar mv + where + convertObject = \case + Left e -> Left e + Right o -> case fromObject o of + Left e -> Left (toObject e) + Right r -> Right r + + +acall' :: (NvimObject result) + => Text + -> [Object] + -> Neovim r st (STM result) +acall' fn parameters = withIgnoredException fn <$> acall fn parameters + + +-- | Call a neovim function synchronously. This function blocks until the +-- result is available. +scall :: (NvimObject result) + => Text -- ^ Function name + -> [Object] -- ^ Parameters in an 'Object' array + -> Neovim r st (Either Object result) + -- ^ result value of the call or the thrown exception +scall fn parameters = acall fn parameters >>= atomically' + + +scall' :: NvimObject result => Text -> [Object] -> Neovim r st result +scall' fn = withIgnoredException fn . scall fn + + +-- | Lifted variant of 'atomically'. +atomically' :: (MonadIO io) => STM result -> io result +atomically' = liftIO . atomically + + +-- | Wait for the result of the STM action. +-- +-- This action possibly blocks as it is an alias for +-- @ \ioSTM -> ioSTM >>= liftIO . atomically@. +wait :: Neovim r st (STM result) -> Neovim r st result +wait = (=<<) atomically' + + +-- | Variant of 'wait' that discards the result. +wait' :: Neovim r st (STM result) -> Neovim r st () +wait' = void . wait + + +-- | Wait for the result of the 'STM' action and call @'err' . (loc++) . show@ +-- if the action returned an error. +waitErr :: (Show e) + => String -- ^ Prefix error message with this. + -> Neovim r st (STM (Either e result)) -- ^ Function call to neovim + -> Neovim r st result +waitErr loc act = wait act >>= either (err . (loc++) . show) return + + +-- | 'waitErr' that discards the result. +waitErr' :: (Show e) + => String + -> Neovim r st (STM (Either e result)) + -> Neovim r st () +waitErr' loc = void . waitErr loc + + +-- | Send the result back to the neovim instance. +respond :: (NvimObject result) => Request -> Either String result -> Neovim r st () +respond Request{..} result = do + q <- eventQueue + atomically' . writeTQueue q . SomeMessage $ uncurry (Response reqId) oResult + + where + oResult = case result of + Left e -> (toObject e, toObject ()) + Right r -> (toObject (), toObject r) + diff --git a/library/Neovim/RPC/SocketReader.hs b/library/Neovim/RPC/SocketReader.hs new file mode 100644 --- /dev/null +++ b/library/Neovim/RPC/SocketReader.hs @@ -0,0 +1,182 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# 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, + ) where + +import Neovim.Classes +import Neovim.Context hiding (ask, asks) +import Neovim.Plugin.IPC +import Neovim.Plugin.IPC.Internal +import Neovim.RPC.Common +import Neovim.RPC.FunctionCall + +import Control.Applicative +import Control.Concurrent (forkIO) +import Control.Concurrent.STM +import Control.Monad (void) +import Control.Monad.Reader (MonadReader, ask, asks) +import Control.Monad.Trans.Resource +import Data.Conduit as C +import Data.Conduit.Binary +import Data.Conduit.Cereal +import Data.Foldable (forM_) +import qualified Data.Map as Map +import Data.MessagePack +import Data.Monoid +import qualified Data.Serialize (get) +import Data.Text (Text, unpack) +import System.IO (IOMode (ReadMode)) +import System.Log.Logger + +import Prelude + +logger :: String +logger = "Socket Reader" + +-- | This function will establish a connection to the given socket and read +-- msgpack-rpc events from it. +runSocketReader :: SocketType -> ConfigWrapper RPCConfig -> IO () +runSocketReader socketType env = do + h <- createHandle ReadMode socketType + runSocketHandler env $ + -- addCleanup (cleanUpHandle h) (sourceHandle h) + -- TODO test whether/how this should be handled + -- this has been commented out because I think that restarting the + -- plugin provider should not cause the stdin and stdout handles to be + -- closed since that would cause neovim to stop the plugin provider (I + -- think). + sourceHandle h + $= conduitGet Data.Serialize.get + $$ messageHandlerSink + +-- | Convenient transformer stack for the socket reader. +newtype SocketHandler a = + SocketHandler (ResourceT (Neovim RPCConfig ()) a) + deriving ( Functor, Applicative, Monad , MonadIO + , MonadReader (ConfigWrapper RPCConfig), MonadThrow) + +runSocketHandler :: ConfigWrapper RPCConfig -> SocketHandler a -> IO () +runSocketHandler r (SocketHandler a) = + void $ runNeovim r () (runResourceT a >> quit) + +-- | Sink that delegates the messages depending on their type. +-- +messageHandlerSink :: Sink Object SocketHandler () +messageHandlerSink = awaitForever $ \rpc -> do + liftIO . debugM logger $ "Received: " <> show rpc + case rpc of + ObjectArray [ObjectInt msgType, ObjectInt fi, e, result] -> + handleResponseOrRequest msgType fi e result + ObjectArray [ObjectInt msgType, method, params] -> + handleNotification msgType method params + obj -> liftIO . errorM logger $ + "Unhandled rpc message: " <> show obj + +handleResponseOrRequest :: Int64 -> Int64 -> Object -> Object + -> Sink a SocketHandler () +handleResponseOrRequest msgType i + | msgType == 1 = handleResponse i + | msgType == 0 = handleRequestOrNotification (Just i) + | otherwise = \_ _ -> do + liftIO . errorM logger $ "Invalid message type: " <> show msgType + return () + +handleResponse :: Int64 -> Object -> Object -> Sink a SocketHandler () +handleResponse i e result = do + answerMap <- asks (recipients . customConfig) + 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 $ case e of + ObjectNil -> Right result + _ -> Left e + +-- | Act upon the received request or notification. The main difference between +-- the two is that a notification does not generate a reply. The distinction +-- between those two cases is done via the first paramater which is 'Maybe' the +-- function call identifier. +handleRequestOrNotification :: Maybe Int64 -> Object -> Object -> Sink a SocketHandler () +handleRequestOrNotification mi method (ObjectArray params) = case fromObject method of + Left e -> liftIO . errorM logger $ show e + -- Fork everything so that we do not block. + -- + -- XXX If the functions never return, we may end up with a lot of idle + -- threads. Maybe we should gather the ThreadIds and kill them after some + -- amount of time if they are still around. Maybe resourcet provides such a + -- facility for threads already. + Right m -> void . liftIO . forkIO . handle m =<< ask + + where + lookupFunction :: Text -> RPCConfig -> STM (Maybe FunctionType) + lookupFunction m rpc = Map.lookup m <$> readTMVar (functions rpc) + + handle m rpc = atomically (lookupFunction m (customConfig rpc)) >>= \case + Nothing -> do + let errM = "No provider for: " <> unpack m + debugM logger errM + forM_ mi $ \i -> atomically' . writeTQueue (_eventQueue rpc) + . SomeMessage $ Response i (toObject errM) ObjectNil + Just (Stateless f) -> do + liftIO . debugM logger $ "Executing stateless function with ID: " <> show mi + -- Stateless function: Create a boring state object for the + -- Neovim context. + -- drop the state of the result with (fmap fst <$>) + res <- fmap fst <$> runNeovim (rpc { customConfig = () }) () (f $ parseParams params) + -- Send the result to the event handler + forM_ mi $ \i -> atomically' . writeTQueue (_eventQueue rpc) + . SomeMessage . uncurry (Response i) $ responseResult res + Just (Stateful c) -> do + now <- liftIO getCurrentTime + reply <- liftIO newEmptyTMVarIO + let q = (recipients . customConfig) rpc + liftIO . debugM logger $ "Executing stateful function with ID: " <> show mi + case mi of + Just i -> do + atomically' . modifyTVar q $ Map.insert i (now, reply) + atomically' . writeTQueue c . SomeMessage $ Request m i (parseParams params) + Nothing -> + atomically' . writeTQueue c . SomeMessage $ Notification m (parseParams params) + responseResult (Left !e) = (toObject e, ObjectNil) + responseResult (Right !res) = (ObjectNil, toObject res) + +handleRequestOrNotification _ _ params = liftIO . errorM logger $ + "Parmaeters in request are not in an object array: " <> show params + +-- TODO implement proper handling for additional parameters +parseParams :: [Object] -> [Object] +parseParams = \case + -- 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 -> args + + +handleNotification :: Int64 -> Object -> Object -> Sink a SocketHandler () +handleNotification 2 method params = do + liftIO . debugM logger $ "Received notification: " <> show method <> show params + handleRequestOrNotification Nothing method params +handleNotification msgType fn params = liftIO . errorM logger $ + "Message is not a noticiation. Received msgType: " <> show msgType + <> " The expected value was 2. The following arguments were given: " + <> show fn <> " and " <> show params + + diff --git a/nvim-hs.cabal b/nvim-hs.cabal new file mode 100644 --- /dev/null +++ b/nvim-hs.cabal @@ -0,0 +1,148 @@ +name: nvim-hs +version: 0.0.1 +synopsis: Haskell plugin backend for neovim +description: + This package provides a plugin provider for neovim. It allows you to write + plugins for one of the great editors of our time in the best programming + language of our time! ;-) + . + You should find all the documentation you need inside the "Neovim" module. All + other modules are considered internal, so don't be annoyed if using things + from there may break your code. + . + If you spot any errors or if you have great ideas, feel free to open an issue + on github. +homepage: https://github.com/saep/nvim-hs +license: Apache-2.0 +license-file: LICENSE +author: Sebastian Witte +maintainer: woozletoff@gmail.com +copyright: Copyright (C) Sebastian Witte +category: Editor +build-type: Simple +cabal-version: >=1.10 +extra-source-files: TestPlugins.vim + , TestPlugins.hs + , nvim-hs.sh + , test-files/compile-error-for-quickfix-test1 + , test-files/compile-error-for-quickfix-test2 + , test-files/compile-error-for-quickfix-test3 + , test-files/compile-error-for-quickfix-test4 + , test-files/compile-error-for-quickfix-test5 + , test-files/hello +source-repository head + type: git + location: https://github.com/saep/nvim-hs + +executable nvim-hs + main-is: Main.hs + hs-source-dirs: executable + default-language: Haskell2010 + build-depends: base ==4.*, nvim-hs, data-default + ghc-options: -threaded -rtsopts -with-rtsopts=-N + +library + exposed-modules: Neovim + -- Note that every module below this is considered internal and if you have to + -- import it somewhere in your code and you think it should be generally + -- available , you should open a ticket about inclusion in the export list of + -- the Neovim module. Since we are still in a prototyping stage, every user of + -- this library should have the freedom to do what she wants. + , Neovim.API.String + , Neovim.Classes + , Neovim.Context + , Neovim.Plugin + , Neovim.Plugin.Classes + , Neovim.Plugin.IPC + , Neovim.Plugin.IPC.Internal + , Neovim.Plugin.IPC.Classes + , Neovim.Config + , Neovim.Debug + , Neovim.Main + , Neovim.RPC.Common + , Neovim.RPC.EventHandler + , Neovim.RPC.FunctionCall + , Neovim.RPC.SocketReader + , Neovim.Plugin.ConfigHelper + , Neovim.Quickfix + + other-modules: Neovim.Plugin.ConfigHelper.Internal + , Neovim.API.Parser + , Neovim.API.TH + -- other-extensions: + build-depends: base ==4.* + , bytestring + , cereal + , cereal-conduit + , conduit + , conduit-extra + , containers + , data-default + , directory + , dyre + , filepath + , hslogger + , messagepack >= 0.4 + , monad-control + , network + , lifted-base + , mtl >= 2.2.1 && < 2.3 + , optparse-applicative + , parsec ==3.* + , process + , resourcet + , stm + , streaming-commons + , template-haskell + , text + , time + , transformers + , transformers-base + , utf8-string + hs-source-dirs: library + default-language: Haskell2010 + ghc-options: -Wall + + +test-suite hspec + type: exitcode-stdio-1.0 + hs-source-dirs: test-suite, library + main-is: Spec.hs + default-language: Haskell2010 + build-depends: base + , nvim-hs + + , hspec ==2.* + , hspec-discover + , QuickCheck >=2.6 + + , bytestring + , cereal + , cereal-conduit + , conduit + , conduit-extra + , containers + , data-default + , directory + , dyre + , filepath + , hslogger + , lifted-base + , mtl >= 2.2.1 && < 2.3 + , messagepack >= 0.4 + , network + , optparse-applicative + , parsec + , process + , resourcet + , stm + , streaming-commons + , text + , template-haskell + , time + , transformers + , utf8-string + , HUnit + + ghc-options: -threaded -rtsopts -with-rtsopts=-N + diff --git a/nvim-hs.sh b/nvim-hs.sh new file mode 100644 --- /dev/null +++ b/nvim-hs.sh @@ -0,0 +1,24 @@ +#!/bin/sh + +# Shell script that starts a plugin provider which is interpreted from the +# TestPlugins.hs file inside this repository. + +if ! type cabal > /dev/null 2>&1 ; then + echo "cabal not installed or on PATH" + echo $PATH + exit 1 +fi + +if ! type runghc > /dev/null 2>&1 ; then + echo "runghc not installed or on PATH" + echo $PATH + exit 1 +fi + +if [ -d ".cabal-sandbox/" ] ; then + # Use `cabal exec` if we are in a sandbox + exec cabal exec runghc TestPlugins.hs -- $1 -l test-log.txt -v DEBUG +else + exec runghc TestPlugins.hs -- $1 -l test-log.txt -v DEBUG +fi + diff --git a/test-files/compile-error-for-quickfix-test1 b/test-files/compile-error-for-quickfix-test1 new file mode 100644 --- /dev/null +++ b/test-files/compile-error-for-quickfix-test1 @@ -0,0 +1,7 @@ + +/.config/nvim/nvim.hs:25:30: + Couldn't match expected type `Language.Haskell.TH.Syntax.Name' + with actual type `Double -> Neovim r0 st0 Double' + In the second argument of `function', namely `mySin' + In the expression: function "Sin" mySin + In the expression: $(function "Sin" mySin) diff --git a/test-files/compile-error-for-quickfix-test2 b/test-files/compile-error-for-quickfix-test2 new file mode 100644 --- /dev/null +++ b/test-files/compile-error-for-quickfix-test2 @@ -0,0 +1,3 @@ + +/.config/nvim/lib/TestPlugins.hs:11:18: + Not in scope: `vim_function' diff --git a/test-files/compile-error-for-quickfix-test3 b/test-files/compile-error-for-quickfix-test3 new file mode 100644 --- /dev/null +++ b/test-files/compile-error-for-quickfix-test3 @@ -0,0 +1,2 @@ + +/.config/nvim/nvim.hs:25:30: Not in scope: `mySin' diff --git a/test-files/compile-error-for-quickfix-test4 b/test-files/compile-error-for-quickfix-test4 new file mode 100644 --- /dev/null +++ b/test-files/compile-error-for-quickfix-test4 @@ -0,0 +1,4 @@ + +/.config/nvim/lib/TestPlugins.hs:23:9: + Not in scope: ‘vim_call_dict_function’ + Perhaps you meant ‘vim_call_function’ (imported from Neovim) diff --git a/test-files/compile-error-for-quickfix-test5 b/test-files/compile-error-for-quickfix-test5 new file mode 100644 --- /dev/null +++ b/test-files/compile-error-for-quickfix-test5 @@ -0,0 +1,22 @@ + +/.config/nvim/lib/TestPlugins.hs:23:9: + Couldn't match type ‘STM (Either Object Object)’ with ‘[Char]’ + Expected type: Neovim () () String + Actual type: Neovim () () (STM (Either Object Object)) + In the expression: + vim_call_dict_function "g:mydict" False "Greet" [toObject "World"] + In an equation for ‘greet’: + greet + = vim_call_dict_function + "g:mydict" False "Greet" [toObject "World"] + +/.config/nvim/lib/TestPlugins.hs:23:32: + Couldn't match expected type ‘Object’ with actual type ‘[Char]’ + In the first argument of ‘vim_call_dict_function’, namely + ‘"g:mydict"’ + In the expression: + vim_call_dict_function "g:mydict" False "Greet" [toObject "World"] + In an equation for ‘greet’: + greet + = vim_call_dict_function + "g:mydict" False "Greet" [toObject "World"] diff --git a/test-files/hello b/test-files/hello new file mode 100644 --- /dev/null +++ b/test-files/hello @@ -0,0 +1,1 @@ +Hello, World! diff --git a/test-suite/Spec.hs b/test-suite/Spec.hs new file mode 100644 --- /dev/null +++ b/test-suite/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}