diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,30 @@ +# 0.0.3 + +* Debugging facilities for ghci have been added. Check out the + `Neovim.Debug` module! These few functions are very valuable to debug your + code or even the code of nvim-hs itself. + +* Startup code now has a special `Neovim` environment which has access to + some of the internals that may or may not be useful. This change allowed + the ConfigHelper plugin to be included as a normal, separable plugin. + Unfortunately, this potentially breaks the plugin startup code of some + existing plugins. + +* Neovim context is no longer a type synonym, but a newtype wrapper around + the previous type synonym with an added `ResourceT` wrapper. The functions + from `MonadReader` are now actually exported as those. + + As a consequence, some of your code may break if you lack some specific + instances which were auto-derived before. Send a PR or open a ticket to + resolve this. + +* Add handling for some kind of variadic arguments handling. + + A command or function will be passed `Nothing` as it's + last arguments if the argument type is wrapped in `Maybe` + and the invocation on the side of neovim did not pass those + arguments. + # 0.0.2 * Add handling for special command options diff --git a/TestPlugins.hs b/TestPlugins.hs --- a/TestPlugins.hs +++ b/TestPlugins.hs @@ -1,18 +1,29 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} import Neovim -import Neovim.Main (realMain) +import qualified Neovim.Context.Internal as Internal +import Neovim.Main (realMain) import Neovim.Plugin.Classes +import TestPlugins.TestFunctions -import System.Log.Logger +import Control.Concurrent (takeMVar, killThread) -- The script `TestPlugins.vim` comments how these functions should behave. main :: IO () -main = realMain def +main = realMain finalizer Nothing defaultConfig { plugins = [ randPlugin ] } -randPlugin :: IO NeovimPlugin +finalizer tids cfg = takeMVar (Internal.quit cfg) >>= \case + Internal.InitSuccess -> + finalizer tids cfg + + _ -> + mapM_ killThread tids + +randPlugin :: Neovim (StartupConfig NeovimConfig) () NeovimPlugin randPlugin = do -- This plugin was intended to use a real random number generator, but -- unfortunately a Travis build with other GHC versions failed to reproduce @@ -20,48 +31,20 @@ -- don't use this for cryptography! let randomNumbers = cycle [42,17,-666] :: [Int16] wrapPlugin Plugin - { exports = [ EF (Function "Randoom" Sync, randoom) - , EF (Function "Const42" Sync, const42) - , EF (Function "PingNvimhs" Sync, pingNvimhs) - , EF (Command "ComplicatedSpecialArgsHandling" - (mkCommandOptions [ CmdSync Sync, CmdRange WholeFile - , CmdBang , CmdNargs "+" - ]) - , complicatedCommand) + { exports = [ $(function' 'randoom) Sync + , $(function' 'const42) Sync + , $(function "PingNvimhs" 'pingNvimhs) Sync + , $(command "ComplicatedSpecialArgsHandling" 'complicatedCommand) + [ CmdSync Sync, CmdRange WholeFile + , CmdBang , CmdNargs "+" + ] ] , statefulExports = [((), randomNumbers, - [ EF (Function "Random" Sync, rf) - , EF (Function "InjectNumber" Sync, inj) + [ $(function "Random" 'rf) Sync + , $(function "InjectNumber" 'inj) Sync + , $(function "InitLazy" 'registerFunctionLazily) Sync ]) ] } -complicatedCommand :: [Object] -> Neovim r st Object -complicatedCommand = undefined - -rf :: [Object] -> Neovim cfg [Int16] Object -rf _ = do - r <- gets head - modify tail - return $ ObjectInt (fromIntegral r) - -inj :: [Object] -> Neovim cfg [Int16] Object -inj [x] = case fromObject x of - Right n -> do - liftIO . debugM "TestPlugins.hs" $ "updating map" - modify (n:) - startofints <- gets (take 10) - liftIO . debugM "TestPlugins.hs" $ "Updated map to: " <> show startofints - return ObjectNil - Left _ -> liftIO (debugM "TestPlugin.hs" ("wrong argument type " ++ show x)) >> return ObjectNil -inj x = liftIO (debugM "TestPlugin.hs" ("wrong argument form " ++ show x)) >> return ObjectNil - -randoom :: [Object] -> Neovim cfg st Object -randoom _ = err "Function not supported" - -const42 :: [Object] -> Neovim cfg st Object -const42 _ = return $ ObjectInt 42 - -pingNvimhs :: [Object] -> Neovim cfg st Object -pingNvimhs _ = return $ ObjectString "Pong" diff --git a/TestPlugins.sh b/TestPlugins.sh new file mode 100644 --- /dev/null +++ b/TestPlugins.sh @@ -0,0 +1,30 @@ +#!/bin/sh + +# Shell script that starts a plugin provider which is interpreted from the +# TestPlugins.hs file inside this repository. + +if [ -d ".cabal-sandbox/" ] ; then + if ! type cabal > /dev/null 2>&1 ; then + echo "cabal-install program not installed or on PATH" + echo $PATH + exit 1 + fi + + if ! type runghc > /dev/null 2>&1 ; then + echo "runghc not installed or on PATH" + echo $PATH + exit 2 + fi + # Use `cabal exec` if we are in a sandbox + exec cabal exec runghc TestPlugins.hs -- $1 -l test-log.txt -v DEBUG +elif [ -d ".stack-work" ] ; then + exec stack runghc TestPlugins.hs -- $1 -l test-log.txt -v DEBUG +else + if ! type runghc > /dev/null 2>&1 ; then + echo "runghc not installed or on PATH" + echo $PATH + exit 3 + fi + exec runghc TestPlugins.hs -- $1 -l test-log.txt -v DEBUG +fi + diff --git a/TestPlugins.vim b/TestPlugins.vim --- a/TestPlugins.vim +++ b/TestPlugins.vim @@ -6,7 +6,7 @@ " messages (something like dist/test/nvim-hs-0.0.1-hspec.log). " Initialize the plugin provider -call remote#host#Register('test', "*.l\?hs", rpcstart('./nvim-hs.sh', ['test'])) +call remote#host#Register('test', "*.l\?hs", rpcstart('./TestPlugins.sh', ['test'])) let haskellChannel = remote#host#Require('test') " We need to issue a synchornous request to make sure that the function " hooks are registered before we try to call them. Issueing this as late as @@ -52,6 +52,19 @@ let notsorandomvalue = Const42() if notsorandomvalue != 42 echom 'Expected the ultimate answer, but got: ' . notsorandomvalue + cq! +endif + +call Lazy() + +" Well, this doesn't initialize a function (yet), but it will modify the +" state of the random numbers! +call InitLazy() + +call Lazy() + +if Random() != 1337 + echom 'Expected the next random number to be 1337' cq! endif diff --git a/executable/Main.hs b/executable/Main.hs --- a/executable/Main.hs +++ b/executable/Main.hs @@ -10,8 +10,7 @@ -} module Main where -import Data.Default -import Neovim (neovim) +import Neovim (neovim, defaultConfig) main :: IO () -main = neovim def +main = neovim defaultConfig diff --git a/library/Neovim.hs b/library/Neovim.hs --- a/library/Neovim.hs +++ b/library/Neovim.hs @@ -31,6 +31,8 @@ Neovim', neovim, NeovimConfig(..), + defaultConfig, + StartupConfig(..), def, -- ** Using existing plugins @@ -40,11 +42,9 @@ -- $creatingplugins NeovimPlugin(..), Plugin(..), - NvimObject, + NvimObject(..), Dictionary, Object(..), - toObject, - fromObject, wrapPlugin, function, function', @@ -56,9 +56,9 @@ RangeSpecification(..), CommandArguments(..), AutocmdOptions(..), + addAutocmd, + addAutocmd', - -- TODO make Neovim a newtype wrapper with MonadReader and MonadState - -- implementation? ask, asks, put, @@ -83,6 +83,11 @@ -- This section contains just a bunch of more or less useful functions which -- were not introduced in any of the previous sections. liftIO, + withCustomEnvironment, + whenM, + unlessM, + Priority(..), + module Control.Monad, module Control.Applicative, module Data.Monoid, module Data.Int, @@ -90,27 +95,33 @@ ) where import Control.Applicative -import Control.Monad.IO.Class (liftIO) -import Data.Default (def) -import Data.Int (Int16, Int32, Int64, Int8) -import Data.MessagePack (Object (..)) +import 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.Text () import Neovim.API.String -import Neovim.API.TH (autocmd, command, command', function, - function') -import Neovim.Classes (Dictionary, NvimObject (..)) -import Neovim.Config (NeovimConfig (..)) -import Neovim.Context (Neovim, Neovim', ask, asks, err, get, - gets, modify, put) -import Neovim.Main (neovim) -import Neovim.Plugin.Classes (AutocmdOptions (..), - CommandArguments (..), - CommandOption (CmdSync, CmdRegister, CmdRange, CmdCount, CmdBang), - NeovimPlugin (..), Plugin (..), - RangeSpecification (..), - Synchronous (..), wrapPlugin) -import Neovim.RPC.FunctionCall (wait, wait', waitErr, waitErr') +import Neovim.API.TH (autocmd, command, command', + function, function') +import Neovim.Classes (Dictionary, NvimObject (..)) +import Neovim.Config (NeovimConfig (..)) +import Neovim.Context (Neovim, Neovim', ask, asks, err, + get, gets, modify, put) +import Neovim.Main (neovim) +import Neovim.Plugin (addAutocmd, addAutocmd') +import Neovim.Plugin.Classes (AutocmdOptions (..), + CommandArguments (..), CommandOption (CmdSync, CmdRegister, CmdRange, CmdCount, CmdBang), + RangeSpecification (..), + Synchronous (..)) +import qualified Neovim.Plugin.ConfigHelper as ConfigHelper +import Neovim.Plugin.Internal (NeovimPlugin (..), Plugin (..), + wrapPlugin) +import Neovim.Plugin.Startup (StartupConfig(..)) +import Neovim.RPC.FunctionCall (wait, wait', waitErr, waitErr') +import Neovim.Util (unlessM, whenM, + withCustomEnvironment) +import System.Log.Logger (Priority (..)) -- Installation {{{1 -- tl;dr installation {{{2 @@ -118,39 +129,35 @@ Since this is still very volatile, I recommend using a sandbox. -__Make sure that neovim's executable (@nvim@) is on your @\$PATH@ during the following steps!__ +Make sure that neovim's executable (@nvim@) is on your @\$PATH@ during the following steps! Install `nvim-hs` from git (example assumes you clone to @\$HOME\/git\/nvim-hs@) using a sandbox: @ \$ mkdir -p ~\/git ; cd ~\/git -\$ git clone https:\/\/github.com\/saep\/nvim-hs +\$ git clone https:\/\/github.com\/neovimhaskell\/nvim-hs \$ cd nvim-hs -\$ git sandbox init +\$ cabal sandbox init \$ cabal install @ -Create this executable script (e.g. @\$HOME\/bin\/nvim-hs@): +Copy the script @nvim-hs-devel.sh@ to a location you like, make it executable +and follow the brief instructions in the comments. @ -\#!\/bin\/sh - -sandbox_directory=\$HOME\/git\/nvim-hs -old_pwd="`pwd`" -cd "$sandbox_directory" -env CABAL_SANDBOX_CONFIG="$sandbox_directory"\/cabal.sandbox.config cabal \\ - exec "$sandbox_directory\/.cabal-sandbox\/bin\/nvim-hs" -- "$@" -cd "$old_pwd" +\$ cp nvim-hs-devel.sh ~\/bin\/ +\$ chmod +x ~\/bin\/nvim-hs-devel.sh @ -Put this in your neovim config file (typically @~\/.nvimrc@ or @~\/.nvim\/nvimrc@): +Assuming you have copied the script to @\$HOME\/bin\/nvim-hs-devel.sh@, +put this in your neovim config file (typically @~\/.nvimrc@ or @~\/.nvim\/nvimrc@): @ if has(\'nvim\') \" This way you can also put it in your vim config file function! s:RequireHaskellHost(name) - \" If the nvim-hs script/executable is not on your path, you should give the full path here - return rpcstart(\'nvim-hs\', [a:name.name]) + \" If the nvim-hs script\/executable is not on your path, you should give the full path here + return rpcstart(expand(\'$HOME\/bin\/nvim-hs-devel.sh\'), [a:name.name]) endfunction \" You can replace \'haskell\' in the following lines with any name you like. @@ -168,8 +175,8 @@ {- $explainedinstallation You essentially have to follow the instructions of the tl;dr subsection above, -but this subsections tells you why you need those steps and it gives you the -required knowledge do deviate from those instructions. +but this subsection tells you why you need those steps and it gives you the +required knowledge to deviate from those instructions. If you want to use or write plugins written in haskell for /nvim-hs/, you first have to make sure that neovim is installed and that it is available on your @@ -180,7 +187,7 @@ The instructions to install /nvim-hs/ should be self-explanatory. In any case, I (saep) recommend using a sandbox for now since there is no stable hackage -release yet and a few librarier are newer than what is currently in stackage +release yet and a few libraries are newer than what is currently in stackage (namely mtl, which is a big deal). Using a sandbox requires you to install all the libraries you want or have to use in your plugins to be installed inside the sandbox! Some Vim plugins (e.g. ghc-mod) may show weird errors inside neovim for @@ -190,15 +197,13 @@ list automatically after you save your configuration file, so you don't need another plugin to detect compile time errors here. But we will discuss this later in more detail. The executable script sets up the build environment for -/nvim-hs/ to use the sandbox. You should only have to adjust the path for the -`sandbox_directory` variable there if you did not install /nvim-hs/ in a sandbox -located at `\$HOME\/git\/nvim-hs`. +/nvim-hs/ to use the sandbox. The Vim-script snippet is a bit lengthy, but the comments should explain how it works. In any case, the snippet can be put anywhere in your neovim configuration file and the last call of `rpcrequest` is not needed if you don't call any functionality before /nvim-hs/ has started properly. Removing the call can -improve the startup time. If you only need some functionality for haskell source +improve the startup time. If you only need some functionality for Haskell source files, you could move those last (or the last two) lines at the top of @\$HOME\/.nvim\/ftplugin\/haskell.vim@. You may wonder why we have to explicitly call 'PingNvimhs' with the function `rpcrequest` here. The short answer is: @@ -218,7 +223,7 @@ Using /nvim-hs/ essentially means to use a static binary that incorporates all plugins. It is generated using the 'Dyre' library and the binary itself is found -in @\$XDG_CACHE_DIR\/nvim@ (usually @~\/.cache\/nvim). The 'Dyre' library makes +in @\$XDG_CACHE_DIR\/nvim@ (usually @~\/.cache\/nvim@). The 'Dyre' library makes it feel more like a scripting language, because the binary is automatically created and executed without having to restart neovim. @@ -236,12 +241,31 @@ \{\-\# LANGUAGE TemplateHaskell \#\-\} import Neovim -main = 'neovim' 'def' +main = 'neovim' 'defaultConfig' @ Adjust the fields in @def@ according to the the parameters in 'NeovimConfig'. -} + + +-- | Default configuration options for /nvim-hs/. If you want to keep the +-- default plugins enabled, you can define you rconfig like this: +-- +-- @ +-- main = 'neovim' 'defaultConfig' +-- { plugins = myPlugins ++ plugins defaultConfig +-- } +-- @ +-- +defaultConfig :: NeovimConfig +defaultConfig = Config + { plugins = [ ConfigHelper.plugin ] + , logOptions = Nothing + , errorMessage = Nothing + } + + -- 2}}} -- Existing Plugins {{{2 @@ -308,7 +332,7 @@ fibonacci n = 'show' $ fibs !! n where fibs :: ['Integer'] - fibs = 1:1:'scanl1' (+) fibs + fibs = 0:1:'scanl1' (+) fibs @ File @~\/.config\/nvim\/nvim.hs@: @@ -371,7 +395,7 @@ necessary information to properly register the function with neovim. Note the prime symbol before the function name! This would have probably caused you some trouble if I haven't mentioned it here! Template Haskell simply requires -you to put that in from of function names that are passed in a splice. +you to put that in front of function names that are passed in a splice. If you compile this (which should happen automatically if you have put those files at the appropriate places), you can calculate the 287323rd Fibonacci number diff --git a/library/Neovim/API/Parser.hs b/library/Neovim/API/Parser.hs --- a/library/Neovim/API/Parser.hs +++ b/library/Neovim/API/Parser.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {- | Module : Neovim.API.Parser @@ -22,7 +23,6 @@ import Control.Exception.Lifted import Control.Monad.Except import qualified Data.ByteString as B -import qualified Data.ByteString.UTF8 as U import Data.Map (Map) import qualified Data.Map as Map import Data.MessagePack @@ -34,36 +34,45 @@ import Prelude + data NeovimType = SimpleType String | NestedType NeovimType (Maybe Int) | Void deriving (Show, Eq) + -- | This data type contains simple information about a function as received -- throudh the @nvim --api-info@ command. data NeovimFunction = NeovimFunction { name :: String -- ^ function name + , parameters :: [(NeovimType, String)] -- ^ A list of type name and variable name. + , canFail :: Bool -- ^ Indicator whether the function can fail/throws exceptions. - , deferred :: Bool + + , async :: Bool -- ^ Indicator whether the this function is asynchronous. + , returnType :: NeovimType -- ^ Functions return type. } deriving (Show) + -- | This data type represents the top-level structure of the @nvim --api-info@ -- output. data NeovimAPI = NeovimAPI { errorTypes :: [(String, Int64)] -- ^ The error types are defined by a name and an identifier. + , customTypes :: [(String, Int64)] -- ^ Extension types defined by neovim. + , functions :: [NeovimFunction] -- ^ The remotely executable functions provided by the neovim api. } @@ -71,73 +80,81 @@ -- | Run @nvim --api-info@ and parse its output. parseAPI :: IO (Either String NeovimAPI) -parseAPI = join . fmap (runExcept . extractAPI) <$> runExceptT decodeAPI +parseAPI = join . fmap extractAPI <$> decodeAPI -extractAPI :: Object -> Except String NeovimAPI + +extractAPI :: Object -> Either String NeovimAPI extractAPI apiObj = NeovimAPI <$> extractErrorTypes apiObj <*> extractCustomTypes apiObj <*> extractFunctions apiObj -decodeAPI :: ExceptT String IO Object + +decodeAPI :: IO (Either String Object) decodeAPI = bracket queryNeovimAPI clean $ \(out, _) -> - either throwError return =<< decode <$> lift (B.hGetContents out) + decode <$> B.hGetContents out where queryNeovimAPI = do - (_, Just out, _, ph) <- lift . createProcess $ + (_, Just out, _, ph) <- createProcess $ (proc "nvim" ["--api-info"]) { std_out = CreatePipe } return (out, ph) - clean (out, ph) = lift $ do + clean (out, ph) = do hClose out terminateProcess ph -oMap :: Object -> Except String (Map Object Object) -oMap o = case o of - ObjectMap m -> return m - _ -> throwError $ "Object is not a map: " ++ show o -oLookup :: Object -> Object -> Except String Object +oMap :: Object -> Either String (Map Object Object) +oMap = \case + ObjectMap m -> + return m + + o -> + throwError $ "Object is not a map: " ++ show o + + +oLookup :: Object -> Object -> Either String Object oLookup qry o = oMap o >>= maybe (throwError ("No entry for" <> show qry)) return . Map.lookup qry -oLookupDefault :: Object -> Object -> Object -> Except String Object + +oLookupDefault :: Object -> Object -> Object -> Either String Object oLookupDefault d qry o = oMap o >>= maybe (return d) return . Map.lookup qry + -- | Extract a 'String' from on 'Object'. -- -- Works on @ObjectBinary@ and @ObjectString@ constructor. -oToString :: Object -> Except String String -oToString o = case o of - ObjectBinary bs -> return $ U.toString bs - ObjectString t -> return $ U.toString t - _ -> throwError $ show o <> " is not convertible to a String." +oToString :: Object -> Either String String +oToString = fromObject + -- ObjectBinary bs -> return $ U.toString bs + -- ObjectString t -> return $ U.toString t + -- o -> throwError $ show o <> " is not convertible to a String." + -- | Extract an 'Int64' from an @Object@. -- -oInt :: Object -> Except String Int64 -oInt o = case o of - ObjectInt i -> return i - _ -> throwError $ show o <> " is not an Int64." +oInt :: Object -> Either String Int64 +oInt = fromObject -oArr :: Object -> Except String [Object] -oArr o = case o of - ObjectArray os -> return os - _ -> throwError $ show o <> " is not an Array." -oToBool :: Object -> Except String Bool -oToBool o = case o of - ObjectBool b -> return b - _ -> throwError $ show o <> " is not a boolean." +oArr :: Object -> Either String [Object] +oArr = fromObject -extractErrorTypes :: Object -> Except String [(String, Int64)] + +oToBool :: Object -> Either String Bool +oToBool = fromObject + + +extractErrorTypes :: Object -> Either String [(String, Int64)] extractErrorTypes objAPI = extractTypeNameAndID =<< oLookup (ObjectBinary "error_types") objAPI -extractTypeNameAndID :: Object -> Except String [(String, Int64)] + +extractTypeNameAndID :: Object -> Either String [(String, Int64)] extractTypeNameAndID m = do types <- Map.toList <$> oMap m forM types $ \(errName, idMap) -> do @@ -145,47 +162,55 @@ i <- oInt =<< oLookup (ObjectBinary "id") idMap return (n,i) -extractCustomTypes :: Object -> Except String [(String, Int64)] + +extractCustomTypes :: Object -> Either String [(String, Int64)] extractCustomTypes objAPI = extractTypeNameAndID =<< oLookup (ObjectBinary "types") objAPI -extractFunctions :: Object -> Except String [NeovimFunction] + +extractFunctions :: Object -> Either String [NeovimFunction] extractFunctions objAPI = do funList <- oArr =<< oLookup (ObjectBinary "functions") objAPI forM funList extractFunction -toParameterlist :: [Object] -> Except String [(NeovimType, String)] + +toParameterlist :: [Object] -> Either String [(NeovimType, String)] toParameterlist ps = forM ps $ \p -> do [t, n] <- mapM oToString =<< oArr p t' <- parseType t return (t', n) -extractFunction :: Object -> Except String NeovimFunction +extractFunction :: Object -> Either String NeovimFunction extractFunction funDefMap = NeovimFunction <$> (oLookup (ObjectBinary "name") funDefMap >>= oToString) <*> (oLookup (ObjectBinary "parameters") funDefMap >>= oArr >>= toParameterlist) <*> (oLookupDefault (ObjectBool False) (ObjectBinary "can_fail") funDefMap >>= oToBool) - <*> (oLookup (ObjectBinary "deferred") funDefMap >>= oToBool) + <*> (oLookup (ObjectBinary "async") funDefMap >>= oToBool) <*> (oLookup (ObjectBinary "return_type") funDefMap >>= oToString >>= parseType) -parseType :: String -> Except String NeovimType +parseType :: String -> Either String NeovimType parseType s = either (throwError . show) return $ parse (pType <* eof) s s + pType :: Parsec String u NeovimType pType = pArray P.<|> pVoid P.<|> pSimple + pVoid :: Parsec String u NeovimType pVoid = const Void <$> (P.try (string "void") <* eof) + pSimple :: Parsec String u NeovimType pSimple = SimpleType <$> many1 (noneOf ",)") + pArray :: Parsec String u NeovimType pArray = NestedType <$> (P.try (string "ArrayOf(") *> pType) <*> optionMaybe pNum <* char ')' + pNum :: Parsec String u Int pNum = read <$> (P.try (char ',') *> spaces *> many1 (oneOf ['0'..'9'])) diff --git a/library/Neovim/API/TH.hs b/library/Neovim/API/TH.hs --- a/library/Neovim/API/TH.hs +++ b/library/Neovim/API/TH.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {- | @@ -18,6 +19,7 @@ , command' , autocmd , defaultAPITypeToHaskellTypeMap + , module Control.Exception.Lifted , module Neovim.Classes , module Data.Data @@ -29,9 +31,10 @@ import Neovim.Context import Neovim.Plugin.Classes (CommandArguments (..), CommandOption (..), - ExportedFunctionality (..), FunctionalityDescription (..), + FunctionName(..), mkCommandOptions) +import Neovim.Plugin.Internal (ExportedFunctionality (..)) import Neovim.RPC.FunctionCall import Language.Haskell.TH @@ -43,6 +46,7 @@ import Control.Exception.Lifted import Control.Monad import Data.ByteString (ByteString) +import Data.ByteString.UTF8 (fromString) import Data.Char (isUpper, toUpper) import Data.Data (Data, Typeable) import Data.Map (Map) @@ -51,7 +55,7 @@ import Data.MessagePack import Data.Monoid import qualified Data.Set as Set -import Data.Text (Text, pack) +import Data.Text (Text) import Prelude @@ -61,7 +65,7 @@ -- 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', +-- provides a Convenient way to replace the /String/ type with 'Text', -- 'ByteString' or 'String'. generateAPI :: Map String (Q Type) -> Q [Dec] generateAPI typeMap = do @@ -129,15 +133,16 @@ -- createFunction :: Map String (Q Type) -> NeovimFunction -> Q [Dec] createFunction typeMap nf = do - let withDeferred | deferred nf = appT [t|STM|] + let withDeferred | async nf = appT [t|STM|] | otherwise = id + withException | canFail nf = appT [t|Either Object|] | otherwise = id - callFn | deferred nf && canFail nf = [|acall|] - | deferred nf = [|acall'|] - | canFail nf = [|scall|] - | otherwise = [|scall'|] + callFn | async nf && canFail nf = [|acall|] + | async nf = [|acall'|] + | canFail nf = [|scall|] + | otherwise = [|scall'|] functionName = (mkName . name) nf toObjVar v = [|toObject $(varE v)|] @@ -159,7 +164,7 @@ [ clause (map (varP . snd) vars) (normalB (callFn - `appE` ([| pack |] `appE` (litE . stringL . name) nf) + `appE` ([| (F . fromString) |] `appE` (litE . stringL . name) nf) `appE` listE (map (toObjVar . snd) vars))) [] ] @@ -186,7 +191,7 @@ -- | If the first parameter is @mkName NeovimException@, this function will --- generate @instance Exception NeovimException"@. +-- generate @instance Exception NeovimException@. exceptionInstance :: Name -> Q [Dec] exceptionInstance exceptionName = return <$> instanceD @@ -246,14 +251,14 @@ -- -- Note that the name must start with an upper case letter. -- --- Example: @ $(function "MyExportedFunction" 'myDefinedFunction) def @ +-- Example: @ $(function \"MyExportedFunction\" 'myDefinedFunction) 'Sync' @ function :: String -> Name -> Q Exp function [] _ = error "Empty names are not allowed for exported functions." function customName@(c:_) functionName | (not . isUpper) c = error $ "Custom function name must start with a capiatl letter: " <> show customName | otherwise = do (_, fun) <- functionImplementation functionName - [|\funOpts -> EF (Function (pack $(litE (StringL customName))) funOpts, $(return fun)) |] + [|\funOpts -> EF (Function (F (fromString $(litE (StringL customName)))) funOpts, $(return fun)) |] -- | Define an exported function. This function works exactly like 'function', @@ -269,10 +274,10 @@ -- 'ByteString' for a value of type. data ArgType = StringyType | ListOfStringyTypes - | OptionalStringyType + | Optional ArgType | CommandArgumentsType | OtherType - deriving (Eq, Ord, Show, Read, Enum, Bounded) + deriving (Eq, Ord, Show, Read) -- | Given a value of type 'Type', test whether it can be classified according @@ -282,19 +287,19 @@ set <- genStringTypesSet maybeType <- [t|Maybe|] cmdArgsType <- [t|CommandArguments|] - return $ case t of + case t of AppT ListT (ConT str) | str `Set.member` set - -> ListOfStringyTypes + -> return ListOfStringyTypes - AppT m (ConT str) | m == maybeType && str `Set.member` set - -> OptionalStringyType + AppT m mt@(ConT _) | m == maybeType + -> Optional <$> classifyArgType mt ConT str | str `Set.member` set - -> StringyType + -> return StringyType cmd | cmd == cmdArgsType - -> CommandArgumentsType + -> return CommandArgumentsType - _ -> OtherType + _ -> return OtherType where genStringTypesSet = do @@ -306,6 +311,26 @@ -- 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' r st () +-- +-- * 'CommandArguments' -> 'Maybe' 'String' -> 'Neovim' r st () +-- +-- * 'CommandArguments' -> 'String' -> 'Neovim' r st () +-- +-- * 'CommandArguments' -> ['String'] -> 'Neovim' r st () +-- +-- * 'CommandArguments' -> 'String' -> ['String'] -> 'Neovim' r st () +-- +-- 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 convienient sorting. You should +-- simply not defined the same option twice. command :: String -> Name -> Q Exp command [] _ = error "Empty names are not allowed for exported commands." command customFunctionName@(c:_) functionName @@ -313,14 +338,13 @@ | otherwise = do (argTypes, fun) <- functionImplementation functionName -- See :help :command-nargs for what the result strings mean - cts <- mapM classifyArgType argTypes - case cts of + case argTypes of (CommandArgumentsType:_) -> return () _ -> error "First argument for a function exported as a command must be CommandArguments!" - let nargs = case tail cts of + let nargs = case tail argTypes of [] -> [|CmdNargs "0"|] [StringyType] -> [|CmdNargs "1"|] - [OptionalStringyType] -> [|CmdNargs "?"|] + [Optional StringyType] -> [|CmdNargs "?"|] [ListOfStringyTypes] -> [|CmdNargs "*"|] [StringyType, ListOfStringyTypes] -> [|CmdNargs "+"|] _ -> error $ unlines @@ -331,7 +355,7 @@ , "explanation." ] [|\copts -> EF (Command - (pack $(litE (StringL customFunctionName))) + (F (fromString $(litE (StringL customFunctionName)))) (mkCommandOptions ($(nargs) : copts)) , $(return fun))|] @@ -343,17 +367,40 @@ in command (toUpper c:cs) functionName --- | Define an autocmd. This function generates an export for autocmd. Since --- this is a static registration, arguments are not allowed here. You can of --- course define a fully applied functions and pass it as an arguments. +-- | 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 - (_, fun) <- functionImplementation functionName - [|\t acmdOpts -> EF (Autocmd t (pack $(litE (StringL (toUpper c : cs)))) acmdOpts, $(return fun))|] + (as, fun) <- functionImplementation functionName + case as of + [] -> + [|\t acmdOpts -> EF (Autocmd t (F (fromString $(litE (StringL (toUpper c : cs))))) 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. -- @@ -371,15 +418,17 @@ -- _ -> err $ "Wrong number of arguments for add: " ++ show xs -- @ -- -functionImplementation :: Name -> Q ([Type], Exp) +functionImplementation :: Name -> Q ([ArgType], Exp) functionImplementation functionName = do fInfo <- reify functionName - -- We only need the number of arguments to generate the appropriate function - let nargs = case fInfo of - VarI _ functionType _ _ -> determineNumberOfArguments functionType - x -> error $ "Value given to function is (likely) not the name of a function.\n" - <> show x - e <- topLevelCase (length nargs) + 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 @@ -389,9 +438,13 @@ AppT (AppT ArrowT t) r -> t : determineNumberOfArguments r _ -> [] -- \args -> case args of ... - topLevelCase :: Int -> Q Exp - topLevelCase n = newName "args" >>= \args -> - lamE [varP args] (caseE (varE args) [matchingCase n, errorCase]) + 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 @@ -400,18 +453,24 @@ ++ $(litE (StringL (nameBase functionName))) |]) [] -- [x,y] -> case pure add <*> fromObject x <*> fromObject y of ... - matchingCase :: Int -> Q Match - matchingCase n = mapM (\_ -> newName "x") [1..n] >>= \vars -> - match (listP (map varP vars)) + 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 (repeat [|(<*>)|]))) + (zip (vars ++ optVars) (repeat [|(<*>)|]))) [successfulEvaluation, failedEvaluation])) [] - genArgumentCast :: Q Exp -> (Name, Q Exp) -> Q Exp - genArgumentCast e (v,op) = infixE (Just e) op (Just [|fromObject $(varE v)|]) + 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 -> diff --git a/library/Neovim/Classes.hs b/library/Neovim/Classes.hs --- a/library/Neovim/Classes.hs +++ b/library/Neovim/Classes.hs @@ -19,21 +19,22 @@ , Dictionary , module Data.Int + , module Data.Word ) where -import Neovim.Context import Control.Applicative import Control.Arrow import Control.Monad.Except import Data.ByteString (ByteString) -import Data.Int (Int16, Int32, Int64) +import Data.Int (Int16, Int32, Int64, Int8) import Data.Map (Map) import qualified Data.Map as Map import Data.MessagePack import Data.Monoid import Data.Text as Text (Text) import Data.Traversable hiding (forM, mapM) +import Data.Word (Word, Word16, Word32, Word64, Word8) import Prelude @@ -133,6 +134,60 @@ fromObject o = throwError $ "Expected any Integer value, but got " <> show o +instance NvimObject Int8 where + toObject = ObjectInt . fromIntegral + + fromObject (ObjectInt i) = return $ fromIntegral i + fromObject (ObjectDouble o) = return $ round o + fromObject (ObjectFloat o) = return $ round o + fromObject o = throwError $ "Expected any Integer value, but got " <> show o + + +instance NvimObject Word where + toObject = ObjectInt . fromIntegral + + fromObject (ObjectInt i) = return $ fromIntegral i + fromObject (ObjectDouble o) = return $ round o + fromObject (ObjectFloat o) = return $ round o + fromObject o = throwError $ "Expected any Integer value, but got " <> show o + + +instance NvimObject Word64 where + toObject = ObjectInt . fromIntegral + + fromObject (ObjectInt i) = return $ fromIntegral i + fromObject (ObjectDouble o) = return $ round o + fromObject (ObjectFloat o) = return $ round o + fromObject o = throwError $ "Expected any Integer value, but got " <> show o + + +instance NvimObject Word32 where + toObject = ObjectInt . fromIntegral + + fromObject (ObjectInt i) = return $ fromIntegral i + fromObject (ObjectDouble o) = return $ round o + fromObject (ObjectFloat o) = return $ round o + fromObject o = throwError $ "Expected any Integer value, but got " <> show o + + +instance NvimObject Word16 where + toObject = ObjectInt . fromIntegral + + fromObject (ObjectInt i) = return $ fromIntegral i + fromObject (ObjectDouble o) = return $ round o + fromObject (ObjectFloat o) = return $ round o + fromObject o = throwError $ "Expected any Integer value, but got " <> show o + + +instance NvimObject Word8 where + toObject = ObjectInt . fromIntegral + + fromObject (ObjectInt i) = return $ fromIntegral i + fromObject (ObjectDouble o) = return $ round o + fromObject (ObjectFloat o) = return $ round o + fromObject o = throwError $ "Expected any Integer value, but got " <> show o + + instance NvimObject Int where toObject = ObjectInt . fromIntegral @@ -172,6 +227,23 @@ fromObject o = either throwError (return . Just) $ fromObject 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 (Map key val) where toObject = ObjectMap @@ -209,16 +281,16 @@ -- By the magic of vim, i will create these. -instance NvimObject o => NvimObject (o, o) where - toObject (o1, o2) = ObjectArray $ map toObject [o1, o2] +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 " <> show o -instance NvimObject o => NvimObject (o, o, o) where - toObject (o1, o2, o3) = ObjectArray $ map toObject [o1, o2, o3] +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 @@ -227,8 +299,8 @@ fromObject o = throwError $ "Expected ObjectArray, but got " <> show o -instance NvimObject o => NvimObject (o, o, o, o) where - toObject (o1, o2, o3, o4) = ObjectArray $ map toObject [o1, o2, o3, o4] +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 @@ -238,8 +310,8 @@ fromObject o = throwError $ "Expected ObjectArray, but got " <> show o -instance NvimObject o => NvimObject (o, o, o, o, o) where - toObject (o1, o2, o3, o4, o5) = ObjectArray $ map toObject [o1, o2, o3, o4, o5] +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 @@ -250,8 +322,8 @@ fromObject o = throwError $ "Expected ObjectArray, but got " <> show o -instance NvimObject o => NvimObject (o, o, o, o, o, o) where - toObject (o1, o2, o3, o4, o5, o6) = ObjectArray $ map toObject [o1, o2, o3, o4, o5, o6] +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 @@ -263,8 +335,8 @@ fromObject o = throwError $ "Expected ObjectArray, but got " <> show o -instance NvimObject o => NvimObject (o, o, o, o, o, o, o) where - toObject (o1, o2, o3, o4, o5, o6, o7) = ObjectArray $ map toObject [o1, o2, o3, o4, o5, o6, o7] +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 @@ -277,8 +349,8 @@ fromObject o = throwError $ "Expected ObjectArray, but got " <> show o -instance NvimObject o => NvimObject (o, o, o, o, o, o, o, o) where - toObject (o1, o2, o3, o4, o5, o6, o7, o8) = ObjectArray $ map toObject [o1, o2, o3, o4, o5, o6, o7, o8] +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 @@ -292,8 +364,8 @@ fromObject o = throwError $ "Expected ObjectArray, but got " <> show o -instance NvimObject o => NvimObject (o, o, o, o, o, o, o, o, o) where - toObject (o1, o2, o3, o4, o5, o6, o7, o8, o9) = ObjectArray $ map toObject [o1, o2, o3, o4, o5, o6, o7, o8, o9] +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 diff --git a/library/Neovim/Config.hs b/library/Neovim/Config.hs --- a/library/Neovim/Config.hs +++ b/library/Neovim/Config.hs @@ -10,35 +10,28 @@ -} module Neovim.Config ( NeovimConfig(..), - module Data.Default, module System.Log, ) where -import Neovim.Plugin.Classes (NeovimPlugin) +import Neovim.Context (Neovim) +import Neovim.Plugin.Internal (NeovimPlugin) +import Neovim.Plugin.Startup (StartupConfig) -import qualified Config.Dyre as Dyre -import Data.Default (Default (def)) -import System.Log (Priority (..)) +import System.Log (Priority (..)) data NeovimConfig = Config - { plugins :: [IO NeovimPlugin] + { plugins :: [Neovim (StartupConfig NeovimConfig) () NeovimPlugin] -- ^ The list of plugins. The IO type inside the list allows the plugin -- author to run some arbitrary startup code before creating a value of -- type 'NeovimPlugin'. - , errorMessage :: Maybe String - -- ^ Used by 'Dyre' for storing compilation errors. + , logOptions :: Maybe (FilePath, Priority) -- ^ Set the general logging options. - , dyreParams :: Maybe (Dyre.Params NeovimConfig) - -- ^ Parmaeters used by 'Dyre'. This is only used for the - -- "Neovim.Plugin.ConfigHelper" plugin. - } -instance Default NeovimConfig where - def = Config - { plugins = [] - , errorMessage = Nothing - , logOptions = Nothing - , dyreParams = Nothing - } + , errorMessage :: Maybe String + -- ^ Internally used field. Changing this has no effect. + -- + -- Used by 'Dyre' for storing compilation errors. + + } diff --git a/library/Neovim/Context.hs b/library/Neovim/Context.hs --- a/library/Neovim/Context.hs +++ b/library/Neovim/Context.hs @@ -11,109 +11,44 @@ -} module Neovim.Context ( - asks, - ask, - eventQueue, - - get, - put, - modify, - gets, + newUniqueFunctionName, Neovim, Neovim', NeovimException(..), - ConfigWrapper(..), + FunctionMap, + FunctionMapEntry, + mkFunctionMap, runNeovim, forkNeovim, err, restart, quit, - QuitAction(..), + ask, + asks, + get, + gets, + put, + modify, + throwError, module Control.Monad.IO.Class, ) where -import Control.Concurrent (MVar, ThreadId, forkIO, putMVar) -import Control.Concurrent.STM +import Neovim.Context.Internal (FunctionMap, FunctionMapEntry, Neovim, + Neovim', forkNeovim, mkFunctionMap, + newUniqueFunctionName, runNeovim) +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 hiding (ask, asks) -import qualified Control.Monad.Reader as R +import Control.Monad.Reader import Control.Monad.State -import Data.Data (Typeable) -import Neovim.Plugin.IPC (SomeMessage) -import System.Log.Logger - - --- | A wrapper for a reader value that contains extra fields required to --- communicate with the messagepack-rpc components. -data ConfigWrapper a = ConfigWrapper - { _eventQueue :: TQueue SomeMessage - -- ^ A queue of messages that the event handler will propagate to - -- appropriate threads and handlers. - , _quit :: MVar QuitAction - -- ^ The main thread will wait for this 'MVar' to be filled with a value - -- and then perform an action appropriate for the value of type - -- 'QuitAction'. - , _providerName :: String - -- ^ Name that is used to identify this provider. Assigning such a name is - -- done in the neovim config (e.g. ~\/.nvim\/nvimrc). - , customConfig :: a - -- ^ Plugin author supplyable custom configuration. It can be queried via - -- 'myConf'. - } - - -data QuitAction = Quit - -- ^ Quit the plugin provider. - | Restart - -- ^ Restart the plugin provider. - deriving (Show, Read, Eq, Ord, Enum, Bounded) - - -eventQueue :: Neovim r st (TQueue SomeMessage) -eventQueue = R.asks _eventQueue - - --- | This is the environment in which all plugins are initially started. --- Stateless functions use '()' for the static configuration and the mutable --- state and there is another type alias for that case: 'Neovim''. --- --- Functions have to run in this transformer stack to communicate with neovim. --- If parts of your own functions dont need to communicate with neovim, it is --- good practice to factor them out. This allows you to write tests and spot --- errors easier. Essentially, you should treat this similar to 'IO' in general --- haskell programs. -type Neovim r st = StateT st (ReaderT (ConfigWrapper r) IO) - - --- | Convenience alias for @'Neovim' () ()@. -type Neovim' = Neovim () () - - --- | Initialize a 'Neovim' context by supplying an 'InternalEnvironment'. -runNeovim :: ConfigWrapper r - -> st - -> Neovim r st a - -> IO (Either String (a, st)) -runNeovim r st a = (try . runReaderT (runStateT a st)) r >>= \case - Left e -> do - liftIO . errorM "Context" $ "Converting Exception to Error message: " ++ show e - return . Left $ show (e :: SomeException) - Right res -> return $ Right res - - --- | Fork a neovim thread with the given custom config value and a custom --- state. The result of the thread is discarded and only the 'ThreadId' is --- returend immediately. -forkNeovim :: ir -> ist -> Neovim ir ist a -> Neovim r st ThreadId -forkNeovim r st a = do - cfg <- R.ask - liftIO . forkIO . void $ runNeovim (cfg { customConfig = r }) st a +import Data.Data (Typeable) data NeovimException @@ -128,24 +63,12 @@ err = throw . ErrorMessage --- | Retrieve something from the configuration with respect to the first --- function. Works exactly like 'R.asks'. -asks :: (r -> a) -> Neovim r st a -asks q = R.asks (q . customConfig) - - --- | Retrieve the Cunfiguration (i.e. read-only state) from the 'Neovim' --- context. -ask :: Neovim r st r -ask = R.asks customConfig - - -- | Initiate a restart of the plugin provider. restart :: Neovim r st () -restart = liftIO . flip putMVar Restart =<< R.asks _quit +restart = liftIO . flip putMVar Internal.Restart =<< Internal.asks' Internal.quit -- | Initiate the termination of the plugin provider. quit :: Neovim r st () -quit = liftIO . flip putMVar Quit =<< R.asks _quit +quit = liftIO . flip putMVar Internal.Quit =<< Internal.asks' Internal.quit diff --git a/library/Neovim/Context/Internal.hs b/library/Neovim/Context/Internal.hs new file mode 100644 --- /dev/null +++ b/library/Neovim/Context/Internal.hs @@ -0,0 +1,261 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# 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.Plugin.Classes +import Neovim.Plugin.IPC (SomeMessage) + +import Control.Applicative +import Control.Concurrent (ThreadId, forkIO) +import Control.Concurrent (MVar, newEmptyMVar) +import Control.Concurrent.STM +import Control.Monad.Base +import Control.Monad.Catch +import Control.Monad.Except +import Control.Monad.Reader +import Control.Monad.State +import Control.Monad.Trans.Resource +import Data.ByteString.UTF8 (fromString) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.MessagePack (Object) +import System.Log.Logger + +import Prelude + + +-- | This is the environment in which all plugins are initially started. +-- Stateless functions use '()' for the static configuration and the mutable +-- state and there is another type alias for that case: 'Neovim''. +-- +-- Functions have to run in this transformer stack to communicate with neovim. +-- If parts of your own functions dont need to communicate with neovim, it is +-- good practice to factor them out. This allows you to write tests and spot +-- errors easier. Essentially, you should treat this similar to 'IO' in general +-- haskell programs. +newtype Neovim r st a = Neovim + { unNeovim :: ResourceT (StateT st (ReaderT (Config r st) IO)) a } + + deriving (Functor, Applicative, Monad, MonadIO, MonadState st + , MonadThrow, MonadCatch, MonadMask, MonadResource) + + +instance MonadBase IO (Neovim r st) where + liftBase = liftIO + + +-- | User facing instance declaration for the reader state. +instance MonadReader r (Neovim r st) where + ask = Neovim $ asks customConfig + local f (Neovim a) = do + r <- Neovim $ ask + s <- get + fmap fst . liftIO $ runReaderT (runStateT (runResourceT a) s) + (r { customConfig = f (customConfig r)}) + + +-- | Same as 'ask' for the 'InternalConfig'. +ask' :: Neovim r st (Config r st) +ask' = Neovim $ ask + + +-- | Same as 'asks' for the 'InternalConfig'. +asks' :: (Config r st -> a) -> Neovim r st a +asks' = Neovim . asks + +-- | Convenience alias for @'Neovim' () ()@. +type Neovim' = Neovim () () + + +-- | Initialize a 'Neovim' context by supplying an 'InternalEnvironment'. +runNeovim :: Config r st + -> st + -> Neovim r st a + -> IO (Either String (a, st)) +runNeovim r st (Neovim a) = (try . runReaderT (runStateT (runResourceT a) st)) r >>= \case + Left e -> do + liftIO . errorM "Context" $ "Converting Exception to Error message: " ++ show e + return . Left $ show (e :: SomeException) + Right res -> return $ Right res + + +-- | Fork a neovim thread with the given custom config value and a custom +-- state. The result of the thread is discarded and only the 'ThreadId' is +-- returend immediately. +-- FIXME This function is pretty much unused and mayhave undesired effects, +-- namely that you cannot register autocmds in the forked thread. +forkNeovim :: ir -> ist -> Neovim ir ist a -> Neovim r st ThreadId +forkNeovim r st a = do + cfg <- ask' + let threadConfig = cfg + { pluginSettings = Nothing -- <- slightly problematic + , customConfig = r + } + liftIO . forkIO . void $ runNeovim threadConfig st a + + +-- | Create a new unique function name. To prevent possible name clashes, digits +-- are stripped from the given suffix. +newUniqueFunctionName :: Neovim r st 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 . fromString . 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. +data FunctionType + = Stateless ([Object] -> Neovim' Object) + -- ^ 'Stateless' functions are simply executed with the sent arguments. + + | Stateful (TQueue SomeMessage) + -- ^ 'Stateful' functions are handled within a special thread, the 'TQueue' + -- is the communication endpoint for the arguments we have to pass. + + +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 FunctionName FunctionMapEntry + + +-- | Create a new function map from the given list of 'FunctionMapEntry' values. +mkFunctionMap :: [FunctionMapEntry] -> FunctionMap +mkFunctionMap = Map.fromList . map (\e -> (name (fst e), e)) + + +-- | 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 r st = Config + -- Global settings; initialized once + { eventQueue :: TQueue SomeMessage + -- ^ A queue of messages that the event handler will propagate to + -- appropriate threads and handlers. + + , quit :: MVar QuitAction + -- ^ The main thread will wait for this 'MVar' to be filled with a value + -- and then perform an action appropriate for the value of type + -- 'QuitAction'. + + , providerName :: 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 r st) + + , customConfig :: r + -- ^ 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 :: r -> st -> Config anotherR anotherSt -> Config r st +retypeConfig r _ cfg = cfg { pluginSettings = Nothing, customConfig = r } + + +-- | This GADT is used to share informatino 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 r st where + StatelessSettings + :: (FunctionalityDescription + -> ([Object] -> Neovim' Object) + -> Neovim' (Maybe FunctionMapEntry)) + -> PluginSettings () () + + StatefulSettings + :: (FunctionalityDescription + -> ([Object] -> Neovim r st Object) + -> TQueue SomeMessage + -> TVar (Map FunctionName ([Object] -> Neovim r st Object)) + -> Neovim r st (Maybe FunctionMapEntry)) + -> TQueue SomeMessage + -> TVar (Map FunctionName ([Object] -> Neovim r st Object)) + -> PluginSettings r st + + +-- | 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 r -> IO (Config r context) +newConfig ioProviderName r = Config + <$> newTQueueIO + <*> newEmptyMVar + <*> (maybe (atomically newEmptyTMVar) (newTMVarIO . Left) =<< ioProviderName) + <*> newTVarIO 100 + <*> atomically newEmptyTMVar + <*> pure Nothing + <*> r + + +data QuitAction = Quit + -- ^ Quit the plugin provider. + + | Restart + -- ^ Restart the plugin provider. + + | Failure String + -- ^ The plugin provider failed to start or some other error + -- occured. + + | InitSuccess + -- ^ The plugin provider started successfully. + + deriving (Show, Read, Eq, Ord) diff --git a/library/Neovim/Debug.hs b/library/Neovim/Debug.hs --- a/library/Neovim/Debug.hs +++ b/library/Neovim/Debug.hs @@ -1,56 +1,124 @@ +{-# LANGUAGE LambdaCase #-} {- | Module : Neovim.Debug -Description : Debugging facilities +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 ( - disableLogger, - withLogger, + debug, + debug', + develMain, - module System.Log.Logger, + runNeovim, + runNeovim', + module Neovim, ) where -import Control.Exception -import System.Log.Formatter (simpleLogFormatter) -import System.Log.Handler (setFormatter) -import System.Log.Handler.Simple -import System.Log.Logger +import Neovim +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) --- | Disable logging to stderr. -disableLogger :: IO a -> IO a -disableLogger action = do - updateGlobalLogger rootLoggerName removeHandler - action +import Control.Concurrent +import Control.Monad +import Foreign.Store --- | 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. +import Prelude + + +-- | Run a 'Neovim' function. +-- +-- This function connects to the socket pointed to by the environment variable +-- @$NVIM_LISTEN_ADDRESS@ 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 :: r -> st -> Internal.Neovim r st a -> IO (Either String (a, st)) +debug r st a = disableLogger $ do + runPluginProvider def { env = True } Nothing finalizer Nothing + where + finalizer tids cfg = takeMVar (Internal.quit cfg) >>= \case + Internal.Failure e -> + return $ Left e + + Internal.InitSuccess -> do + res <- Internal.runNeovim + (cfg { Internal.customConfig = r, Internal.pluginSettings = Nothing }) + st + a + + mapM_ killThread tids + return res + + _ -> + return $ Left "Unexpected finalizer state." + + +-- | Run a 'Neovim'' function. +-- -- @ --- main = withLogger "/home/dude/nvim.log" Debug $ do --- putStrLn "Hello, World!" +-- debug' a = fmap fst <$> debug () () a -- @ -withLogger :: FilePath -> Priority -> IO a -> IO a -withLogger fp p action = bracket - setupRootLogger - (\fh -> closeFunc fh (privData fh)) - (const action) +-- +-- See documentation for 'debug'. +debug' :: Internal.Neovim' a -> IO (Either String a) +debug' a = fmap fst <$> debug () () a + + +-- | This function is intended to be run _once_ in a ghci session that to +-- give a REPL based workflow when developing a plugin. +-- +-- 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: +-- +-- @ +-- λ Right (tids, cfg) <- develMain +-- +-- λ runNeovim' cfg \$ vim_call_function "getqflist" [] +-- Right (Right (ObjectArray [])) +-- +-- λ :r +-- +-- λ Right (tids, cfg) <- develMain +-- @ +-- +develMain :: IO (Either String ([ThreadId], Internal.Config RPCConfig ())) +develMain = lookupStore 0 >>= \case + Nothing -> do + x <- disableLogger $ + runPluginProvider def { env = True } Nothing finalizer Nothing + void $ newStore x + return x + + Just x -> + readStore x 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' + finalizer tids cfg = takeMVar (Internal.quit cfg) >>= \case + Internal.Failure e -> + return $ Left e + + Internal.InitSuccess -> + return $ Right (tids, cfg) + + _ -> + return $ Left "Unexpected finalizer state for develMain." + + +-- | Convenience function to run a stateless 'Neovim' function. +runNeovim' :: Internal.Config r st -> Neovim' a -> IO (Either String a) +runNeovim' cfg = + fmap (fmap fst) . runNeovim (Internal.retypeConfig () () cfg) () + diff --git a/library/Neovim/Log.hs b/library/Neovim/Log.hs new file mode 100644 --- /dev/null +++ b/library/Neovim/Log.hs @@ -0,0 +1,60 @@ +{- | +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 --- a/library/Neovim/Main.hs +++ b/library/Neovim/Main.hs @@ -13,35 +13,65 @@ where import Neovim.Config +import qualified Neovim.Context.Internal as Internal +import Neovim.Log import Neovim.Plugin as P -import qualified Neovim.Plugin.ConfigHelper as ConfigHelper +import Neovim.Plugin.Startup (StartupConfig(..)) +import Neovim.RPC.Common as RPC +import Neovim.RPC.EventHandler +import Neovim.RPC.SocketReader import qualified Config.Dyre as Dyre import qualified Config.Dyre.Relaunch as Dyre import Control.Concurrent -import Control.Concurrent.STM +import Control.Concurrent.STM (putTMVar, atomically) +import Control.Monad +import Data.Default +import Data.Maybe import Data.Monoid -import Neovim.Context -import Neovim.Debug -import Neovim.RPC.Common as RPC -import Neovim.RPC.EventHandler -import Neovim.RPC.SocketReader import Options.Applicative import System.IO (stdin, stdout) +import System.SetEnv +import System.Environment +import Prelude + + +logger :: String +logger = "Neovim.Main" + + data CommandLineOptions = - Opt { providerName :: String + Opt { providerName :: Maybe String , hostPort :: Maybe (String, Int) , unix :: Maybe FilePath , env :: Bool , logOpts :: Maybe (FilePath, Priority) } + +instance Default CommandLineOptions where + def = Opt + { providerName = Nothing + , hostPort = Nothing + , unix = Nothing + , env = False + , logOpts = Nothing + } + + optParser :: Parser CommandLineOptions optParser = Opt - <$> strArgument + <$> optional (strArgument (metavar "NAME" - <> help "Name that associates the plugin provider with neovim") + <> help (unlines + [ "Name that associates the plugin provider with neovim." + , "This option has only an effect if you start nvim-hs" + , "with rpcstart() and use the factory method approach." + , "Since it is extremely hard to figure that out inside" + , "nvim-hs, this options is assumed to used if the input" + , "and output is tied to standard in and standard out." + ]))) <*> optional ((,) <$> strOption (long "host" @@ -84,54 +114,107 @@ -- | This is essentially the main function for /nvim-hs/, at least if you want --- to use the "Config.Dyre" for the configuration.. +-- to use "Config.Dyre" for the configuration. neovim :: NeovimConfig -> IO () -neovim conf = +neovim = let params = Dyre.defaultParams { Dyre.showError = \cfg errM -> cfg { errorMessage = Just errM } , Dyre.projectName = "nvim" - , Dyre.realMain = realMain + , Dyre.realMain = realMain finishDyre (Just params) , Dyre.statusOut = debugM "Dyre" , Dyre.ghcOpts = ["-threaded", "-rtsopts", "-with-rtsopts=-N"] } - in Dyre.wrapMain params (conf { dyreParams = Just params }) + in Dyre.wrapMain params -realMain :: NeovimConfig -> IO () -realMain cfg = do + +type Finalizer a = [ThreadId] -> 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 :: Finalizer a + -> Maybe (Dyre.Params NeovimConfig) + -> NeovimConfig + -> IO () +realMain finalizer mParams cfg = do os <- execParser opts maybe disableLogger (uncurry withLogger) (logOpts os <|> logOptions cfg) $ do - logM "Neovim.Main" DEBUG "Starting up neovim haskell plguin provider" - runPluginProvider os cfg + debugM logger "Starting up neovim haskell plguin provider" + void $ runPluginProvider os (Just cfg) finalizer mParams -runPluginProvider :: CommandLineOptions -> NeovimConfig -> IO () -runPluginProvider os = case (hostPort os, unix os) of - (Just (h,p), _) -> let s = TCP p h in run s s - (_, Just fp) -> let s = UnixSocket fp in run s s - _ | env os -> run Environment Environment - _ -> run (Stdout stdout) (Stdout stdin) +-- | Generic main function. Most arguments are optional or have sane defaults. +runPluginProvider + :: CommandLineOptions -- ^ See /nvim-hs/ executables --help function or 'optParser' + -> Maybe NeovimConfig + -> Finalizer a + -> Maybe (Dyre.Params NeovimConfig) + -> IO a +runPluginProvider os mcfg finalizer mDyreParams = 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 + + _ | env os -> + createHandle Environment >>= \s -> run s s + + _ -> + run stdout stdin + where - run evHandlerSocket sockreaderSocket cfg = do - rpcConfig <- newRPCConfig - q <- newTQueueIO - quitter <- newEmptyMVar - let conf = ConfigWrapper q quitter (providerName os) () - allPlugins = maybe id ((:) . ConfigHelper.plugin) (dyreParams cfg) $ plugins cfg - startPluginThreads (conf { customConfig = RPC.functions rpcConfig }) allPlugins >>= \case - Left e -> errorM "Neovim.Main" $ "Error initializing plugins: " <> e - Right pluginTidsWithQueues -> do - let rpcEnv = conf { customConfig = rpcConfig } - ehTid <- forkIO $ runEventHandler evHandlerSocket rpcEnv - _ <- forkIO $ register (conf { customConfig = RPC.functions rpcConfig }) pluginTidsWithQueues - let pluginTids = concatMap (map fst . snd) pluginTidsWithQueues - rTid <- forkIO $ runSocketReader sockreaderSocket rpcEnv - debugM "Neovim.Main" "Waiting for threads to finish." - finish (rTid:ehTid:pluginTids) =<< readMVar quitter + run evHandlerHandle sockreaderHandle = do -finish :: [ThreadId] -> QuitAction -> IO () -finish threads = \case - Restart -> do - debugM "Neovim.Main" "Trying to restart nvim-hs" + -- 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 <- forkIO $ runEventHandler + evHandlerHandle + conf { Internal.pluginSettings = Nothing } + + srTid <- forkIO $ runSocketReader sockreaderHandle conf + + ghcEnv <- forM ["GHC_PACKAGE_PATH","CABAL_SANDBOX_CONFIG"] $ \var -> do + val <- lookupEnv var + unsetEnv var + return (var, val) + let startupConf = Internal.retypeConfig + (StartupConfig mDyreParams ghcEnv) + () + conf + startPluginThreads startupConf allPlugins >>= \case + Left e -> do + errorM logger $ "Error initializing plugins: " <> e + putMVar (Internal.quit conf) $ Internal.Failure e + finalizer [ehTid, srTid] conf + + Right (funMapEntries, pluginTids) -> do + atomically $ putTMVar + (Internal.globalFunctionMap conf) + (Internal.mkFunctionMap funMapEntries) + putMVar (Internal.quit conf) $ Internal.InitSuccess + finalizer (srTid:ehTid:pluginTids) conf + + +finishDyre :: Finalizer () +finishDyre threads cfg = takeMVar (Internal.quit cfg) >>= \case + Internal.InitSuccess -> do + debugM logger "Waiting for threads to finish." + finishDyre threads cfg + + Internal.Restart -> do + debugM logger "Trying to restart nvim-hs" mapM_ killThread threads Dyre.relaunchMaster Nothing - Quit -> return () + + Internal.Failure e -> + errorM logger e + + Internal.Quit -> + return () + diff --git a/library/Neovim/Plugin.hs b/library/Neovim/Plugin.hs --- a/library/Neovim/Plugin.hs +++ b/library/Neovim/Plugin.hs @@ -1,8 +1,10 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} {- | Module : Neovim.Plugin -Description : +Description : Plugin and functionality registration code Copyright : (c) Sebastian Witte License : Apache-2.0 @@ -11,140 +13,354 @@ Portability : GHC -} + module Neovim.Plugin ( startPluginThreads, - register, + StartupConfig, wrapPlugin, NeovimPlugin, Plugin(..), Synchronous(..), CommandOption(..), + + addAutocmd, + addAutocmd', + + registerInStatelessContext, + registerInStatefulContext, ) where import Neovim.API.String import Neovim.Classes +import Neovim.Config import Neovim.Context -import Neovim.Plugin.Classes hiding (register) -import Neovim.Plugin.IPC -import Neovim.Plugin.IPC.Internal -import Neovim.RPC.Common +import Neovim.Context.Internal (FunctionType (..)) +import qualified Neovim.Context.Internal as Internal +import Neovim.Plugin.Classes hiding (register) +import Neovim.Plugin.Internal +import Neovim.Plugin.IPC.Classes +import qualified Neovim.Plugin.Startup as Plugin import Neovim.RPC.FunctionCall -import Control.Arrow ((&&&)) -import Control.Concurrent (ThreadId) +import Control.Applicative +import Control.Concurrent (ThreadId, forkIO) import Control.Concurrent.STM -import Control.Exception.Lifted (SomeException, try) -import Control.Monad (foldM, forM, void) -import qualified Control.Monad.Reader as R -import Data.Foldable (forM_) -import qualified Data.Map as Map +import Control.Monad (foldM, void) +import Control.Monad.Catch (SomeException, try) +import Control.Monad.Trans.Resource hiding (register) +import Data.ByteString (ByteString) +import Data.Foldable (forM_) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe (catMaybes) import Data.MessagePack -import Data.Text (unpack) +import Data.Traversable (forM) import System.Log.Logger +import Prelude + + logger :: String logger = "Neovim.Plugin" -startPluginThreads :: ConfigWrapper r - -> [IO NeovimPlugin] - -> IO (Either String [(NeovimPlugin, [(ThreadId, [(FunctionalityDescription, FunctionType)])])]) -startPluginThreads cfg = fmap (fmap fst) . runNeovim cfg () . foldM go [] + +type StartupConfig = Plugin.StartupConfig NeovimConfig + + +startPluginThreads :: Internal.Config StartupConfig () + -> [Neovim StartupConfig () NeovimPlugin] + -> IO (Either String ([FunctionMapEntry],[ThreadId])) +startPluginThreads cfg = fmap (fmap fst) + . runNeovim cfg () + . foldM go ([], []) where - go :: [(NeovimPlugin, [(ThreadId, [(FunctionalityDescription, FunctionType)])])] - -> IO NeovimPlugin - -> Neovim r () [(NeovimPlugin, [(ThreadId, [(FunctionalityDescription, FunctionType)])])] - go pluginThreads iop = do - NeovimPlugin p <- liftIO iop - tids <- mapM registerStatefulFunctionality (statefulExports p) - return $ (NeovimPlugin p, tids) : pluginThreads + go :: ([FunctionMapEntry], [ThreadId]) + -> Neovim StartupConfig () NeovimPlugin + -> Neovim StartupConfig () ([FunctionMapEntry], [ThreadId]) + go acc iop = do + NeovimPlugin p <- iop -register :: ConfigWrapper (TMVar FunctionMap) - -> [(NeovimPlugin, [(ThreadId, [(FunctionalityDescription, FunctionType)])])] - -> IO () -register (cfg@ConfigWrapper{ customConfig = sem }) ps = void . runNeovim cfg () $ do - registeredFunctions <- forM ps $ \(NeovimPlugin p, fs) -> do - let statefulFunctionsToRegister = concatMap snd fs - statelessFunctionsToRegister = - map (getDescription &&& Stateless . getFunction) $ exports p - functionsToRegister = statefulFunctionsToRegister ++ statelessFunctionsToRegister - mapM_ (registerWithNeovim . fst) functionsToRegister - return $ map (\(d,f) -> (name d, (d, f))) functionsToRegister - liftIO . atomically . putTMVar sem . Map.fromList $ concat registeredFunctions + (es, tids) <- foldl (\(es, tids) (es', tid) -> (es'++es, tid:tids)) acc + <$> mapM registerStatefulFunctionality (statefulExports p) + es' <- forM (exports p) $ \e -> do + registerInStatelessContext + (\_ -> return ()) + (getDescription e) + (getFunction e) -registerWithNeovim :: FunctionalityDescription -> Neovim customConfig () () + return $ (catMaybes es' ++ es, tids) + + +-- | Callthe 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 anyConfig anyState Bool registerWithNeovim = \case - Function functionName s -> do - pName <- R.asks _providerName - ret <- wait $ vim_call_function "remote#define#FunctionOnHost" + Function (F functionName) s -> do + pName <- getProviderName + ret <- vim_call_function "remote#define#FunctionOnHost" [ toObject pName, toObject functionName, toObject s , toObject functionName, toObject (Map.empty :: Dictionary) ] case ret of - Left e -> liftIO . errorM logger $ - "Failed to register function: " ++ unpack functionName ++ show e - Right _ -> liftIO . debugM logger $ - "Registered function: " ++ unpack functionName + Left e -> do + liftIO . errorM logger $ + "Failed to register function: " ++ show functionName ++ show e + return False + Right _ -> do + liftIO . debugM logger $ + "Registered function: " ++ show functionName + return True - Command functionName copts -> do + 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 <- R.asks _providerName - ret <- wait $ vim_call_function "remote#define#CommandOnHost" + pName <- getProviderName + ret <- vim_call_function "remote#define#CommandOnHost" [ toObject pName, toObject functionName, toObject sync , toObject functionName, toObject copts ] case ret of - Left e -> liftIO . errorM logger $ - "Failed to register command: " ++ unpack functionName ++ show e - Right _ -> liftIO . debugM logger $ - "Registered command: " ++ unpack functionName + Left e -> do + liftIO . errorM logger $ + "Failed to register command: " ++ show functionName ++ show e + return False + Right _ -> do + liftIO . debugM logger $ + "Registered command: " ++ show functionName + return True - Autocmd acmdType functionName opts -> do - pName <- R.asks _providerName - ret <- wait $ vim_call_function "remote#define#AutocmdOnHost" - [ toObject pName, toObject functionName, toObject (acmdSync opts) + Autocmd acmdType (F functionName) opts -> do + pName <- getProviderName + ret <- vim_call_function "remote#define#AutocmdOnHost" + [ toObject pName, toObject functionName, toObject Async , toObject acmdType , toObject opts ] case ret of - Left e -> liftIO . errorM logger $ - "Failed to register autocmd: " ++ unpack functionName ++ show e - Right _ -> liftIO . debugM logger $ - "Registered autocmd: " ++ unpack functionName + Left e -> do + liftIO . errorM logger $ + "Failed to register autocmd: " ++ show functionName ++ show e + return False + Right _ -> do + liftIO . debugM logger $ + "Registered autocmd: " ++ show functionName + return True +-- | Return or retrive the provider name that the current instance is associated +-- with on the neovim side. +getProviderName :: Neovim r st (Either String Int) +getProviderName = do + mp <- Internal.asks' Internal.providerName + (liftIO . atomically . tryReadTMVar) mp >>= \case + Just p -> + return p + + Nothing -> do + api <- wait vim_get_api_info + case api of + (ObjectInt i:_) -> do + liftIO . atomically . putTMVar mp . Right $ fromIntegral i + return . Right $ fromIntegral i + + _ -> + err "Could not determine provider name." + + +registerFunctionality :: FunctionalityDescription + -> ([Object] -> Neovim r st Object) + -> Neovim r st (Maybe (FunctionMapEntry, Either (Neovim anyR anySt ()) ReleaseKey)) +registerFunctionality d f = Internal.asks' Internal.pluginSettings >>= \case + Nothing -> do + liftIO $ errorM logger "Cannot register functionality in this context." + return Nothing + + Just (Internal.StatelessSettings reg) -> + reg d f >>= \case + Just e -> do + return $ Just (e, Left (freeFun (fst e))) + _ -> + return Nothing + + Just (Internal.StatefulSettings reg q m) -> + reg d f q m >>= \case + Just e -> do + -- Redefine fields so that it gains a new type + cfg <- Internal.retypeConfig () () <$> Internal.ask' + rk <- fst <$> allocate (return ()) (free cfg (fst e)) + return $ Just (e, Right rk) + + Nothing -> + return Nothing + + where + freeFun = \case + Autocmd event _ AutocmdOptions{..} -> do + void . vim_call_function "autocmd!" $ catMaybes + [ toObject <$> acmdGroup, Just (toObject event) + , Just (toObject acmdPattern) + ] + + Command{} -> + liftIO $ warningM logger "Free not implemented for commands." + + Function{} -> + liftIO $ warningM logger "Free not implemented for functions." + + + free cfg = const . void . liftIO . runNeovim cfg () . freeFun + + +-- | Register a functoinality in a stateless context. +registerInStatelessContext + :: (FunctionMapEntry -> Neovim r st ()) + -> FunctionalityDescription + -> ([Object] -> Neovim' Object) + -> Neovim r st (Maybe FunctionMapEntry) +registerInStatelessContext reg d f = registerWithNeovim d >>= \case + False -> + return Nothing + + True -> do + let e = (d, Stateless f) + reg e + return $ Just e + + +registerInGlobalFunctionMap :: FunctionMapEntry -> Neovim r st () +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 ((name . fst) e) e m + liftIO . debugM logger $ "Added function to global function map." ++ show (fst e) + +registerInStatefulContext + :: (FunctionMapEntry -> Neovim r st ()) + -> FunctionalityDescription + -> ([Object] -> Neovim r st Object) + -> TQueue SomeMessage + -> TVar (Map FunctionName ([Object] -> Neovim r st Object)) + -> Neovim r st (Maybe FunctionMapEntry) +registerInStatefulContext reg d f q tm = registerWithNeovim d >>= \case + True -> do + let n = name 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. If you +-- need that information, but do not want to block the other functions in this +-- thread, you have to manually fork a thread and make the state you need +-- available there. If you don't care abou the state (or your function has been +-- appield to all the necessary state (e.g. a 'TVar' to share the rusult), then +-- you can also call 'addAutocmd'' which will register a stateless function that +-- only interacts with other threads by means of concurrency abstractions. +-- +-- Note that the function you pass must be fully applied. +-- +-- Note beside: This function is equivalent to 'addAutocmd'' if called from a +-- stateless plugin thread. +addAutocmd :: ByteString + -- ^ The event to register to (e.g. BufWritePost) + -> AutocmdOptions + -> (Neovim r st ()) + -- ^ Fully applied function to register + -> Neovim r st (Maybe (Either (Neovim anyR anySt ()) ReleaseKey)) + -- ^ A 'ReleaseKey' if the registration worked +addAutocmd event (opts@AutocmdOptions{..}) f = do + n <- newUniqueFunctionName + fmap snd <$> registerFunctionality (Autocmd event n opts) (\_ -> toObject <$> f) + + +-- | Add a stateless autocmd. +-- +-- See 'addAutocmd' for more details. +addAutocmd' :: ByteString + -> AutocmdOptions + -> Neovim' () + -> Neovim r st (Maybe ReleaseKey) +addAutocmd' event opts f = do + n <- newUniqueFunctionName + void $ registerInStatelessContext + registerInGlobalFunctionMap + (Autocmd event n opts) + (\_ -> toObject <$> f) + return Nothing + + -- | Create a listening thread for events and add update the 'FunctionMap' with -- the corresponding 'TQueue's (i.e. communication channels). registerStatefulFunctionality :: (r, st, [ExportedFunctionality r st]) - -> Neovim customcConfig () (ThreadId, [(FunctionalityDescription, FunctionType)]) + -> Neovim anyconfig anyState ([FunctionMapEntry], ThreadId) registerStatefulFunctionality (r, st, fs) = do q <- liftIO newTQueueIO - tid <- forkNeovim r st (listeningThread q) - return (tid, map (\n -> (getDescription n, Stateful q)) fs) - where - functionRoutes = foldr updateRoute Map.empty fs - updateRoute = uncurry Map.insert . (name &&& getFunction) + route <- liftIO $ newTVarIO Map.empty + cfg <- Internal.ask' + + let startupConfig = cfg + { Internal.customConfig = r + , Internal.pluginSettings = Just $ Internal.StatefulSettings + (registerInStatefulContext (\_ -> return ())) q route + } + res <- liftIO . runNeovim startupConfig st . forM fs $ \f -> + registerFunctionality (getDescription f) (getFunction f) + es <- case res of + Left e -> err e + Right (a,_) -> return $ catMaybes a + + let pluginThreadConfig = cfg + { Internal.customConfig = r + , Internal.pluginSettings = Just $ Internal.StatefulSettings + (registerInStatefulContext registerInGlobalFunctionMap) q route + } + + tid <- liftIO . forkIO . void . runNeovim pluginThreadConfig st $ do + listeningThread q route + + return (map fst es, tid) -- NB: dropping release functions/keys here + + + where executeFunction :: ([Object] -> Neovim r st Object) -> [Object] -> Neovim r st (Either String Object) executeFunction f args = try (f args) >>= \case - Left e -> let e' = e :: SomeException - in return . Left $ show e' + Left e -> return . Left $ show (e :: SomeException) Right res -> return $ Right res - listeningThread q = do + + listeningThread :: TQueue SomeMessage + -> TVar (Map FunctionName ([Object] -> Neovim r st Object)) + -> Neovim r st loop + listeningThread q route = do msg <- liftIO . atomically $ readTQueue q - forM_ (fromMessage msg) $ \req@Request{..} -> - forM_ (Map.lookup reqMethod functionRoutes) $ \f -> + + forM_ (fromMessage msg) $ \req@Request{..} -> do + route' <- liftIO $ readTVarIO route + forM_ (Map.lookup reqMethod route') $ \f -> respond req =<< executeFunction f reqArgs - forM_ (fromMessage msg) $ \Notification{..} -> - forM_ (Map.lookup notMethod functionRoutes) $ \f -> + + forM_ (fromMessage msg) $ \Notification{..} -> do + route' <- liftIO $ readTVarIO route + forM_ (Map.lookup notMethod route') $ \f -> void $ executeFunction f notArgs - listeningThread q + + listeningThread q route diff --git a/library/Neovim/Plugin/Classes.hs b/library/Neovim/Plugin/Classes.hs --- a/library/Neovim/Plugin/Classes.hs +++ b/library/Neovim/Plugin/Classes.hs @@ -1,7 +1,6 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} {- | Module : Neovim.Plugin.Classes Description : Classes and data types related to plugins @@ -14,53 +13,39 @@ -} module Neovim.Plugin.Classes ( - ExportedFunctionality(..), - getFunction, - getDescription, FunctionalityDescription(..), FunctionName(..), - NeovimPlugin(..), - Plugin(..), - wrapPlugin, Synchronous(..), CommandOption(..), + CommandOptions, RangeSpecification(..), CommandArguments(..), getCommandOptions, mkCommandOptions, AutocmdOptions(..), + HasFunctionName(..), ) where import Neovim.Classes -import Neovim.Context -import Control.Applicative ((<$>)) -import Data.Char (isDigit) +import Control.Applicative +import Control.Monad.Error.Class +import Data.ByteString (ByteString) +import Data.Char (isDigit) import Data.Default -import Data.List (groupBy, sort) -import qualified Data.Map as Map +import Data.List (groupBy, sort) +import qualified Data.Map as Map import Data.Maybe import Data.MessagePack import Data.String -import Data.Text (Text) -import Data.Traversable (sequence) -import Prelude hiding (sequence) - --- | This data type is used in the plugin registration to properly register the --- functions. -newtype ExportedFunctionality r st - = EF (FunctionalityDescription, [Object] -> Neovim r st Object) - +import Data.Traversable (sequence) --- | Extract the description of an 'ExportedFunctionality'. -getDescription :: ExportedFunctionality r st -> FunctionalityDescription -getDescription (EF (d,_)) = d +import Prelude hiding (sequence) --- | Extract the function of an 'ExportedFunctionality'. -getFunction :: ExportedFunctionality r st -> [Object] -> Neovim r st Object -getFunction (EF (_, f)) = f - +-- | Essentially just a string. +newtype FunctionName = F ByteString + deriving (Eq, Ord, Show, Read) -- | Functionality specific functional description entries. -- @@ -69,28 +54,28 @@ -- The last field is a data type that contains all relevant options with -- sensible defaults, hence 'def' can be used as an argument. data FunctionalityDescription - = Function Text Synchronous + = Function FunctionName Synchronous -- ^ Exported function. Callable via @call name(arg1,arg2)@. -- -- * Name of the function (must start with an uppercase letter) -- * Option to indicate how neovim should behave when calling this function - | Command Text CommandOptions + | Command FunctionName CommandOptions -- ^ Exported Command. Callable via @:Name arg1 arg2@. -- -- * Name of the command (must start with an uppercase letter) -- * Options to configure neovim's behavior for calling the command - | Autocmd Text Text AutocmdOptions + | Autocmd ByteString FunctionName AutocmdOptions -- ^ Exported autocommand. Will call the given function if the type and -- filter match. -- -- NB: Since we are registering this on the Haskell side of things, the -- number of accepted arguments should be 0. - -- TODO Should this be enforced somehow? Possibly via the TH generator. -- -- * Type of the autocmd (e.g. \"BufWritePost\") -- * Name for the function to call + -- * Options for the autocmd (use 'def' here if you don't want to change anything) deriving (Show, Read, Eq, Ord) @@ -107,10 +92,8 @@ | Sync -- ^ Call the function and wait for its result. This is only synchronous on - -- the neovim side. For comands it means that the GUI will (probably) not - -- allow any user input until a reult is received. Functions run - -- asynchronously inside neovim (or in one of its plugin providers) can use - -- these functions concurrently. + -- the neovim side. This means that the GUI will (probably) not + -- allow any user input until a reult is received. deriving (Show, Read, Eq, Ord, Enum) @@ -140,14 +123,12 @@ -- 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 = CmdSync Synchronous - -- ^ Should neovim wait for an answer ('Sync')? - -- - -- Stringliteral: \"sync\" or "\async\" + -- ^ Stringliteral "sync" or "async" | CmdRegister -- ^ Register passed to the command. -- - -- Stringliteral: \"\"\" + -- Stringliteral: @\"\\\"\"@ | CmdNargs String -- ^ Command takes a specific amount of arguments @@ -162,7 +143,7 @@ -- Stringliterals: \"%\" for 'WholeFile', \",\" for line -- and \",123\" for 123 lines. - | CmdCount Int + | CmdCount Word -- ^ Command handles a count. The argument defines the -- default count. -- @@ -247,7 +228,7 @@ -- attributes a command can take. data CommandArguments = CommandArguments { bang :: Maybe Bool - -- ^ Nothing means that the function was not defined to handle a bang, + -- ^ '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'@). @@ -255,7 +236,8 @@ -- ^ Range passed from neovim. Only set if 'CmdRange' was used in the export -- declaration of the command. -- - -- Examples: + -- Example: + -- -- * @Just (1,12)@ , count :: Maybe Int @@ -263,7 +245,7 @@ -- declaration of the command. , register :: Maybe String - -- ^ Register that the command can/should/must use. + -- ^ Register that the command can\/should\/must use. } deriving (Eq, Ord, Show, Read) @@ -302,26 +284,25 @@ data AutocmdOptions = AutocmdOptions - { acmdSync :: Synchronous - -- ^ Option to indicate whether vim shuould block until the function has - -- completed. (default: 'Sync') - - , acmdPattern :: String + { 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) instance Default AutocmdOptions where def = AutocmdOptions - { acmdSync = Sync - , acmdPattern = "*" + { acmdPattern = "*" , acmdNested = False + , acmdGroup = Nothing } @@ -330,39 +311,20 @@ (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: " ++ show o -- | Conveniennce class to extract a name from some value. -class FunctionName a where - name :: a -> Text +class HasFunctionName a where + name :: a -> FunctionName -instance FunctionName FunctionalityDescription where +instance HasFunctionName FunctionalityDescription where name = \case Function n _ -> n Command n _ -> n Autocmd _ n _ -> n - - -instance FunctionName (ExportedFunctionality r st) where - name = name . getDescription - - --- | This data type contains meta information for the plugin manager. --- -data Plugin r st = Plugin - { exports :: [ExportedFunctionality () ()] - , statefulExports :: [(r, st, [ExportedFunctionality r st])] - } - - -data NeovimPlugin = forall r st. NeovimPlugin (Plugin r st) - - --- | Wrap a 'Plugin' in some nice blankets, so that we can put them in a simple --- list. -wrapPlugin :: Monad m => Plugin r st -> m NeovimPlugin -wrapPlugin = return . NeovimPlugin diff --git a/library/Neovim/Plugin/ConfigHelper.hs b/library/Neovim/Plugin/ConfigHelper.hs --- a/library/Neovim/Plugin/ConfigHelper.hs +++ b/library/Neovim/Plugin/ConfigHelper.hs @@ -1,5 +1,6 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} {- | Module : Neovim.Plugin.ConfigHelper Description : Helper plugin to ease recompiling the nvim-hs config @@ -14,33 +15,39 @@ module Neovim.Plugin.ConfigHelper where -import Config.Dyre (Params) -import Config.Dyre.Paths (getPaths) import Neovim.API.TH import Neovim.Config +import Neovim.Context import Neovim.Plugin.Classes import Neovim.Plugin.ConfigHelper.Internal +import Neovim.Plugin.Internal +import Neovim.Plugin.Startup --- | Note that you cannot really use this plugin by hand. It is automatically --- loaded for all Neovim instances. -plugin :: Params NeovimConfig -> IO NeovimPlugin -plugin params = do - (_, _, cfgFile, _, libsDir) <- getPaths params - wrapPlugin Plugin - { exports = - [ $(function' 'pingNvimhs) Sync - ] - , statefulExports = - [ (params, [], - [ $(autocmd 'recompileNvimhs) "BufWritePost" def - { acmdSync = Async - , acmdPattern = cfgFile - } - , $(autocmd 'recompileNvimhs) "BufWritePost" def - { acmdSync = Async - , acmdPattern = libsDir++"/*" - } - , $(command' 'restartNvimhs) [CmdSync Async, CmdBang, CmdRegister] - ]) - ] - } +import Config.Dyre.Paths (getPaths) +import Data.Default + + +plugin :: Neovim (StartupConfig NeovimConfig) () NeovimPlugin +plugin = asks dyreParams >>= \case + Nothing -> + wrapPlugin Plugin { exports = [], statefulExports = [] } + + Just params -> do + ghcEnv <- asks ghcEnvironmentVariables + (_, _, cfgFile, _, libsDir) <- liftIO $ getPaths params + wrapPlugin Plugin + { exports = + [ $(function' 'pingNvimhs) Sync + ] + , statefulExports = + [ ((params, ghcEnv), [], + [ $(autocmd 'recompileNvimhs) "BufWritePost" def + { acmdPattern = cfgFile + } + , $(autocmd 'recompileNvimhs) "BufWritePost" def + { acmdPattern = libsDir++"/*" + } + , $(command' 'restartNvimhs) [CmdSync Async, CmdBang, CmdRegister] + ]) + ] + } diff --git a/library/Neovim/Plugin/ConfigHelper/Internal.hs b/library/Neovim/Plugin/ConfigHelper/Internal.hs --- a/library/Neovim/Plugin/ConfigHelper/Internal.hs +++ b/library/Neovim/Plugin/ConfigHelper/Internal.hs @@ -19,17 +19,20 @@ import Neovim.Context import Neovim.Plugin.Classes import Neovim.Quickfix -import Neovim.RPC.FunctionCall +import Neovim.Util (withCustomEnvironment) import Config.Dyre (Params) import Config.Dyre.Compile import Control.Applicative hiding (many, (<|>)) -import Control.Monad (void) +import Control.Monad (void, forM_) import Data.Char -import Text.Parsec hiding (count) +import Text.Parsec hiding (Error, count) import Text.Parsec.String +import System.SetEnv +import Prelude + -- | Simple function that will return @"Pong"@ if the plugin provider is -- running. pingNvimhs :: Neovim' String @@ -37,14 +40,13 @@ -- | Recompile the plugin provider and put comile errors in the quickfix list. -recompileNvimhs :: Neovim (Params NeovimConfig) [QuickfixListItem String] () -recompileNvimhs = do - cfg <- ask +recompileNvimhs :: Neovim (Params NeovimConfig, [(String, Maybe String)]) [QuickfixListItem String] () +recompileNvimhs = ask >>= \(cfg,env) -> withCustomEnvironment env $ do mErrString <- liftIO (customCompile cfg >> getErrorString cfg) let qs = maybe [] parseQuickfixItems mErrString put qs setqflist qs Replace - wait' $ vim_command "cwindow" + void $ vim_command "cwindow" -- | Note that restarting the plugin provider implies compilation because Dyre @@ -52,11 +54,14 @@ -- compiled bynary is executed. This essentially means that restarting may take -- more time then you might expect. restartNvimhs :: CommandArguments - -> Neovim (Params NeovimConfig) [QuickfixListItem String] () + -> Neovim (Params NeovimConfig, [(String, Maybe String)]) [QuickfixListItem String] () restartNvimhs CommandArguments{..} = do case bang of Just True -> recompileNvimhs _ -> return () + (_, env) <- ask + forM_ env $ \(var, val) -> liftIO $ do + maybe (unsetEnv var) (setEnv var) val restart -- Parsing {{{1 @@ -73,17 +78,22 @@ pQuickfixListItem = do _ <- many blankLine (f,l,c) <- pLocation + + void $ many spaceChar + e <- option Error $ do + void . try $ string "Warning:" + return Warning desc <- try pShortDesrciption <|> pLongDescription return $ (quickfixListItem (Right f) (Left l)) { col = Just (c, True) , text = desc - , errorType = "E" -- TODO determine actual type + , errorType = e } pShortDesrciption :: Parser String pShortDesrciption = (:) - <$> (many spaceChar *> notFollowedBy blankLine *> anyChar) + <$> (notFollowedBy blankLine *> anyChar) <*> anyChar `manyTill` (void (many1 blankLine) <|> eof) diff --git a/library/Neovim/Plugin/IPC/Classes.hs b/library/Neovim/Plugin/IPC/Classes.hs --- a/library/Neovim/Plugin/IPC/Classes.hs +++ b/library/Neovim/Plugin/IPC/Classes.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ExistentialQuantification #-} {- | Module : Neovim.Plugin.IPC.Classes @@ -10,11 +11,27 @@ Portability : GHC -} -module Neovim.Plugin.IPC.Classes - where +module Neovim.Plugin.IPC.Classes ( + SomeMessage(..), + Message(..), + FunctionCall(..), + Request(..), + Notification(..), -import Data.Data (Typeable, cast) + module Data.Int, + module Data.Time, + ) where +import Neovim.Plugin.Classes (FunctionName) + +import Control.Concurrent.STM +import Data.Data (Typeable, cast) +import Data.Int (Int64) +import Data.MessagePack +import Data.Time + +import Prelude + -- | Taken from xmonad and based on ideas in /An Extensible Dynamically-Typed -- Hierarchy of Exceptions/, Simon Marlow, 2006. -- @@ -27,4 +44,44 @@ -- interested in. Will evaluate to 'Nothing' for any other type. fromMessage :: SomeMessage -> Maybe message fromMessage (SomeMessage message) = cast message + + +-- | Haskell representation of supported Remote Procedure Call messages. +data FunctionCall + = FunctionCall FunctionName [Object] (TMVar (Either Object Object)) UTCTime + -- ^ Method name, parameters, callback, timestamp + deriving (Typeable) + + +instance Message FunctionCall + + +-- | A request is a data type containing the method to call, its arguments and +-- an identifier used to map the result to the function that has been called. +data Request = Request + { reqMethod :: FunctionName + -- ^ Name of the function to call. + , reqId :: !Int64 + -- ^ Identifier to map the result to a function call invocation. + , reqArgs :: [Object] + -- ^ Arguments for the function. + } deriving (Eq, Ord, Show, Typeable) + + +instance Message Request + + +-- | A notification is similar to a 'Request'. It essentially does the same +-- thing, but the function is only called for its side effects. This type of +-- message is sent by neovim if the caller there does not care about the result +-- of the computation. +data Notification = Notification + { notMethod :: FunctionName + -- ^ Name of the function to call. + , notArgs :: [Object] + -- ^ Arguments for the function. + } deriving (Eq, Ord, Show, Typeable) + + +instance Message Notification diff --git a/library/Neovim/Plugin/IPC/Internal.hs b/library/Neovim/Plugin/IPC/Internal.hs deleted file mode 100644 --- a/library/Neovim/Plugin/IPC/Internal.hs +++ /dev/null @@ -1,71 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{- | -Module : Neovim.Plugin.IPC.Internal -Description : Internally used parts of the inter plugin communication -Copyright : (c) Sebastian Witte -License : Apache-2.0 - -Maintainer : woozletoff@gmail.com -Stability : experimental -Portability : GHC - --} -module Neovim.Plugin.IPC.Internal - ( RPCMessage(..) - , Request(..) - , Notification(..) - - , module Data.Int - , module Data.Time - ) where - -import Control.Concurrent.STM -import Data.Data (Typeable) -import Data.Int (Int64) -import Data.MessagePack -import Data.Text (Text) -import Data.Time -import Neovim.Plugin.IPC.Classes - --- | Haskell representation of supported Remote Procedure Call messages. -data RPCMessage - = FunctionCall Text [Object] (TMVar (Either Object Object)) UTCTime - -- ^ Method name, parameters, callback, timestamp - | Response !Int64 Object Object - -- ^ Response sent to indicate the result of a function call. - -- - -- * identfier of the message as 'Word32' - -- * Error value - -- * Result value - | NotificationCall Text [Object] - -- ^ Method name and parameters. - deriving (Typeable) - -instance Message RPCMessage - --- | A request is a data type containing the method to call, its arguments and --- an identifier used to map the result to the function that has been called. -data Request = Request - { reqMethod :: Text - -- ^ Name of the function to call. - , reqId :: !Int64 - -- ^ Identifier to map the result to a function call invocation. - , reqArgs :: [Object] - -- ^ Arguments for the function. - } deriving (Typeable) - -instance Message Request - --- | A notification is similar to a 'Request'. It essentially does the same --- thing, but the function is only called for its side effects. This type of --- message is sent by neovim if the caller there does not care about the result --- of the computation. -data Notification = Notification - { notMethod :: Text - -- ^ Name of the function to call. - , notArgs :: [Object] - -- ^ Argumentse for the function. - } deriving (Typeable) - -instance Message Notification - diff --git a/library/Neovim/Plugin/Internal.hs b/library/Neovim/Plugin/Internal.hs new file mode 100644 --- /dev/null +++ b/library/Neovim/Plugin/Internal.hs @@ -0,0 +1,64 @@ +{-# 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 +import Neovim.Plugin.Classes + +import Data.MessagePack + + +-- | This data type is used in the plugin registration to properly register the +-- functions. +newtype ExportedFunctionality r st + = EF (FunctionalityDescription, [Object] -> Neovim r st Object) + + +-- | Extract the description of an 'ExportedFunctionality'. +getDescription :: ExportedFunctionality r st -> FunctionalityDescription +getDescription (EF (d,_)) = d + + +-- | Extract the function of an 'ExportedFunctionality'. +getFunction :: ExportedFunctionality r st -> [Object] -> Neovim r st Object +getFunction (EF (_, f)) = f + + +instance HasFunctionName (ExportedFunctionality r st) where + name = name . getDescription + + +-- | This data type contains meta information for the plugin manager. +-- +data Plugin r st = Plugin + { exports :: [ExportedFunctionality () ()] + , statefulExports :: [(r, st, [ExportedFunctionality r st])] + } + + +-- | 'Plugin' values are wraped inside this data type via 'wrapPlugin' so that +-- we can put plugins in an ordinary list. +data NeovimPlugin = forall r st. NeovimPlugin (Plugin r st) + + +-- | Wrap a 'Plugin' in some nice blankets, so that we can put them in a simple +-- list. +wrapPlugin :: Monad m => Plugin r st -> m NeovimPlugin +wrapPlugin = return . NeovimPlugin diff --git a/library/Neovim/Plugin/Startup.hs b/library/Neovim/Plugin/Startup.hs new file mode 100644 --- /dev/null +++ b/library/Neovim/Plugin/Startup.hs @@ -0,0 +1,36 @@ +{- | +Module : Neovim.Plugin.Startup +Description : Startup utilities for plugins +Copyright : (c) Sebastian Witte +License : Apache-2.0 + +Maintainer : woozletoff@gmail.com +Stability : experimental +Portability : GHC + +This plugin only exists due to cyclic dependencies. +-} +module Neovim.Plugin.Startup + where + +import qualified Config.Dyre as Dyre + +-- | This data type contains internal fields of /nvim-hs/ that may +-- be useful for plugin authors. It is available via 'ask' inside +-- the plugin startup code. +data StartupConfig cfg = StartupConfig + { dyreParams :: Maybe (Dyre.Params cfg) + -- ^ The configuration options for "Config.Dyre". This is always set if + -- /nvim-hs/ has been started via "Config.Dyre". Be sure to set up the + -- 'ghcEnvironmentVariables' correctly if you issue a recompilation via + -- the "Config.Dyre" API. + + , ghcEnvironmentVariables :: [(String, Maybe String)] + -- ^ The GHC environment variables with which /nvim-hs/ has been started. + -- This are mainly of significance if you want to use the same environment + -- for compilation or a REPL that /nvim-hs/ runs on. + -- + -- These variables have to be used if you want to invoke functionality of + -- "Config.Dyre" targeting /nvim-hs/. + } + diff --git a/library/Neovim/Quickfix.hs b/library/Neovim/Quickfix.hs --- a/library/Neovim/Quickfix.hs +++ b/library/Neovim/Quickfix.hs @@ -25,12 +25,13 @@ import Neovim.API.String import Neovim.Classes import Neovim.Context -import Neovim.RPC.FunctionCall +import Prelude + setqflist :: (Monoid strType, NvimObject strType) => [QuickfixListItem strType] -> QuickfixAction -> Neovim r st () setqflist qs a = - void . wait' $ vim_call_function "setqflist" [toObject qs, toObject a] + void $ vim_call_function "setqflist" [toObject qs, toObject a] -- | Quickfix list item. The parameter names should mostly conform to those in -- @:h setqflist()@. Some fields are merged to explicitly state mutually @@ -52,10 +53,26 @@ -- ^ Error number. , text :: strType -- ^ Description of the error. - , errorType :: strType - -- ^ TODO replace with enum, but too lazy for now. + , errorType :: QuickfixErrorType + -- ^ Type of error. } deriving (Eq, Show) + +data QuickfixErrorType = Warning | Error + deriving (Eq, Ord, Show, Read, Enum, Bounded) + + +instance NvimObject QuickfixErrorType where + toObject = \case + Warning -> ObjectBinary "W" + Error -> ObjectBinary "E" + + fromObject o = case fromObject o :: Either String 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) @@ -68,9 +85,10 @@ , col = Nothing , nr = Nothing , text = mempty - , errorType = mempty + , errorType = Error } + instance (Monoid strType, NvimObject strType) => NvimObject (QuickfixListItem strType) where toObject QFItem{..} = @@ -119,7 +137,7 @@ 0 -> Nothing _ -> Just (c',v') text <- fromMaybe mempty <$> l' "text" - errorType <- fromMaybe mempty <$> l' "type" + errorType <- fromMaybe Error <$> l' "type" return QFItem{..} fromObject o = throwError $ "Could not deserialize QuickfixListItem, expected a map but received: " ++ show o diff --git a/library/Neovim/RPC/Classes.hs b/library/Neovim/RPC/Classes.hs new file mode 100644 --- /dev/null +++ b/library/Neovim/RPC/Classes.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE LambdaCase #-} +{- | +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 (NvimObject (..)) +import Neovim.Plugin.Classes (FunctionName (..)) +import qualified Neovim.Plugin.IPC.Classes as IPC + +import Control.Applicative +import Control.Monad.Error.Class +import Data.Data (Typeable) +import Data.Int (Int64) +import Data.MessagePack (Object (..)) + +import Prelude + +-- | See https://github.com/msgpack-rpc/msgpack-rpc/blob/master/spec.md for +-- details about the msgpack rpc specification. +data Message + = Request IPC.Request + -- ^ 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 + + | Response !Int64 (Either Object Object) + -- ^ Response in the sense of the msgpack rpc specifcation + -- + -- Parameters + -- * Mesage identifier which matches a request + -- * 'Either' an error 'Object' or a result 'Object' + + | Notification IPC.Notification + -- ^ Notification in the sense of the msgpack rpc specification + deriving (Eq, Ord, Show, Typeable) + + +instance IPC.Message Message + +instance NvimObject Message where + toObject = \case + Request (IPC.Request (F m) i ps) -> + ObjectArray [ ObjectInt 0, ObjectInt i, ObjectBinary m, ObjectArray ps ] + + Response i (Left e) -> + ObjectArray [ ObjectInt 1, ObjectInt i, e, ObjectNil] + + Response i (Right r) -> + ObjectArray [ ObjectInt 1, ObjectInt i, ObjectNil, r] + + Notification (IPC.Notification (F m) ps) -> + ObjectArray [ ObjectInt 2, ObjectBinary m, ObjectArray 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 F (fromObject m)) + <*> fromObject ps + return $ Notification n + + o -> + throwError $ "Not a known/valid msgpack-rpc message" ++ show o + + + diff --git a/library/Neovim/RPC/Common.hs b/library/Neovim/RPC/Common.hs --- a/library/Neovim/RPC/Common.hs +++ b/library/Neovim/RPC/Common.hs @@ -15,8 +15,6 @@ where import Neovim.Context -import Neovim.Plugin.IPC -import Neovim.Plugin.Classes (FunctionalityDescription) import Control.Applicative import Control.Concurrent.STM @@ -27,53 +25,22 @@ import Data.Monoid import Data.Streaming.Network import Data.String -import Data.Text (Text) import Data.Time import Network.Socket as N hiding (SocketType) import System.Environment (getEnv) -import System.IO (BufferMode (..), Handle, IOMode, +import System.IO (BufferMode (..), Handle, IOMode(ReadWriteMode), hClose, hSetBuffering) import System.Log.Logger import Prelude --- | A function map is a map containing the names of functions as keys and some --- context dependent value which contains all the necessary information to --- execute that function in the intended way. --- --- This type is only used internally and handles two distinct cases. One case --- is a direct function call, wich is simply a function that accepts a list of --- 'Object' values and returns a result in the 'Neovim' context. The second --- case is calling a function that has a persistent state. This is mediated to --- a thread that reads from a 'TQueue'. (NB: persistent currently means, that --- state is stored for as long as the plugin provider is running and not --- restarted.) -type FunctionMap = - Map Text (FunctionalityDescription, FunctionType) - --- | This data type is used to dispatch a remote function call to the appopriate --- recipient. -data FunctionType - = Stateless ([Object] -> Neovim' Object) - -- ^ 'Stateless' functions are simply executed with the sent arguments. - - | Stateful (TQueue SomeMessage) - -- ^ 'Stateful' functions are handled within a special thread, the 'TQueue' - -- is the communication endpoint for the arguments we have to pass. - - -- | Things shared between the socket reader and the event handler. data RPCConfig = RPCConfig { recipients :: TVar (Map Int64 (UTCTime, TMVar (Either Object Object))) -- ^ A map from message identifiers (as per RPC spec) to a tuple with a -- timestamp and a 'TMVar' that is used to communicate the result back to -- the calling thread. - , functions :: TMVar FunctionMap - -- ^ A map that contains the function names which are registered to this - -- plugin manager. Putting the map in a 'TMVar' ensures that all - -- functionality is registered properly before answering to requests send - -- by neovim. } -- | Create a new basic configuration containing a communication channel for @@ -82,7 +49,6 @@ newRPCConfig :: (Applicative io, MonadIO io) => io RPCConfig newRPCConfig = RPCConfig <$> liftIO (newTVarIO mempty) - <*> liftIO newEmptyTMVarIO -- | Simple data type defining the kind of socket the socket reader should use. data SocketType = Stdout Handle @@ -101,34 +67,36 @@ -- -- The handle is not automatically closed. createHandle :: (Functor io, MonadIO io) - => IOMode - -> SocketType + => SocketType -> io Handle -createHandle ioMode socketType = case socketType of +createHandle = \case Stdout h -> do liftIO $ hSetBuffering h (BlockBuffering Nothing) return h - UnixSocket f -> createHandle ioMode . Stdout - =<< createUnixSocketHandle f - TCP p h -> createHandle ioMode . Stdout - =<< createTCPSocketHandle p h - Environment -> createHandle ioMode . Stdout - =<< createSocketHandleFromEnvironment + UnixSocket f -> + createHandle . Stdout =<< createUnixSocketHandle f + + TCP p h -> + createHandle . Stdout =<< createTCPSocketHandle p h + + Environment -> + createHandle . Stdout =<< createSocketHandleFromEnvironment + where createUnixSocketHandle :: (MonadIO io) => FilePath -> io Handle createUnixSocketHandle f = - liftIO $ getSocketUnix f >>= flip socketToHandle ioMode + liftIO $ getSocketUnix f >>= flip socketToHandle ReadWriteMode createTCPSocketHandle :: (Functor io, MonadIO io) => Int -> String -> io Handle createTCPSocketHandle p h = liftIO $ getSocketTCP (fromString h) p - >>= flip socketToHandle ioMode . fst + >>= flip socketToHandle ReadWriteMode . fst createSocketHandleFromEnvironment = do listenAddress <- liftIO (getEnv "NVIM_LISTEN_ADDRESS") case words listenAddress of - [unixSocket] -> createHandle ioMode (UnixSocket unixSocket) - [h,p] -> createHandle ioMode (TCP (read p) h) + [unixSocket] -> createHandle (UnixSocket unixSocket) + [h,p] -> createHandle (TCP (read p) h) _ -> do let errMsg = unlines [ "Unhandled socket type from environment variable: " diff --git a/library/Neovim/RPC/EventHandler.hs b/library/Neovim/RPC/EventHandler.hs --- a/library/Neovim/RPC/EventHandler.hs +++ b/library/Neovim/RPC/EventHandler.hs @@ -15,9 +15,10 @@ ) where import Neovim.Classes -import Neovim.Context hiding (ask, asks) -import Neovim.Plugin.IPC -import Neovim.Plugin.IPC.Internal +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 @@ -30,9 +31,8 @@ import Data.Conduit as C import Data.Conduit.Binary (sinkHandle) import qualified Data.Map as Map -import Data.MessagePack import Data.Serialize (encode) -import System.IO (IOMode (WriteMode)) +import System.IO (Handle) import System.Log.Logger import Prelude @@ -40,71 +40,68 @@ -- | This function will establish a connection to the given socket and write -- msgpack-rpc requests to it. -runEventHandler :: SocketType - -> ConfigWrapper RPCConfig +runEventHandler :: Handle + -> Internal.Config RPCConfig Int64 -> IO () -runEventHandler socketType env = +runEventHandler writeableHandle env = runEventHandlerContext env $ do - h <- createHandle WriteMode socketType eventHandlerSource $= eventHandler - $$ addCleanup (cleanUpHandle h) (sinkHandle h) + $$ addCleanup + (cleanUpHandle writeableHandle) + (sinkHandle writeableHandle) -- | Convenient monad transformer stack for the event handler newtype EventHandler a = - EventHandler (ResourceT (ReaderT (ConfigWrapper RPCConfig) (StateT Int64 IO)) a) + EventHandler (ResourceT (ReaderT (Internal.Config RPCConfig Int64) (StateT Int64 IO)) a) deriving ( Functor, Applicative, Monad, MonadState Int64, MonadIO - , MonadReader (ConfigWrapper RPCConfig)) + , MonadReader (Internal.Config RPCConfig Int64)) -runEventHandlerContext :: ConfigWrapper RPCConfig -> EventHandler a -> IO a +runEventHandlerContext + :: Internal.Config RPCConfig Int64 -> EventHandler a -> IO a runEventHandlerContext env (EventHandler a) = evalStateT (runReaderT (runResourceT a) env) 1 eventHandlerSource :: Source EventHandler SomeMessage -eventHandlerSource = asks _eventQueue >>= \q -> +eventHandlerSource = asks Internal.eventQueue >>= \q -> forever $ yield =<< atomically' (readTQueue q) eventHandler :: ConduitM SomeMessage ByteString EventHandler () eventHandler = await >>= \case - Nothing -> return () -- i.e. close the conduit -- TODO signal shutdown globally - Just message -> handleMessage (fromMessage message) >> eventHandler + Nothing -> + return () -- i.e. close the conduit -- TODO signal shutdown globally + Just message -> do + handleMessage (fromMessage message, fromMessage message) + eventHandler -yield' :: (MonadIO io) => Object -> ConduitM i ByteString io () + +yield' :: (MonadIO io) => MsgpackRPC.Message -> ConduitM i ByteString io () yield' o = do liftIO . debugM "EventHandler" $ "Sending: " ++ show o - yield $ encode o + yield . encode $ toObject o -handleMessage :: Maybe RPCMessage -> ConduitM i ByteString EventHandler () +handleMessage :: (Maybe FunctionCall, Maybe MsgpackRPC.Message) + -> ConduitM i ByteString EventHandler () handleMessage = \case - Just (FunctionCall fn params reply time) -> do + (Just (FunctionCall fn params reply time), _) -> do i <- get modify succ - rs <- asks (recipients . customConfig) + rs <- asks (recipients . Internal.customConfig) atomically' . modifyTVar rs $ Map.insert i (time, reply) - yield' $ ObjectArray - [ toObject (0 :: Int64) - , ObjectInt i - , toObject fn - , toObject params - ] - Just (Response i e res) -> - yield' $ ObjectArray - [ toObject (1 :: Int64) - , ObjectInt i - , toObject e - , toObject res - ] - Just (NotificationCall fn params) -> - yield' $ ObjectArray - [ ObjectInt 2 - , toObject fn - , toObject params - ] - Nothing -> return () -- i.e. skip to next message + yield' $ MsgpackRPC.Request (Request fn i 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 --- a/library/Neovim/RPC/FunctionCall.hs +++ b/library/Neovim/RPC/FunctionCall.hs @@ -25,16 +25,19 @@ import Neovim.Classes import Neovim.Context -import Neovim.Plugin.IPC -import Neovim.Plugin.IPC.Internal +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 as R +import Control.Monad.Reader import Data.MessagePack import Data.Monoid -import Data.Text +import Prelude + unexpectedException :: String -> err -> a unexpectedException fn _ = error $ "Function threw an exception even though it was declared not to throw one: " @@ -42,20 +45,19 @@ withIgnoredException :: (Functor f, NvimObject result) - => Text -- ^ Function name for better error messages + => FunctionName -- ^ For better error messages -> f (Either err result) -> f result -withIgnoredException fn = fmap (either ((unexpectedException . unpack) fn) id) +withIgnoredException fn = fmap (either ((unexpectedException . show) fn) id) --- | Helper function that concurrently puts a 'Message' in the event queue --- and returns an 'STM' action that returns the result. +-- | Helper function that concurrently puts a 'Message' in the event queue and returns an 'STM' action that returns the result. acall :: (NvimObject result) - => Text + => FunctionName -> [Object] -> Neovim r st (STM (Either Object result)) acall fn parameters = do - q <- eventQueue + q <- Internal.asks' Internal.eventQueue mv <- liftIO newEmptyTMVarIO timestamp <- liftIO getCurrentTime atomically' . writeTQueue q . SomeMessage $ FunctionCall fn parameters mv timestamp @@ -69,7 +71,7 @@ acall' :: (NvimObject result) - => Text + => FunctionName -> [Object] -> Neovim r st (STM result) acall' fn parameters = withIgnoredException fn <$> acall fn parameters @@ -78,14 +80,14 @@ -- | Call a neovim function synchronously. This function blocks until the -- result is available. scall :: (NvimObject result) - => Text -- ^ Function name + => FunctionName -> [Object] -- ^ Parameters in an 'Object' array -> Neovim r st (Either Object result) -- ^ result value of the call or the thrown exception scall fn parameters = acall fn parameters >>= atomically' -scall' :: NvimObject result => Text -> [Object] -> Neovim r st result +scall' :: NvimObject result => FunctionName -> [Object] -> Neovim r st result scall' fn = withIgnoredException fn . scall fn @@ -127,11 +129,7 @@ -- | Send the result back to the neovim instance. respond :: (NvimObject result) => Request -> Either String result -> Neovim r st () respond Request{..} result = do - q <- eventQueue - atomically' . writeTQueue q . SomeMessage $ uncurry (Response reqId) oResult - - where - oResult = case result of - Left e -> (toObject e, toObject ()) - Right r -> (toObject (), toObject r) + q <- Internal.asks' Internal.eventQueue + atomically' . writeTQueue q . SomeMessage . MsgpackRPC.Response reqId $ + either (Left . toObject) (Right . toObject) result diff --git a/library/Neovim/RPC/SocketReader.hs b/library/Neovim/RPC/SocketReader.hs --- a/library/Neovim/RPC/SocketReader.hs +++ b/library/Neovim/RPC/SocketReader.hs @@ -18,33 +18,34 @@ ) where import Neovim.Classes -import Neovim.Context hiding (ask, asks) -import Neovim.Plugin.Classes (CommandArguments (..), - CommandOption (..), - FunctionalityDescription (..), - getCommandOptions) -import Neovim.Plugin.IPC -import Neovim.Plugin.IPC.Internal +import Neovim.Context +import qualified Neovim.Context.Internal as Internal +import Neovim.Plugin.Classes (CommandArguments (..), + CommandOption (..), + FunctionName (..), + FunctionalityDescription (..), + getCommandOptions) +import Neovim.Plugin.IPC.Classes +import Neovim.Plugin (registerInStatelessContext) +import qualified Neovim.RPC.Classes as MsgpackRPC import Neovim.RPC.Common import Neovim.RPC.FunctionCall import Control.Applicative -import Control.Concurrent (forkIO) +import Control.Concurrent (forkIO) import Control.Concurrent.STM -import Control.Monad (void) -import Control.Monad.Reader (MonadReader, ask, asks) -import Control.Monad.Trans.Resource hiding (register) -import Data.Conduit as C +import Control.Monad (void) +import Control.Monad.Trans.Class (lift) +import Data.Conduit as C import Data.Conduit.Binary import Data.Conduit.Cereal -import Data.Default (def) -import Data.Foldable (foldl', forM_) -import qualified Data.Map as Map +import Data.Default (def) +import Data.Foldable (foldl', forM_) +import qualified Data.Map as Map import Data.MessagePack import Data.Monoid -import qualified Data.Serialize (get) -import Data.Text (Text, unpack) -import System.IO (IOMode (ReadMode)) +import qualified Data.Serialize (get) +import System.IO (Handle) import System.Log.Logger import Prelude @@ -52,119 +53,111 @@ 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 :: SocketType -> ConfigWrapper RPCConfig -> IO () -runSocketReader socketType env = do - h <- createHandle ReadMode socketType - runSocketHandler env $ +runSocketReader :: Handle + -> Internal.Config RPCConfig st + -> IO () +runSocketReader readableHandle cfg = + void . runNeovim (Internal.retypeConfig (Internal.customConfig cfg) () cfg) () $ do -- addCleanup (cleanUpHandle h) (sourceHandle h) -- TODO test whether/how this should be handled -- this has been commented out because I think that restarting the -- plugin provider should not cause the stdin and stdout handles to be -- closed since that would cause neovim to stop the plugin provider (I -- think). - sourceHandle h + sourceHandle readableHandle $= conduitGet Data.Serialize.get $$ messageHandlerSink --- | Convenient transformer stack for the socket reader. -newtype SocketHandler a = - SocketHandler (ResourceT (Neovim RPCConfig ()) a) - deriving ( Functor, Applicative, Monad , MonadIO - , MonadReader (ConfigWrapper RPCConfig), MonadThrow) -runSocketHandler :: ConfigWrapper RPCConfig -> SocketHandler a -> IO () -runSocketHandler r (SocketHandler a) = - void $ runNeovim r () (runResourceT a >> quit) - -- | Sink that delegates the messages depending on their type. -- messageHandlerSink :: Sink Object SocketHandler () messageHandlerSink = awaitForever $ \rpc -> do liftIO . debugM logger $ "Received: " <> show rpc - case rpc of - ObjectArray [ObjectInt msgType, ObjectInt fi, e, result] -> - handleResponseOrRequest msgType fi e result - ObjectArray [ObjectInt msgType, method, params] -> - handleNotification msgType method params - obj -> liftIO . errorM logger $ - "Unhandled rpc message: " <> show obj + case fromObject rpc of + Right (MsgpackRPC.Request (Request fn i ps)) -> + handleRequestOrNotification (Just i) fn ps -handleResponseOrRequest :: Int64 -> Int64 -> Object -> Object - -> Sink a SocketHandler () -handleResponseOrRequest msgType i - | msgType == 1 = handleResponse i - | msgType == 0 = handleRequestOrNotification (Just i) - | otherwise = \_ _ -> do - liftIO . errorM logger $ "Invalid message type: " <> show msgType - return () + Right (MsgpackRPC.Response i r) -> + handleResponse i r -handleResponse :: Int64 -> Object -> Object -> Sink a SocketHandler () -handleResponse i e result = do - answerMap <- asks (recipients . customConfig) + Right (MsgpackRPC.Notification (Notification fn ps)) -> + handleRequestOrNotification Nothing fn ps + + Left e -> liftIO . errorM logger $ + "Unhandled rpc message: " <> show e + + +handleResponse :: Int64 -> Either Object Object -> Sink a 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 $ case e of - ObjectNil -> Right result - _ -> Left e + atomically' $ putTMVar reply result -- | Act upon the received request or notification. The main difference between -- the two is that a notification does not generate a reply. The distinction -- between those two cases is done via the first paramater which is 'Maybe' the -- function call identifier. -handleRequestOrNotification :: Maybe Int64 -> Object -> Object -> Sink a SocketHandler () -handleRequestOrNotification mi method (ObjectArray params) = case fromObject method of - Left e -> liftIO . errorM logger $ show e - -- Fork everything so that we do not block. - -- - -- XXX If the functions never return, we may end up with a lot of idle - -- threads. Maybe we should gather the ThreadIds and kill them after some - -- amount of time if they are still around. Maybe resourcet provides such a - -- facility for threads already. - Right m -> void . liftIO . forkIO . handle m =<< ask +handleRequestOrNotification :: Maybe Int64 -> FunctionName -> [Object] -> Sink a SocketHandler () +handleRequestOrNotification mi m params = do + cfg <- lift Internal.ask' + void . liftIO . forkIO $ handle cfg where - lookupFunction :: Text -> RPCConfig -> STM (Maybe (FunctionalityDescription, FunctionType)) - lookupFunction m rpc = Map.lookup m <$> readTMVar (functions rpc) + lookupFunction + :: TMVar Internal.FunctionMap + -> STM (Maybe (FunctionalityDescription, Internal.FunctionType)) + lookupFunction funMap = Map.lookup m <$> readTMVar funMap - handle m rpc = atomically (lookupFunction m (customConfig rpc)) >>= \case + handle :: Internal.Config RPCConfig () -> IO () + handle rpc = atomically (lookupFunction (Internal.globalFunctionMap rpc)) >>= \case + Nothing -> do - let errM = "No provider for: " <> unpack m + let errM = "No provider for: " <> show m debugM logger errM - forM_ mi $ \i -> atomically' . writeTQueue (_eventQueue rpc) - . SomeMessage $ Response i (toObject errM) ObjectNil - Just (copts, Stateless f) -> do + forM_ mi $ \i -> atomically' . writeTQueue (Internal.eventQueue rpc) + . SomeMessage $ MsgpackRPC.Response i (Left (toObject errM)) + Just (copts, Internal.Stateless f) -> do liftIO . debugM logger $ "Executing stateless function with ID: " <> show mi -- Stateless function: Create a boring state object for the -- Neovim context. -- drop the state of the result with (fmap fst <$>) - res <- fmap fst <$> runNeovim (rpc { customConfig = () }) () (f $ parseParams copts params) + let rpc' = rpc + { Internal.customConfig = () + , Internal.pluginSettings = Just . Internal.StatelessSettings $ + registerInStatelessContext (\_ -> return ()) + } + res <- fmap fst <$> runNeovim rpc' () (f $ parseParams copts params) -- Send the result to the event handler - forM_ mi $ \i -> atomically' . writeTQueue (_eventQueue rpc) - . SomeMessage . uncurry (Response i) $ responseResult res - Just (copts, Stateful c) -> do + forM_ mi $ \i -> atomically' . writeTQueue (Internal.eventQueue rpc) + . SomeMessage . MsgpackRPC.Response i $ either (Left . toObject) Right res + Just (copts, Internal.Stateful c) -> do now <- liftIO getCurrentTime reply <- liftIO newEmptyTMVarIO - let q = (recipients . customConfig) rpc + let q = (recipients . Internal.customConfig) rpc liftIO . debugM logger $ "Executing stateful function with ID: " <> show mi case mi of Just i -> do atomically' . modifyTVar q $ Map.insert i (now, reply) - atomically' . writeTQueue c . SomeMessage $ Request m i (parseParams copts params) + atomically' . writeTQueue c . SomeMessage $ + Request m i (parseParams copts params) + Nothing -> - atomically' . writeTQueue c . SomeMessage $ Notification m (parseParams copts params) - responseResult (Left !e) = (toObject e, ObjectNil) - responseResult (Right !res) = (ObjectNil, toObject res) + atomically' . writeTQueue c . SomeMessage $ + Notification m (parseParams copts params) -handleRequestOrNotification _ _ params = liftIO . errorM logger $ - "Parmaeters in request are not in an object array: " <> show params --- TODO implement proper handling for additional parameters parseParams :: FunctionalityDescription -> [Object] -> [Object] parseParams (Function _ _) args = case args of -- Defining a function on the remote host creates a function that, that @@ -208,7 +201,7 @@ either (const old) (\b -> (c { bang = Just b }, args')) $ fromObject o (CmdNargs "*", ObjectArray os) -> - -- CommadnArguments -> [String] -> Neovim r st a + -- CommandArguments -> [String] -> Neovim r st a (c, os) (CmdNargs "+", ObjectArray (o:os)) -> -- CommandArguments -> String -> [String] -> Neovim r st a @@ -237,15 +230,4 @@ parseParams (Autocmd _ _ _) args = case args of [ObjectArray fArgs] -> fArgs _ -> args - - -handleNotification :: Int64 -> Object -> Object -> Sink a SocketHandler () -handleNotification 2 method params = do - liftIO . debugM logger $ "Received notification: " <> show method <> show params - handleRequestOrNotification Nothing method params -handleNotification msgType fn params = liftIO . errorM logger $ - "Message is not a noticiation. Received msgType: " <> show msgType - <> " The expected value was 2. The following arguments were given: " - <> show fn <> " and " <> show params - diff --git a/library/Neovim/Test.hs b/library/Neovim/Test.hs new file mode 100644 --- /dev/null +++ b/library/Neovim/Test.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE LambdaCase #-} +{- | +Module : Neovim.Test +Description : Testing functions +Copyright : (c) Sebastian Witte +License : Apache-2.0 + +Maintainer : woozletoff@gmail.com +Stability : experimental +Portability : GHC + +-} +module Neovim.Test ( + testWithEmbeddedNeovim, + ) where + +import Neovim +import qualified Neovim.Context.Internal as Internal +import Neovim.RPC.Common (newRPCConfig, RPCConfig) +import Neovim.RPC.EventHandler (runEventHandler) +import Neovim.RPC.SocketReader (runSocketReader) + +import Control.Concurrent +import Control.Concurrent.STM (atomically, putTMVar) +import Control.Monad.Reader (runReaderT) +import Control.Monad.State (runStateT) +import Control.Monad.Trans.Resource (runResourceT) +import System.Directory +import System.Exit (ExitCode (..)) +import System.IO (Handle) +import System.Process + + +-- | Type synonym for 'Word'. +type Seconds = Word + + +-- | Run the given 'Neovim' action according to the given parameters. +-- The embedded neovim instance is started without a config (i.e. it is passed +-- @-u NONE@). +-- +-- If you want to run your tests purely from haskell, you have to setup +-- the desired state of neovim with the help of the functions in +-- "Neovim.API.String". +testWithEmbeddedNeovim + :: Maybe FilePath -- ^ Optional path to a file that should be opened + -> Seconds -- ^ Maximum time (in seconds) that a test is allowed to run + -> r -- ^ Read-only configuration + -> st -- ^ State + -> Neovim r st a -- ^ Test case + -> IO () +testWithEmbeddedNeovim file timeout r st (Internal.Neovim a) = do + (_, _, ph, cfg) <- startEmbeddedNvim file timeout + + let testCfg = Internal.retypeConfig r st cfg + + void $ runReaderT (runStateT (runResourceT a) st) testCfg + + -- vim_command isn't asynchronous, so we need to avoid waiting for the + -- result of the operation since neovim cannot send a result if it + -- has quit. + let Internal.Neovim q = vim_command "qa!" + void . forkIO . void $ runReaderT (runStateT (runResourceT q) st ) testCfg + + waitForProcess ph >>= \case + ExitFailure i -> + fail $ "Neovim returned with an exit status of: " ++ show i + + ExitSuccess -> + return () + + +startEmbeddedNvim + :: Maybe FilePath + -> Word + -> IO (Handle, Handle, ProcessHandle, Internal.Config RPCConfig st) +startEmbeddedNvim file timeout = do + args <- case file of + Nothing -> + return [] + + Just f -> do + -- 'fail' should work with most testing frameworks. In case + -- it doesn't, please file a bug report! + unlessM (doesFileExist f) . fail $ "File not found: " ++ f + return [f] + + (Just hin, Just hout, _, ph) <- + createProcess (proc "nvim" (["-n","-u","NONE","--embed"] ++ args)) + { std_in = CreatePipe + , std_out = CreatePipe + } + + cfg <- Internal.newConfig (pure Nothing) newRPCConfig + + void . forkIO $ runSocketReader + hout + (cfg { Internal.pluginSettings = Nothing }) + + void . forkIO $ runEventHandler + hin + (cfg { Internal.pluginSettings = Nothing }) + + atomically $ putTMVar + (Internal.globalFunctionMap cfg) + (Internal.mkFunctionMap []) + + void . forkIO $ do + threadDelay $ (fromIntegral timeout) * 1000 * 1000 + getProcessExitCode ph >>= maybe (terminateProcess ph) (\_ -> return ()) + + return (hin, hout, ph, cfg) + diff --git a/library/Neovim/Util.hs b/library/Neovim/Util.hs new file mode 100644 --- /dev/null +++ b/library/Neovim/Util.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE LambdaCase #-} +{- | +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 ( + withCustomEnvironment, + whenM, + unlessM, + ) where + +import Control.Monad (forM, forM_, when, unless) +import Control.Monad.Catch (MonadMask, bracket) +import Neovim.Context +import System.SetEnv +import System.Environment + + +-- | Execute the given action with a changed set of environment variables and +-- restore the original state of the environment afterwards. +withCustomEnvironment :: (MonadMask io, MonadIO io) + => [(String, Maybe String)] -> io a -> io a +withCustomEnvironment modifiedEnvironment action = + bracket saveAndSet unset (const action) + + where + saveAndSet = do + preservedValues <- forM modifiedEnvironment $ \(var, val) -> liftIO $ do + old <- lookupEnv var + maybe (unsetEnv var) (setEnv var) val + return (var, old) + return preservedValues + + unset preservedValues = forM_ preservedValues $ \(var, val) -> liftIO $ + maybe (unsetEnv var) (setEnv var) val + + +-- | '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 diff --git a/nvim-hs-devel.sh b/nvim-hs-devel.sh new file mode 100644 --- /dev/null +++ b/nvim-hs-devel.sh @@ -0,0 +1,34 @@ +#!/bin/sh + +# Helper script to run nvim-hs in a development environment. + +# You should not name this script nvim-hs and put it on your path. +if [ x"$0" = x`which nvim-hs` ] ; then + echo "This script has the potential to run in an infinite loop. Exiting now..." + exit 1 +fi + +# This variable defines where the sandbox or stack files can be found. Adjust it +# appropriately and then delete the line after it. +sandbox_directory=$HOME/git/nvim-hs +echo "I should have read the comments. Silly me." && exit 1 + +old_pwd="`pwd`" +cd "$sandbox_directory" + +if [ -d "$sandbox_directory/.cabal-sandbox" ] ; then + # We detect the sandbox by checking for the directory .cabal-sandbox + # This should work most of the time. + env CABAL_SANDBOX_CONFIG="$sandbox_directory"/cabal.sandbox.config cabal \ + exec "$sandbox_directory/.cabal-sandbox/bin/nvim-hs" -- "$@" +elif [ -d "$sandbox_directory/.stack-work" ] ; then + # Stack leaves behind a .stack-work directory, so we take its present as a + # sign to use this approach. + PATH=`stack path --bin-path` stack exec nvim-hs -- "$@" +else + echo "No development directories found. Have you built the project?" + exit 2 +fi +cd "$old_pwd" + +# vim: foldmethod=marker sts=2 ts=4 expandtab sw=4 diff --git a/nvim-hs.cabal b/nvim-hs.cabal --- a/nvim-hs.cabal +++ b/nvim-hs.cabal @@ -1,5 +1,5 @@ name: nvim-hs -version: 0.0.2 +version: 0.0.3 synopsis: Haskell plugin backend for neovim description: This package provides a plugin provider for neovim. It allows you to write @@ -12,7 +12,7 @@ . If you spot any errors or if you have great ideas, feel free to open an issue on github. -homepage: https://github.com/saep/nvim-hs +homepage: https://github.com/neovimhaskell/nvim-hs license: Apache-2.0 license-file: LICENSE author: Sebastian Witte @@ -23,7 +23,8 @@ cabal-version: >=1.10 extra-source-files: TestPlugins.vim , TestPlugins.hs - , nvim-hs.sh + , TestPlugins.sh + , nvim-hs-devel.sh , test-files/compile-error-for-quickfix-test1 , test-files/compile-error-for-quickfix-test2 , test-files/compile-error-for-quickfix-test3 @@ -33,17 +34,21 @@ , CHANGELOG.md source-repository head type: git - location: https://github.com/saep/nvim-hs + location: https://github.com/neovimhaskell/nvim-hs executable nvim-hs main-is: Main.hs hs-source-dirs: executable default-language: Haskell2010 - build-depends: base ==4.*, nvim-hs, data-default + build-depends: base >=4.6 && <5, nvim-hs, data-default ghc-options: -threaded -rtsopts -with-rtsopts=-N library exposed-modules: Neovim + , Neovim.Quickfix + , Neovim.Plugin.ConfigHelper + , Neovim.Debug + , Neovim.Test -- Note that every module below this is considered internal and if you have to -- import it somewhere in your code and you think it should be generally -- available , you should open a ticket about inclusion in the export list of @@ -51,27 +56,29 @@ -- this library should have the freedom to do what she wants. , Neovim.API.String , Neovim.Classes + , Neovim.Config , Neovim.Context + , Neovim.Context.Internal , Neovim.Plugin , Neovim.Plugin.Classes + , Neovim.Plugin.Internal , Neovim.Plugin.IPC - , Neovim.Plugin.IPC.Internal , Neovim.Plugin.IPC.Classes - , Neovim.Config - , Neovim.Debug + , Neovim.Log , Neovim.Main + , Neovim.RPC.Classes , Neovim.RPC.Common , Neovim.RPC.EventHandler , Neovim.RPC.FunctionCall , Neovim.RPC.SocketReader - , Neovim.Plugin.ConfigHelper - , Neovim.Quickfix + , Neovim.Plugin.Startup + , Neovim.Util other-modules: Neovim.Plugin.ConfigHelper.Internal , Neovim.API.Parser , Neovim.API.TH -- other-extensions: - build-depends: base ==4.* + build-depends: base >=4.6 && < 5 , bytestring , cereal , cereal-conduit @@ -81,7 +88,9 @@ , data-default , directory , dyre + , exceptions , filepath + , foreign-store , hslogger , messagepack >= 0.4 , monad-control @@ -89,9 +98,10 @@ , lifted-base , mtl >= 2.2.1 && < 2.3 , optparse-applicative - , parsec ==3.* + , parsec >= 3.1.9 , process , resourcet + , setenv >= 0.1.1.3 , stm , streaming-commons , template-haskell @@ -110,7 +120,7 @@ hs-source-dirs: test-suite,library main-is: Spec.hs default-language: Haskell2010 - build-depends: base + build-depends: base >= 4.6 && < 5 , nvim-hs , hspec ==2.* @@ -126,22 +136,26 @@ , data-default , directory , dyre + , exceptions , filepath + , foreign-store , hslogger , lifted-base , mtl >= 2.2.1 && < 2.3 , messagepack >= 0.4 , network , optparse-applicative - , parsec + , parsec >= 3.1.9 , process , resourcet + , setenv >= 0.1.1.3 , stm , streaming-commons , text , template-haskell , time , transformers + , transformers-base , utf8-string , HUnit diff --git a/nvim-hs.sh b/nvim-hs.sh deleted file mode 100644 --- a/nvim-hs.sh +++ /dev/null @@ -1,24 +0,0 @@ -#!/bin/sh - -# Shell script that starts a plugin provider which is interpreted from the -# TestPlugins.hs file inside this repository. - -if ! type cabal > /dev/null 2>&1 ; then - echo "cabal not installed or on PATH" - echo $PATH - exit 1 -fi - -if ! type runghc > /dev/null 2>&1 ; then - echo "runghc not installed or on PATH" - echo $PATH - exit 1 -fi - -if [ -d ".cabal-sandbox/" ] ; then - # Use `cabal exec` if we are in a sandbox - exec cabal exec runghc TestPlugins.hs -- $1 -l test-log.txt -v DEBUG -else - exec runghc TestPlugins.hs -- $1 -l test-log.txt -v DEBUG -fi - diff --git a/test-files/compile-error-for-quickfix-test5 b/test-files/compile-error-for-quickfix-test5 --- a/test-files/compile-error-for-quickfix-test5 +++ b/test-files/compile-error-for-quickfix-test5 @@ -1,5 +1,5 @@ -/.config/nvim/lib/TestPlugins.hs:23:9: +/.config/nvim/lib/TestPlugins.hs:23:9: Warning: Couldn't match type ‘STM (Either Object Object)’ with ‘[Char]’ Expected type: Neovim () () String Actual type: Neovim () () (STM (Either Object Object)) @@ -10,7 +10,7 @@ = vim_call_dict_function "g:mydict" False "Greet" [toObject "World"] -/.config/nvim/lib/TestPlugins.hs:23:32: +/.config/nvim/lib/TestPlugins.hs:23:32:Warning: Couldn't match expected type ‘Object’ with actual type ‘[Char]’ In the first argument of ‘vim_call_dict_function’, namely ‘"g:mydict"’