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