nvim-hs 0.2.5 → 1.0.0.0
raw patch · 29 files changed
+750/−740 lines, 29 filesdep +prettyprinterdep +prettyprinter-ansi-terminaldep +unliftiodep −ansi-wl-pprintdep −conduit-extradep −exceptionsdep ~cereal-conduitdep ~conduitdep ~resourcet
Dependencies added: prettyprinter, prettyprinter-ansi-terminal, unliftio, unliftio-core
Dependencies removed: ansi-wl-pprint, conduit-extra, exceptions, lifted-base, monad-control
Dependency ranges changed: cereal-conduit, conduit, resourcet, setenv
Files
- CHANGELOG.md +27/−0
- library/Neovim.hs +75/−60
- library/Neovim/API/Parser.hs +24/−23
- library/Neovim/API/TH.hs +15/−15
- library/Neovim/Classes.hs +77/−55
- library/Neovim/Config.hs +1/−1
- library/Neovim/Context.hs +15/−13
- library/Neovim/Context/Internal.hs +65/−92
- library/Neovim/Debug.hs +45/−43
- library/Neovim/Exceptions.hs +18/−11
- library/Neovim/Main.hs +10/−10
- library/Neovim/Plugin.hs +76/−113
- library/Neovim/Plugin/Classes.hs +30/−28
- library/Neovim/Plugin/ConfigHelper.hs +12/−17
- library/Neovim/Plugin/ConfigHelper/Internal.hs +23/−15
- library/Neovim/Plugin/IPC/Classes.hs +18/−17
- library/Neovim/Plugin/Internal.hs +10/−20
- library/Neovim/Quickfix.hs +42/−20
- library/Neovim/RPC/Classes.hs +13/−10
- library/Neovim/RPC/Common.hs +4/−0
- library/Neovim/RPC/EventHandler.hs +21/−39
- library/Neovim/RPC/FunctionCall.hs +22/−22
- library/Neovim/RPC/SocketReader.hs +33/−44
- library/Neovim/Test.hs +41/−31
- library/Neovim/Util.hs +11/−7
- nvim-hs.cabal +13/−24
- test-suite/Neovim/API/THSpec.hs +3/−3
- test-suite/Neovim/API/THSpecFunctions.hs +5/−5
- test-suite/Neovim/EmbeddedRPCSpec.hs +1/−2
CHANGELOG.md view
@@ -1,3 +1,30 @@+# 1.0.0.0++* Each plugin (type) now defines an environment which is similar to how+ stateful plugins have been declared in previous versions. If you need+ multiple different environments for different functions, you can make them+ fields of a bigger environment or define multiple plugin values.++ The type `Neovim r st a` has become `Neovim env a` where `env` is+ technically equivalent to the previous `r`.+ I was mainly motivated by this blog post:++ https://www.fpcomplete.com/blog/2017/06/readert-design-pattern++* Only works with ghc >= 8. I removed some backwards compatibility. If you+ need older ghc versions, just use the previous version (0.2.5) as the+ feature set hasn't really changed.++* A different pretty printer library is now used and may surface at some+ places.++* Functions do now time out after some time, 10 seconds for those that block+ neovim and 10 minutes for background functions.++* A few types have been adjusted.++* Some improvement in error reporting.+ # 0.2.5 * Older versions of `nvim-hs` may not function if some versions of a
library/Neovim.hs view
@@ -22,7 +22,6 @@ -- ** tl;dr -- $tldrgettingstarted Neovim,- Neovim', neovim, NeovimConfig(..), defaultConfig,@@ -35,7 +34,6 @@ -- ** Creating a plugin -- $creatingplugins NeovimPlugin(..),- StatefulFunctionality(..), Plugin(..), NvimObject(..), (+:),@@ -53,14 +51,9 @@ CommandArguments(..), AutocmdOptions(..), addAutocmd,- addAutocmd', ask, asks,- put,- get,- gets,- modify, -- ** Creating a stateful plugin -- $statefulplugin@@ -72,10 +65,7 @@ waitErr, waitErr', err,- Doc,- Pretty(..), errOnInvalidResult,- text, NeovimException(..), -- ** Generated functions for neovim interaction module Neovim.API.String,@@ -89,6 +79,11 @@ unlessM, docToObject, docFromObject,+ Doc,+ AnsiStyle,+ Pretty(..),+ putDoc,+ exceptionToDoc, Priority(..), module Control.Monad, module Control.Applicative,@@ -110,15 +105,17 @@ import Neovim.API.TH (autocmd, command, command', function, function') import Neovim.Classes (Dictionary, NvimObject (..),+ Doc, AnsiStyle, Pretty(..), docFromObject, docToObject, (+:)) import Neovim.Config (NeovimConfig (..))-import Neovim.Context (Neovim, Neovim',- NeovimException (ErrorMessage),+import Neovim.Context (Neovim,+ NeovimException(..),+ exceptionToDoc, ask, asks, err, errOnInvalidResult, get, gets, modify, put) import Neovim.Main (neovim)-import Neovim.Plugin (addAutocmd, addAutocmd')+import Neovim.Plugin (addAutocmd) import Neovim.Plugin.Classes (AutocmdOptions (..), CommandArguments (..), CommandOption (CmdBang, CmdCount, CmdRange, CmdRegister, CmdSync),@@ -126,14 +123,13 @@ Synchronous (..)) import qualified Neovim.Plugin.ConfigHelper as ConfigHelper import Neovim.Plugin.Internal (NeovimPlugin (..), Plugin (..),- StatefulFunctionality(..), wrapPlugin)+ 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 (..))-import Text.PrettyPrint.ANSI.Leijen (Doc, Pretty (..), text)-+import Data.Text.Prettyprint.Doc.Render.Terminal (putDoc) -- Installation {{{1 {- $installation @@ -149,7 +145,7 @@ If you are proficient with Haskell, it may be sufficient to point you at some of the important data structures and functions. So, I will do it here. If you need more assistance, please skip to the next section and follow the links for functions or data-types you do no understand how to use. If you think that the documentation is lacking,+types you do not understand how to use. If you think that the documentation is lacking, please create an issue on github (or even better, a pull request with a fix @;-)@). The code sections that describe new functionality are followed by the source code documentation of the used functions (and possibly a few more).@@ -252,7 +248,7 @@ import "Neovim" \-\- \| Neovim is not really good with big numbers, so we return a 'String' here.-fibonacci :: 'Int' -> 'Neovim'' 'String'+fibonacci :: 'Int' -> 'Neovim' env 'String' fibonacci n = 'return' . 'show' \$ fibs !! n where fibs :: [Integer]@@ -270,8 +266,8 @@ plugin :: 'Neovim' ('StartupConfig' 'NeovimConfig') () 'NeovimPlugin' plugin = 'wrapPlugin' Plugin- { 'exports' = [ $('function'' 'fibonacci) 'Sync' ]- , 'statefulExports' = []+ { 'environment' = ()+ , 'exports' = [ $('function'' 'fibonacci) 'Sync' ] } @ @@ -292,35 +288,27 @@ that takes the @n@th element of the infinite list of Fibonacci numbers. Even though the definition is very concise and asthetically pleasing, the important part is the type signature for @fibonacci@. Similarly how @main :: IO ()@ works in normal Haskell-programs, 'Neovim'' is the environment we need for plugins. Internally, it stores a+programs, 'Neovim' is the environment we need for plugins. Internally, it stores a few things that are needed to communicate with neovim, but that shouldn't bother you too much. Simply remember that every plugin function must have a function signature-whose last element is of type @'Neovim' r st something@. The result of @fibonacci@+whose last element is of type @'Neovim' env something@. The result of @fibonacci@ is 'String' because neovim cannot handle big numbers so well. :-) You can use any argument or result type as long as it is an instance of 'NvimObject'. The second part of of the puzzle, which is the definition of @plugin@-in @~\/.config\/nvim\/lib\/Fibonacci.hs@, shows what a plugin is. It is essentially two-lists of stateless and stateful functionality. A functionality can currently be one-of three things: a function, a command and an autocmd in the context of vim-terminology. In the end, all of those functionalities map to a function at the side+in @~\/.config\/nvim\/lib\/Fibonacci.hs@, shows what a plugin is. It is essentially+an environment that and a list of functions, commands or autocommands in the context of vim+terminology. In the end, all of those things map to a function at the side of /nvim-hs/. If you really want to know what the distinction between those is, you have to consult the @:help@ pages of neovim (e.g. @:help :function@, @:help :command@-and @:help :autocmd@). What's relevant from the side of /nvim-hs/ is the distinction-between __stateful__ and __stateless__. A stateless function can be called at any-time and it does not share any of its internals with other functions. A stateful-function on the other hand can share a well-defined amount of state with other-functions and in the next section I will show you a simple example for that.-Anyhow, if you take a look at the type alias for 'Neovim', you notice the two-type variables @r@ and @st@. These can be accessed with different semantics-each. A value of type @r@ can only be read. It is more or less a static value-you can query with 'ask' or 'asks' if you-are inside a 'Neovim' environment. The value @st@ can be changed and those-changes will be available to other functions which run in the same environment.-You can get the current value with 'get', you can replace an existing value with-'put' and you can also apply a function to the current state with 'modify'.-Notice how 'Neovim'' is just a specialization of 'Neovim' with its @r@ and-@st@ set to @()@.+and @:help :autocmd@). What's relevant from the side of /nvim-hs/ is the environment.+The environment is a data type that is avaiable to all exported functions of your+plugin. This example does not make use of anything of that environment, so+we used '()', also known as unit, as our environment. The definition of+@fibonacci@ uses a type variable @env@ as it does not access the environment and+can handly any environment. If you want to access the environment, you can call+'ask' or 'asks' if you are inside a 'Neovim' environment. An example that shows+you how to use it can be found in a later chapter. Now to the magical part: @\$('function'' 'fibonacci)@. This is a so called Template Haskell splice and this is why you need@@ -367,15 +355,47 @@ import "Neovim" -\-\- | Neovim isn't so good with big numbers here either.-nextRandom :: 'Neovim' r ['Int16'] 'Int16'+import System.Random (newStdGen, randoms)+import UnliftIO.STM (TVar, atomically, readTVar, modifyTVar, newTVarIO)++-- You may want to define a type alias for your plugin, so that if you change+-- your environment, you don't have to change all type signatures.+--+-- If I were to write a real plugin, I would probably also create a data type+-- instead of directly using a TVar here.+--+type MyNeovim a = Neovim ('TVar' ['Int16']) a++-- This function will create an initial environment for our random number+-- generator. Note that the return type is the type of our environment.+randomNumbers :: Neovim startupEnv (TVar [Int16])+randomNumbers = do+ g <- liftIO newStdGen -- Create a new seed for a pseudo random number generator+ newTVarIO (randoms g) -- Put an infinite list of random numbers into a TVar++-- | Get the next random number and update the state of the list.+nextRandom :: MyNeovim 'Int16' nextRandom = do- r <- 'gets' 'head' -- get the head of the infinite random number list- 'modify' 'tail' -- set the list to its tail- 'return' r+ tVarWithRandomNumbers <- 'ask'+ atomically $ do+ -- pick the head of our list of random numbers+ r <- 'head' <$> 'readTVar' tVarWithRandomNumbers -setNextRandom :: 'Int16' -> 'Neovim' r ['Int16'] ()-setNextRandom n = 'modify' (n:) -- cons to the front of the infinite list+ -- Since we do not want to return the same number all over the place+ -- remove the head of our list of random numbers+ modifyTVar tVarWithRandomNumbers 'tail'++ 'return' r+++-- | You probably don't want this in a random number generator, but this shows+-- hoy you can edit the state of a stateful plugin.+setNextRandom :: 'Int16' -> MyNeovim ()+setNextRandom n = do+ tVarWithRandomNumbers <- 'ask'++ -- cons n to the front of the infinite list+ atomically $ modifyTVar tVarWithRandomNumbers (n:) @ File @~\/.config\/nvim\/lib\/Random.hs@:@@ -390,18 +410,13 @@ plugin :: 'Neovim' ('StartupConfig' 'NeovimConfig') () 'NeovimPlugin' plugin = do- g <- 'liftIO' 'newStdGen' -- initialize with a random seed- let randomNumbers = 'randoms' g -- an infinite list of random numbers+ env <- randomNumbers 'wrapPlugin' 'Plugin'- { 'exports' = []- , 'statefulExports' = [ 'StatefulFunctionality'- { readOnly = ()- , writable = randomNumbers- , functionalities =- [ $('function'' 'nextRandom) 'Sync'- , $('function' \"SetNextRandom\" 'setNextRandom) 'Async'- ]- }]+ { environment = env+ , 'exports' =+ [ $('function'' 'nextRandom) 'Sync'+ , $('function' \"SetNextRandom\" 'setNextRandom) 'Async'+ ] } @ @@ -455,7 +470,7 @@ to rename it. @-inspectBuffer :: 'Neovim' r st ()+inspectBuffer :: 'Neovim' env () inspectBuffer = do cb <- 'vim_get_current_buffer' isValid <- 'buffer_is_valid' cb
library/Neovim/API/Parser.hs view
@@ -19,20 +19,21 @@ import Neovim.Classes import Control.Applicative-import Control.Exception.Lifted import Control.Monad.Except-import qualified Data.ByteString as B-import Data.Map (Map)-import qualified Data.Map as Map+import qualified Data.ByteString as B+import Data.Map (Map)+import qualified Data.Map as Map import Data.MessagePack-import Data.Monoid import Data.Serialize-import System.IO (hClose)+import Neovim.Compat.Megaparsec as P+import System.IO (hClose) import System.Process-import Neovim.Compat.Megaparsec as P-import Text.PrettyPrint.ANSI.Leijen (Doc)-import qualified Text.PrettyPrint.ANSI.Leijen as P+import UnliftIO.Exception (SomeException,+ bracket, catch) +import Data.Text.Prettyprint.Doc (Doc, Pretty(..), (<+>))+import Data.Text.Prettyprint.Doc.Render.Terminal (AnsiStyle)+ import Prelude data NeovimType = SimpleType String@@ -79,10 +80,10 @@ deriving (Show) -- | Run @nvim --api-info@ and parse its output.-parseAPI :: IO (Either Doc NeovimAPI)-parseAPI = either (Left . P.text) extractAPI <$> (decodeAPI `catch` readFromAPIFile)+parseAPI :: IO (Either (Doc AnsiStyle) NeovimAPI)+parseAPI = either (Left . pretty) extractAPI <$> (decodeAPI `catch` readFromAPIFile) -extractAPI :: Object -> Either Doc NeovimAPI+extractAPI :: Object -> Either (Doc AnsiStyle) NeovimAPI extractAPI apiObj = fromObject apiObj >>= \apiMap -> NeovimAPI <$> extractErrorTypes apiMap <*> extractCustomTypes apiMap@@ -111,21 +112,21 @@ terminateProcess ph -oLookup :: (NvimObject o) => String -> Map String Object -> Either Doc o+oLookup :: (NvimObject o) => String -> Map String Object -> Either (Doc AnsiStyle) o oLookup qry = maybe throwErrorMessage fromObject . Map.lookup qry where- throwErrorMessage = throwError . P.text $ "No entry for: " <> show qry+ throwErrorMessage = throwError $ "No entry for:" <+> pretty qry -oLookupDefault :: (NvimObject o) => o -> String -> Map String Object -> Either Doc o+oLookupDefault :: (NvimObject o) => o -> String -> Map String Object -> Either (Doc AnsiStyle) o oLookupDefault d qry m = maybe (return d) fromObject $ Map.lookup qry m -extractErrorTypes :: Map String Object -> Either Doc [(String, Int64)]+extractErrorTypes :: Map String Object -> Either (Doc AnsiStyle) [(String, Int64)] extractErrorTypes objAPI = extractTypeNameAndID =<< oLookup "error_types" objAPI -extractTypeNameAndID :: Object -> Either Doc [(String, Int64)]+extractTypeNameAndID :: Object -> Either (Doc AnsiStyle) [(String, Int64)] extractTypeNameAndID m = do types <- Map.toList <$> fromObject m forM types $ \(errName, idMap) -> do@@ -133,21 +134,21 @@ return (errName,i) -extractCustomTypes :: Map String Object -> Either Doc [(String, Int64)]+extractCustomTypes :: Map String Object -> Either (Doc AnsiStyle) [(String, Int64)] extractCustomTypes objAPI = extractTypeNameAndID =<< oLookup "types" objAPI -extractFunctions :: Map String Object -> Either Doc [NeovimFunction]+extractFunctions :: Map String Object -> Either (Doc AnsiStyle) [NeovimFunction] extractFunctions objAPI = mapM extractFunction =<< oLookup "functions" objAPI -toParameterlist :: [(String, String)] -> Either Doc [(NeovimType, String)]+toParameterlist :: [(String, String)] -> Either (Doc AnsiStyle) [(NeovimType, String)] toParameterlist ps = forM ps $ \(t,n) -> do t' <- parseType t return (t', n) -extractFunction :: Map String Object -> Either Doc NeovimFunction+extractFunction :: Map String Object -> Either (Doc AnsiStyle) NeovimFunction extractFunction funDefMap = NeovimFunction <$> (oLookup "name" funDefMap) <*> (oLookup "parameters" funDefMap >>= toParameterlist)@@ -156,8 +157,8 @@ <*> (oLookup "return_type" funDefMap >>= parseType) -parseType :: String -> Either Doc NeovimType-parseType s = either (throwError . P.text . show) return $ parse (pType <* eof) s s+parseType :: String -> Either (Doc AnsiStyle) NeovimType+parseType s = either (throwError . pretty . show) return $ parse (pType <* eof) s s pType :: P.Parser NeovimType
library/Neovim/API/TH.hs view
@@ -21,7 +21,7 @@ , autocmd , defaultAPITypeToHaskellTypeMap - , module Control.Exception.Lifted+ , module UnliftIO.Exception , module Neovim.Classes , module Data.Data , module Data.MessagePack@@ -44,7 +44,6 @@ import Control.Arrow (first) import Control.Concurrent.STM (STM) import Control.Exception-import Control.Exception.Lifted import Control.Monad import Data.ByteString (ByteString) import Data.ByteString.UTF8 (fromString)@@ -57,7 +56,8 @@ import Data.Monoid import qualified Data.Set as Set import Data.Text (Text)-import Text.PrettyPrint.ANSI.Leijen (text, (<+>), Doc)+import Data.Text.Prettyprint.Doc ((<+>), Doc, viaShow, Pretty(..))+import UnliftIO.Exception import Prelude @@ -148,8 +148,8 @@ let withDeferred | async nf = appT [t|STM|] | otherwise = id - withException | canFail nf = appT [t|Either NeovimException|]- | otherwise = id+ withException' | canFail nf = appT [t|Either NeovimException|]+ | otherwise = id callFns | async nf && canFail nf = [ [|acall|] ] | async nf = [ [|acall'|] ]@@ -160,13 +160,13 @@ toObjVar v = [|toObject $(varE v)|] - retTypes <- let (r,st) = (mkName "r", mkName "st")+ retTypes <- let env = (mkName "env") createSig retTypeFun =- forallT [PlainTV r, PlainTV st] (return [])- . appT ([t|Neovim $(varT r) $(varT st) |])+ forallT [PlainTV env] (return [])+ . appT ([t|Neovim $(varT env) |]) . withDeferred . retTypeFun . apiTypeToHaskellType typeMap $ returnType nf- in mapM createSig [ withException, id ]+ in mapM createSig [ withException', id ] vars <- mapM (\(t,n) -> (,) <$> apiTypeToHaskellType typeMap t <*> newName n)@@ -252,9 +252,9 @@ clause [ varP o ] (normalB [|throwError $- text "Object is not convertible to:"- <+> text n- <+> text "Received:" <+> (text . show) $(varE o)|])+ pretty "Object is not convertible to:"+ <+> viaShow n+ <+> pretty "Received:" <+> viaShow $(varE o)|]) [] toObjectClause :: Name -> Int64 -> Q Clause@@ -309,7 +309,7 @@ -- | Given a value of type 'Type', test whether it can be classified according--- to the constructors of 'ArgType'.+-- to the constructors of "ArgType". classifyArgType :: Type -> Q ArgType classifyArgType t = do set <- genStringTypesSet@@ -481,7 +481,7 @@ -- _ -> err "Wrong number of arguments" errorCase :: Q Match errorCase = match wildP- (normalB [|throw . ErrorMessage . text $ "Wrong number of arguments for function: "+ (normalB [|throw . ErrorMessage . pretty $ "Wrong number of arguments for function: " ++ $(litE (StringL (nameBase functionName))) |]) [] -- [x,y] -> case pure add <*> fromObject x <*> fromObject y of ...@@ -512,6 +512,6 @@ failedEvaluation :: Q Match failedEvaluation = newName "e" >>= \e -> match (conP (mkName "Left") [varP e])- (normalB [|err ($(varE e) :: Doc)|])+ (normalB [|err ($(varE e) :: Doc AnsiStyle)|]) []
library/Neovim/Classes.hs view
@@ -1,10 +1,10 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ < 710 {-# LANGUAGE OverlappingInstances #-} #endif@@ -25,36 +25,48 @@ , Generic , docToObject , docFromObject+ , docToText + , Doc+ , AnsiStyle+ , Pretty(..)+ , (<+>) , module Data.Int , module Data.Word , module Control.DeepSeq ) where -import Neovim.Exceptions (NeovimException(..))+import Neovim.Exceptions (NeovimException (..)) import Control.Applicative-import Control.Arrow+import Control.Arrow ((***)) import Control.DeepSeq-import Control.Exception.Lifted (throwIO) import Control.Monad.Except-import Control.Monad.Base (MonadBase(..))-import Data.ByteString (ByteString)-import Data.Int (Int16, Int32, Int64, Int8)-import qualified Data.Map.Strict as SMap+import Data.ByteString (ByteString)+import Data.Int (Int16, Int32, Int64,+ Int8)+import qualified Data.Map.Strict as SMap import Data.MessagePack import Data.Monoid-import Data.Text as Text (Text)-import Data.Traversable hiding (forM, mapM)-import Data.Word (Word, Word16, Word32, Word64,- Word8)-import GHC.Generics (Generic)-import Text.PrettyPrint.ANSI.Leijen (Doc, lparen,- rparen, text, displayS, renderCompact)-import qualified Text.PrettyPrint.ANSI.Leijen as P+import Data.Text as Text (Text)+import Data.Text.Prettyprint.Doc (Doc, Pretty (..),+ defaultLayoutOptions,+ layoutPretty, viaShow,+ (<+>))+import qualified Data.Text.Prettyprint.Doc as P+import Data.Text.Prettyprint.Doc.Render.Terminal (AnsiStyle,+ renderStrict)+import Data.Traversable hiding (forM, mapM)+import Data.Word (Word, Word16,+ Word32, Word64,+ Word8)+import GHC.Generics (Generic) -import qualified Data.ByteString.UTF8 as UTF8 (fromString, toString)-import Data.Text.Encoding (decodeUtf8, encodeUtf8)+import qualified Data.ByteString.UTF8 as UTF8 (fromString,+ toString)+import Data.Text.Encoding (decodeUtf8,+ encodeUtf8)+import UnliftIO.Exception (throwIO) import Prelude @@ -62,6 +74,9 @@ infixr 5 +: -- | Convenient operator to create a list of 'Object' from normal values.+-- @+-- values +: of :+ different :+ types :+ can +: be +: combined +: this +: way +: []+-- @ (+:) :: (NvimObject o) => o -> [Object] -> [Object] o +: os = toObject o : os @@ -69,13 +84,19 @@ -- | Convert a 'Doc'-ument to a messagepack 'Object'. This is more a convenience -- method to transport error message from and to neovim. It generally does not -- hold that 'docToObject . docFromObject' = 'id'.-docToObject :: Doc -> Object-docToObject = toObject . flip displayS "" . renderCompact+docToObject :: Doc AnsiStyle -> Object+docToObject = ObjectString . encodeUtf8 . docToText + -- | See 'docToObject'.-docFromObject :: Object -> Either Doc Doc-docFromObject o = P.pretty . UTF8.toString <$> fromObject o+docFromObject :: Object -> Either (Doc AnsiStyle) (Doc AnsiStyle)+docFromObject o = (P.viaShow :: Text -> Doc AnsiStyle) <$> fromObject o ++docToText :: Doc AnsiStyle -> Text+docToText = renderStrict . layoutPretty defaultLayoutOptions++ -- | A generic vim dictionary is a simply a map from strings to objects. This -- type alias is sometimes useful as a type annotation especially if the -- OverloadedStrings extension is enabled.@@ -94,14 +115,14 @@ fromObjectUnsafe :: Object -> o fromObjectUnsafe o = case fromObject o of Left e -> error . show $- text "Not the expected object:" P.<+> (text . show) o- P.<+> lparen P.<> e P.<> rparen+ "Not the expected object:" <+> P.viaShow o+ <+> P.lparen <> e <> P.rparen Right obj -> obj - fromObject :: Object -> Either Doc o+ fromObject :: Object -> Either (Doc AnsiStyle) o fromObject = return . fromObjectUnsafe - fromObject' :: (MonadBase IO io) => Object -> io o+ fromObject' :: (MonadIO io) => Object -> io o fromObject' = either (throwIO . ErrorMessage) return . fromObject @@ -110,7 +131,7 @@ toObject _ = ObjectNil fromObject ObjectNil = return ()- fromObject o = throwError . text $ "Expected ObjectNil, but got " <> show o+ fromObject o = throwError $ "Expected ObjectNil, but got" <+> P.viaShow o -- We may receive truthy values from neovim, so we should be more forgiving@@ -136,7 +157,8 @@ fromObject (ObjectFloat o) = return $ realToFrac o fromObject (ObjectInt o) = return $ fromIntegral o fromObject (ObjectUInt o) = return $ fromIntegral o- fromObject o = throwError . text $ "Expected ObjectDouble, but got " <> show o+ fromObject o = throwError $ "Expected ObjectDouble, but got"+ <+> viaShow o instance NvimObject Integer where@@ -146,7 +168,7 @@ fromObject (ObjectUInt o) = return $ toInteger o fromObject (ObjectDouble o) = return $ round o fromObject (ObjectFloat o) = return $ round o- fromObject o = throwError . text $ "Expected ObjectInt, but got " <> show o+ fromObject o = throwError $ "Expected ObjectInt, but got" <+> viaShow o instance NvimObject Int64 where@@ -156,7 +178,7 @@ fromObject (ObjectUInt o) = return $ fromIntegral o fromObject (ObjectDouble o) = return $ round o fromObject (ObjectFloat o) = return $ round o- fromObject o = throwError . text $ "Expected any Integer value, but got " <> show o+ fromObject o = throwError $ "Expected any Integer value, but got" <+> viaShow o instance NvimObject Int32 where@@ -166,7 +188,7 @@ fromObject (ObjectUInt i) = return $ fromIntegral i fromObject (ObjectDouble o) = return $ round o fromObject (ObjectFloat o) = return $ round o- fromObject o = throwError . text $ "Expected any Integer value, but got " <> show o+ fromObject o = throwError $ "Expected any Integer value, but got" <+> viaShow o instance NvimObject Int16 where@@ -176,7 +198,7 @@ fromObject (ObjectUInt i) = return $ fromIntegral i fromObject (ObjectDouble o) = return $ round o fromObject (ObjectFloat o) = return $ round o- fromObject o = throwError . text $ "Expected any Integer value, but got " <> show o+ fromObject o = throwError $ "Expected any Integer value, but got" <+> viaShow o instance NvimObject Int8 where@@ -186,7 +208,7 @@ fromObject (ObjectUInt i) = return $ fromIntegral i fromObject (ObjectDouble o) = return $ round o fromObject (ObjectFloat o) = return $ round o- fromObject o = throwError . text $ "Expected any Integer value, but got " <> show o+ fromObject o = throwError $ "Expected any Integer value, but got" <+> viaShow o instance NvimObject Word where@@ -196,7 +218,7 @@ fromObject (ObjectUInt i) = return $ fromIntegral i fromObject (ObjectDouble o) = return $ round o fromObject (ObjectFloat o) = return $ round o- fromObject o = throwError . text $ "Expected any Integer value, but got " <> show o+ fromObject o = throwError $ "Expected any Integer value, but got" <+> viaShow o instance NvimObject Word64 where@@ -206,7 +228,7 @@ fromObject (ObjectUInt i) = return $ fromIntegral i fromObject (ObjectDouble o) = return $ round o fromObject (ObjectFloat o) = return $ round o- fromObject o = throwError . text $ "Expected any Integer value, but got " <> show o+ fromObject o = throwError $ "Expected any Integer value, but got" <+> viaShow o instance NvimObject Word32 where@@ -216,7 +238,7 @@ fromObject (ObjectUInt i) = return $ fromIntegral i fromObject (ObjectDouble o) = return $ round o fromObject (ObjectFloat o) = return $ round o- fromObject o = throwError . text $ "Expected any Integer value, but got " <> show o+ fromObject o = throwError $ "Expected any Integer value, but got" <+> viaShow o instance NvimObject Word16 where@@ -226,7 +248,7 @@ fromObject (ObjectUInt i) = return $ fromIntegral i fromObject (ObjectDouble o) = return $ round o fromObject (ObjectFloat o) = return $ round o- fromObject o = throwError . text $ "Expected any Integer value, but got " <> show o+ fromObject o = throwError $ "Expected any Integer value, but got" <+> viaShow o instance NvimObject Word8 where@@ -236,7 +258,7 @@ fromObject (ObjectUInt i) = return $ fromIntegral i fromObject (ObjectDouble o) = return $ round o fromObject (ObjectFloat o) = return $ round o- fromObject o = throwError . text $ "Expected any Integer value, but got " <> show o+ fromObject o = throwError $ "Expected any Integer value, but got" <+> viaShow o instance NvimObject Int where@@ -246,7 +268,7 @@ fromObject (ObjectUInt i) = return $ fromIntegral i fromObject (ObjectDouble o) = return $ round o fromObject (ObjectFloat o) = return $ round o- fromObject o = throwError . text $ "Expected any Integer value, but got " <> show o+ fromObject o = throwError $ "Expected any Integer value, but got" <+> viaShow o instance {-# OVERLAPPING #-} NvimObject [Char] where@@ -254,21 +276,21 @@ fromObject (ObjectBinary o) = return $ UTF8.toString o fromObject (ObjectString o) = return $ UTF8.toString o- fromObject o = throwError . text $ "Expected ObjectString, but got " <> show o+ fromObject o = throwError $ "Expected ObjectString, but got" <+> viaShow o instance {-# OVERLAPPABLE #-} NvimObject o => NvimObject [o] where toObject = ObjectArray . map toObject fromObject (ObjectArray os) = mapM fromObject os- fromObject o = throwError . text $ "Expected ObjectArray, but got " <> show o+ fromObject o = throwError $ "Expected ObjectArray, but got" <+> viaShow o instance NvimObject o => NvimObject (Maybe o) where toObject = maybe ObjectNil toObject fromObject ObjectNil = return Nothing- fromObject o = either throwError (return . Just) $ fromObject o+ fromObject o = either throwError (return . Just) $ fromObject o @@ -285,7 +307,7 @@ return $ Left l Left e2 ->- throwError $ e1 P.<+> text "--" P.<+> e2+ throwError $ e1 <+> "--" <+> e2 instance (Ord key, NvimObject key, NvimObject val)@@ -299,7 +321,7 @@ . (fromObject *** fromObject)) . SMap.toList) om - fromObject o = throwError . text $ "Expected ObjectMap, but got " <> show o+ fromObject o = throwError $ "Expected ObjectMap, but got" <+> viaShow o instance NvimObject Text where@@ -307,7 +329,7 @@ fromObject (ObjectBinary o) = return $ decodeUtf8 o fromObject (ObjectString o) = return $ decodeUtf8 o- fromObject o = throwError . text $ "Expected ObjectBinary, but got " <> show o+ fromObject o = throwError $ "Expected ObjectBinary, but got" <+> viaShow o instance NvimObject ByteString where@@ -315,7 +337,7 @@ fromObject (ObjectBinary o) = return o fromObject (ObjectString o) = return o- fromObject o = throwError . text $ "Expected ObjectBinary, but got " <> show o+ fromObject o = throwError $ "Expected ObjectBinary, but got" <+> viaShow o instance NvimObject Object where@@ -332,7 +354,7 @@ fromObject (ObjectArray [o1, o2]) = (,) <$> fromObject o1 <*> fromObject o2- fromObject o = throwError . text $ "Expected ObjectArray, but got " <> show o+ fromObject o = throwError $ "Expected ObjectArray, but got" <+> viaShow o instance (NvimObject o1, NvimObject o2, NvimObject o3) => NvimObject (o1, o2, o3) where toObject (o1, o2, o3) = ObjectArray $ [toObject o1, toObject o2, toObject o3]@@ -341,7 +363,7 @@ <$> fromObject o1 <*> fromObject o2 <*> fromObject o3- fromObject o = throwError . text $ "Expected ObjectArray, but got " <> show o+ fromObject o = throwError $ "Expected ObjectArray, but got" <+> viaShow o instance (NvimObject o1, NvimObject o2, NvimObject o3, NvimObject o4) => NvimObject (o1, o2, o3, o4) where@@ -352,7 +374,7 @@ <*> fromObject o2 <*> fromObject o3 <*> fromObject o4- fromObject o = throwError . text $ "Expected ObjectArray, but got " <> show o+ fromObject o = throwError $ "Expected ObjectArray, but got" <+> viaShow o instance (NvimObject o1, NvimObject o2, NvimObject o3, NvimObject o4, NvimObject o5) => NvimObject (o1, o2, o3, o4, o5) where@@ -364,7 +386,7 @@ <*> fromObject o3 <*> fromObject o4 <*> fromObject o5- fromObject o = throwError . text $ "Expected ObjectArray, but got " <> show o+ fromObject o = throwError $ "Expected ObjectArray, but got" <+> viaShow o instance (NvimObject o1, NvimObject o2, NvimObject o3, NvimObject o4, NvimObject o5, NvimObject o6) => NvimObject (o1, o2, o3, o4, o5, o6) where@@ -377,7 +399,7 @@ <*> fromObject o4 <*> fromObject o5 <*> fromObject o6- fromObject o = throwError . text $ "Expected ObjectArray, but got " <> show o+ fromObject o = throwError $ "Expected ObjectArray, but got" <+> viaShow o instance (NvimObject o1, NvimObject o2, NvimObject o3, NvimObject o4, NvimObject o5, NvimObject o6, NvimObject o7) => NvimObject (o1, o2, o3, o4, o5, o6, o7) where@@ -391,7 +413,7 @@ <*> fromObject o5 <*> fromObject o6 <*> fromObject o7- fromObject o = throwError . text $ "Expected ObjectArray, but got " <> show o+ fromObject o = throwError $ "Expected ObjectArray, but got" <+> viaShow o instance (NvimObject o1, NvimObject o2, NvimObject o3, NvimObject o4, NvimObject o5, NvimObject o6, NvimObject o7, NvimObject o8) => NvimObject (o1, o2, o3, o4, o5, o6, o7, o8) where@@ -406,7 +428,7 @@ <*> fromObject o6 <*> fromObject o7 <*> fromObject o8- fromObject o = throwError . text $ "Expected ObjectArray, but got " <> show o+ fromObject o = throwError $ "Expected ObjectArray, but got" <+> viaShow o instance (NvimObject o1, NvimObject o2, NvimObject o3, NvimObject o4, NvimObject o5, NvimObject o6, NvimObject o7, NvimObject o8, NvimObject o9) => NvimObject (o1, o2, o3, o4, o5, o6, o7, o8, o9) where@@ -422,7 +444,7 @@ <*> fromObject o7 <*> fromObject o8 <*> fromObject o9- fromObject o = throwError . text $ "Expected ObjectArray, but got " <> show o+ fromObject o = throwError $ "Expected ObjectArray, but got" <+> viaShow o -- 1}}}
library/Neovim/Config.hs view
@@ -23,7 +23,7 @@ -- the fields' documentation for what you possibly want to change. Also, the -- tutorial in the "Neovim" module should get you started. data NeovimConfig = Config- { plugins :: [Neovim (StartupConfig NeovimConfig) () 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'.
library/Neovim/Context.hs view
@@ -14,13 +14,12 @@ newUniqueFunctionName, Neovim,- Neovim', NeovimException(..),+ exceptionToDoc, FunctionMap, FunctionMapEntry, mkFunctionMap, runNeovim,- forkNeovim, err, errOnInvalidResult, restart,@@ -33,6 +32,10 @@ put, modify, + Doc,+ AnsiStyle,+ docToText,+ throwError, module Control.Monad.IO.Class, #if __GLASGOW_HASKELL__ <= 710@@ -43,10 +46,9 @@ import Neovim.Classes import Neovim.Context.Internal (FunctionMap, FunctionMapEntry,- Neovim, Neovim', forkNeovim,- mkFunctionMap,+ Neovim, mkFunctionMap, newUniqueFunctionName, runNeovim)-import Neovim.Exceptions (NeovimException (..))+import Neovim.Exceptions (NeovimException (..), exceptionToDoc) import qualified Neovim.Context.Internal as Internal @@ -61,20 +63,19 @@ import Control.Monad.Reader import Control.Monad.State import Data.MessagePack (Object)-import Text.PrettyPrint.ANSI.Leijen (Pretty (..)) -- | @'throw'@ specialized to a 'Pretty' value.-err :: Pretty err => err -> Neovim r st a-err = throw . ErrorMessage . pretty+err :: Doc AnsiStyle -> Neovim env a+err = throw . ErrorMessage errOnInvalidResult :: (NvimObject o)- => Neovim r st (Either NeovimException Object)- -> Neovim r st o+ => Neovim env (Either NeovimException Object)+ -> Neovim env o errOnInvalidResult a = a >>= \case Left o ->- (err . show) o+ (err . exceptionToDoc) o Right o -> case fromObject o of Left e ->@@ -84,12 +85,13 @@ return x + -- | Initiate a restart of the plugin provider.-restart :: Neovim r st ()+restart :: Neovim env () restart = liftIO . flip putMVar Internal.Restart =<< Internal.asks' Internal.transitionTo -- | Initiate the termination of the plugin provider.-quit :: Neovim r st ()+quit :: Neovim env () quit = liftIO . flip putMVar Internal.Quit =<< Internal.asks' Internal.transitionTo
library/Neovim/Context/Internal.hs view
@@ -4,6 +4,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {- | Module : Neovim.Context.Internal@@ -21,75 +22,75 @@ where import Neovim.Classes-import Neovim.Exceptions (NeovimException (..))+import Neovim.Exceptions (NeovimException (..),+ exceptionToDoc) import Neovim.Plugin.Classes-import Neovim.Plugin.IPC (SomeMessage)+import Neovim.Plugin.IPC (SomeMessage) import Control.Applicative-import Control.Concurrent (ThreadId, forkIO)-import Control.Concurrent (MVar, newEmptyMVar)-import Control.Concurrent.STM-import Control.Exception (ArithException, ArrayException,- ErrorCall, PatternMatchFail)-import Control.Monad.Base-import Control.Monad.Catch+import Control.Exception (ArithException,+ ArrayException,+ ErrorCall,+ PatternMatchFail) import Control.Monad.Except import Control.Monad.Reader-import Control.Monad.State import Control.Monad.Trans.Resource-import qualified Data.ByteString.UTF8 as U (fromString)-import Data.Map (Map)-import qualified Data.Map as Map-import Data.MessagePack (Object)+import qualified Data.ByteString.UTF8 as U (fromString)+import Data.Map (Map)+import qualified Data.Map as Map+import Data.MessagePack (Object) import System.Log.Logger-import Text.PrettyPrint.ANSI.Leijen hiding ((<$>))+import UnliftIO +import Data.Text.Prettyprint.Doc (Doc, Pretty (..),+ viaShow)+import Data.Text.Prettyprint.Doc.Render.Terminal (AnsiStyle)+ 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)-+newtype Neovim env a = Neovim+ { unNeovim :: ResourceT (ReaderT (Config env) IO) a } -instance MonadBase IO (Neovim r st) where- liftBase = liftIO+ deriving (Functor, Applicative, Monad, MonadIO+ , MonadThrow) -- | User facing instance declaration for the reader state.-instance MonadReader r (Neovim r st) where+instance MonadReader env (Neovim env) where ask = Neovim $ asks customConfig local f (Neovim a) = do- r <- Neovim $ ask- s <- get- fmap fst . liftIO $ runReaderT (runStateT (runResourceT a) s)+ r <- Neovim ask+ liftIO $ runReaderT (runResourceT a) (r { customConfig = f (customConfig r)}) +instance MonadResource (Neovim env) where+ liftResourceT m = Neovim $ liftResourceT m+++instance MonadUnliftIO (Neovim env) where+ askUnliftIO = Neovim . withUnliftIO $ \x ->+ return (UnliftIO (unliftIO x . unNeovim))+ -- | Same as 'ask' for the 'InternalConfig'.-ask' :: Neovim r st (Config r st)-ask' = Neovim $ ask+ask' :: Neovim env (Config env)+ask' = Neovim ask -- | Same as 'asks' for the 'InternalConfig'.-asks' :: (Config r st -> a) -> Neovim r st a+asks' :: (Config env -> a) -> Neovim env a asks' = Neovim . asks --- | Convenience alias for @'Neovim' () ()@.-type Neovim' = Neovim () () -exceptionHandlers :: [Handler IO (Either Doc a)]+exceptionHandlers :: [Handler IO (Either (Doc ann) a)] exceptionHandlers = [ Handler $ \(_ :: ArithException) -> ret "ArithException (e.g. division by 0)" , Handler $ \(_ :: ArrayException) -> ret "ArrayException"@@ -98,52 +99,35 @@ , Handler $ \(_ :: SomeException) -> ret "Unhandled exception" ] where- ret = return . Left . pretty+ ret = return . Left -- | Initialize a 'Neovim' context by supplying an 'InternalEnvironment'. runNeovim :: NFData a- => Config r st- -> st- -> Neovim r st a- -> IO (Either Doc (a, st))-runNeovim = runNeovimInternal (\(a,st) -> a `deepseq` return (a, st))+ => Config env+ -> Neovim env a+ -> IO (Either (Doc AnsiStyle) a)+runNeovim = runNeovimInternal (\a -> a `deepseq` return a) -runNeovimInternal :: ((a, st) -> IO (a, st))- -> Config r st- -> st- -> Neovim r st a- -> IO (Either Doc (a, st))-runNeovimInternal f r st (Neovim a) =- (try . runReaderT (runStateT (runResourceT a) st)) r >>= \case+runNeovimInternal :: (a -> IO a)+ -> Config env+ -> Neovim env a+ -> IO (Either (Doc AnsiStyle) a)+runNeovimInternal f r (Neovim a) =+ (try . runReaderT (runResourceT a)) r >>= \case Left e -> case fromException e of Just e' ->- return . Left . pretty $ (e' :: NeovimException)+ return . Left . exceptionToDoc $ (e' :: NeovimException) Nothing -> do liftIO . errorM "Context" $ "Converting Exception to Error message: " ++ show e- (return . Left . text . show) e+ (return . Left . viaShow) e Right res -> (Right <$> f res) `catches` exceptionHandlers --- | 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 :: NFData a => 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 :: Neovim env FunctionName newUniqueFunctionName = do tu <- asks' uniqueCounter -- reverseing the integer string should distribute the first character more@@ -156,19 +140,14 @@ -- | 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)+newtype FunctionType = Stateful (TQueue SomeMessage) -- ^ 'Stateful' functions are handled within a special thread, the 'TQueue' -- is the communication endpoint for the arguments we have to pass. instance Pretty FunctionType where pretty = \case- Stateless _ -> blue $ text "\\os -> Neovim' o"- Stateful _ -> green $ text "\\os -> Neovim r st o"+ Stateful _ -> "\\os -> Neovim env o" -- | Type of the values stored in the function map.@@ -200,7 +179,7 @@ -- -- Note that you most probably do not want to change the fields prefixed with an -- underscore.-data Config r st = Config+data Config env = Config -- Global settings; initialized once { eventQueue :: TQueue SomeMessage -- ^ A queue of messages that the event handler will propagate to@@ -229,11 +208,11 @@ -- it's appropriate targets. -- Local settings; intialized for each stateful component- , pluginSettings :: Maybe (PluginSettings r st)+ , pluginSettings :: Maybe (PluginSettings env) -- ^ In a registered functionality this field contains a function (and -- possibly some context dependent values) to register new functionality. - , customConfig :: r+ , customConfig :: env -- ^ Plugin author supplyable custom configuration. Queried on the -- user-facing side with 'ask' or 'asks'. }@@ -243,30 +222,24 @@ -- config. -- -- Sets the 'pluginSettings' field to 'Nothing'.-retypeConfig :: r -> st -> Config anotherR anotherSt -> Config r st-retypeConfig r _ cfg = cfg { pluginSettings = Nothing, customConfig = r }+retypeConfig :: env -> Config anotherEnv -> Config env+retypeConfig r cfg = cfg { pluginSettings = Nothing, customConfig = r } -- | This GADT is used to share information between stateless and stateful -- plugin threads since they work fundamentally in the same way. They both -- contain a function to register some functionality in the plugin provider -- as well as some values which are specific to the one or the other context.-data PluginSettings r st where- StatelessSettings- :: (FunctionalityDescription- -> ([Object] -> Neovim' Object)- -> Neovim' (Maybe FunctionMapEntry))- -> PluginSettings () ()-+data PluginSettings env where StatefulSettings :: (FunctionalityDescription- -> ([Object] -> Neovim r st Object)+ -> ([Object] -> Neovim env Object) -> TQueue SomeMessage- -> TVar (Map FunctionName ([Object] -> Neovim r st Object))- -> Neovim r st (Maybe FunctionMapEntry))+ -> TVar (Map FunctionName ([Object] -> Neovim env Object))+ -> Neovim env (Maybe FunctionMapEntry)) -> TQueue SomeMessage- -> TVar (Map FunctionName ([Object] -> Neovim r st Object))- -> PluginSettings r st+ -> TVar (Map FunctionName ([Object] -> Neovim env Object))+ -> PluginSettings env -- | Create a new 'InternalConfig' object by providing the minimal amount of@@ -274,7 +247,7 @@ -- -- 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 :: IO (Maybe String) -> IO env -> IO (Config env) newConfig ioProviderName r = Config <$> newTQueueIO <*> newEmptyMVar@@ -293,7 +266,7 @@ | Restart -- ^ Restart the plugin provider. - | Failure Doc+ | Failure (Doc AnsiStyle) -- ^ The plugin provider failed to start or some other error occured. | InitSuccess
library/Neovim/Debug.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-} {- | Module : Neovim.Debug Description : Utilities to debug Neovim and nvim-hs functionality@@ -26,22 +27,26 @@ import Neovim import Neovim.Classes-import Neovim.Context (runNeovim)-import qualified Neovim.Context.Internal as Internal-import Neovim.Log (disableLogger)-import Neovim.Main (CommandLineOptions (..),- runPluginProvider)-import Neovim.RPC.Common (RPCConfig)+import Neovim.Context (runNeovim)+import qualified Neovim.Context.Internal as Internal+import Neovim.Log (disableLogger)+import Neovim.Main (CommandLineOptions (..),+ runPluginProvider)+import Neovim.RPC.Common (RPCConfig) -import Control.Concurrent-import Control.Concurrent.STM import Control.Monad-import qualified Data.Map as Map+import qualified Data.Map as Map import Foreign.Store-import System.IO (stdout)-import Text.PrettyPrint.ANSI.Leijen hiding ((<$>))-import qualified Text.PrettyPrint.ANSI.Leijen as Pretty +import UnliftIO.Async (Async, async,+ cancel)+import UnliftIO.Concurrent (putMVar, takeMVar)+import UnliftIO.STM++import Data.Text.Prettyprint.Doc (nest, softline,+ vcat, vsep)+import Data.Text.Prettyprint.Doc.Render.Terminal (putDoc)+ import Prelude @@ -54,9 +59,9 @@ -- -- 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 Doc (a, st))-debug r st a = disableLogger $ do- runPluginProvider def { env = True } Nothing transitionHandler Nothing+debug :: env -> Internal.Neovim env a -> IO (Either (Doc AnsiStyle) a)+debug env a = disableLogger $ do+ runPluginProvider def { envVar = True } Nothing transitionHandler Nothing where transitionHandler tids cfg = takeMVar (Internal.transitionTo cfg) >>= \case Internal.Failure e ->@@ -65,15 +70,14 @@ Internal.InitSuccess -> do res <- Internal.runNeovimInternal return- (cfg { Internal.customConfig = r, Internal.pluginSettings = Nothing })- st+ (cfg { Internal.customConfig = env, Internal.pluginSettings = Nothing }) a - mapM_ killThread tids+ mapM_ cancel tids return res _ ->- return . Left $ text "Unexpected transition state."+ return . Left $ "Unexpected transition state." -- | Run a 'Neovim'' function.@@ -83,8 +87,8 @@ -- @ -- -- See documentation for 'debug'.-debug' :: Internal.Neovim' a -> IO (Either Doc a)-debug' a = fmap fst <$> debug () () a+debug' :: Internal.Neovim () a -> IO (Either (Doc AnsiStyle) a)+debug' a = debug () a -- | This function is intended to be run _once_ in a ghci session that to@@ -111,11 +115,11 @@ -- develMain :: Maybe NeovimConfig- -> IO (Either Doc ([ThreadId], Internal.Config RPCConfig ()))+ -> IO (Either (Doc AnsiStyle) [Async ()]) develMain mcfg = lookupStore 0 >>= \case Nothing -> do x <- disableLogger $- runPluginProvider def { env = True } mcfg transitionHandler Nothing+ runPluginProvider def { envVar = True } mcfg transitionHandler Nothing void $ newStore x return x @@ -127,10 +131,9 @@ return $ Left e Internal.InitSuccess -> do- transitionHandlerThread <- forkIO $ do- myTid <- myThreadId- void $ transitionHandler (myTid:tids) cfg- return $ Right (transitionHandlerThread:tids, cfg)+ transitionHandlerThread <- async $ do+ void $ transitionHandler (tids) cfg+ return $ Right (transitionHandlerThread:tids) Internal.Quit -> do lookupStore 0 >>= \case@@ -140,23 +143,23 @@ Just x -> deleteStore x - mapM_ killThread tids- return . Left $ text "Quit develMain"+ mapM_ cancel tids+ return . Left $ "Quit develMain" _ ->- return . Left $ text "Unexpected transition state for develMain."+ return . Left $ "Unexpected transition state for develMain." -- | Quit a previously started plugin provider.-quitDevelMain :: Internal.Config r st -> IO ()+quitDevelMain :: Internal.Config env -> IO () quitDevelMain cfg = putMVar (Internal.transitionTo cfg) Internal.Quit -- | Restart the development plugin provider. restartDevelMain- :: Internal.Config RPCConfig ()+ :: Internal.Config RPCConfig -> Maybe NeovimConfig- -> IO (Either Doc ([ThreadId], Internal.Config RPCConfig ()))+ -> IO (Either (Doc AnsiStyle) [Async ()]) restartDevelMain cfg mcfg = do quitDevelMain cfg develMain mcfg@@ -164,23 +167,22 @@ -- | Convenience function to run a stateless 'Neovim' function. runNeovim' :: NFData a- => Internal.Config r st -> Neovim' a -> IO (Either Doc a)+ => Internal.Config env -> Neovim () a -> IO (Either (Doc AnsiStyle) a) runNeovim' cfg =- fmap (fmap fst) . runNeovim (Internal.retypeConfig () () cfg) ()+ runNeovim (Internal.retypeConfig () cfg) -- | Print the global function map to the console.-printGlobalFunctionMap :: Internal.Config r st -> IO ()+printGlobalFunctionMap :: Internal.Config env -> IO () printGlobalFunctionMap cfg = do es <- fmap Map.toList . atomically $ readTMVar (Internal.globalFunctionMap cfg)- let header = text "Printing global function map:"+ let header = "Printing global function map:" funs = map (\(fname, (d, f)) -> nest 3 (pretty fname- </> text "->"- </> pretty d <+> text ":"+ <> softline <> "->"+ <> softline <> pretty d <+> ":" <+> pretty f)) es- displayIO stdout . renderPretty 0.4 80 $- nest 2 (header <$$> vcat funs)- <$$> Pretty.empty+ putDoc $+ nest 2 $ vsep [header, vcat funs, mempty]
library/Neovim/Exceptions.hs view
@@ -1,5 +1,6 @@-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-} {- | Module : Neovim.Exceptions Description : General Exceptions@@ -13,17 +14,19 @@ -} module Neovim.Exceptions ( NeovimException(..)+ , exceptionToDoc ) where -import Control.Exception (Exception)-import Data.MessagePack (Object (..))-import Data.String (IsString (..))-import Data.Typeable (Typeable)-import Text.PrettyPrint.ANSI.Leijen (Doc, Pretty (..))+import Control.Exception (Exception)+import Data.MessagePack (Object (..))+import Data.String (IsString (..))+import Data.Text.Prettyprint.Doc (Doc, (<+>), viaShow)+import Data.Text.Prettyprint.Doc.Render.Terminal (AnsiStyle)+import Data.Typeable (Typeable) -- | Exceptions specific to /nvim-hs/. data NeovimException- = ErrorMessage Doc+ = ErrorMessage (Doc AnsiStyle) -- ^ Simply error message that is passed to neovim. It should currently only -- contain one line of text. | ErrorResult Object@@ -39,7 +42,11 @@ fromString = ErrorMessage . fromString -instance Pretty NeovimException where- pretty = \case- ErrorMessage s -> s- ErrorResult e -> pretty $ show e+exceptionToDoc :: NeovimException -> Doc AnsiStyle+exceptionToDoc = \case+ ErrorMessage e ->+ "Error message:" <+> e++ ErrorResult o ->+ "Result representing an error:" <+> viaShow o+
library/Neovim/Main.hs view
@@ -33,6 +33,7 @@ import Options.Applicative import System.IO (stdin, stdout) import System.SetEnv+import UnliftIO.Async (Async, async, cancel) import Prelude import System.Environment@@ -46,7 +47,7 @@ Opt { providerName :: Maybe String , hostPort :: Maybe (String, Int) , unix :: Maybe FilePath- , env :: Bool+ , envVar :: Bool , logOpts :: Maybe (FilePath, Priority) } @@ -56,7 +57,7 @@ { providerName = Nothing , hostPort = Nothing , unix = Nothing- , env = False+ , envVar = False , logOpts = Nothing } @@ -133,7 +134,7 @@ -- 'Internal.Config' with the custom field set to 'RPCConfig'. These information -- can be used to properly clean up a session and then do something else. -- The transition handler is first called after the plugin provider has started.-type TransitionHandler a = [ThreadId] -> Internal.Config RPCConfig () -> IO a+type TransitionHandler a = [Async ()] -> Internal.Config RPCConfig -> IO a -- | This main functions can be used to create a custom executable without@@ -164,7 +165,7 @@ (_, Just fp) -> createHandle (UnixSocket fp) >>= \s -> run s s - _ | env os ->+ _ | envVar os -> createHandle Environment >>= \s -> run s s _ ->@@ -179,11 +180,11 @@ conf <- Internal.newConfig (pure (providerName os)) newRPCConfig - ehTid <- forkIO $ runEventHandler+ ehTid <- async $ runEventHandler evHandlerHandle conf { Internal.pluginSettings = Nothing } - srTid <- forkIO $ runSocketReader sockreaderHandle conf+ srTid <- async $ runSocketReader sockreaderHandle conf ghcEnv <- forM ["GHC_PACKAGE_PATH","CABAL_SANDBOX_CONFIG"] $ \var -> do val <- lookupEnv var@@ -191,11 +192,10 @@ return (var, val) let startupConf = Internal.retypeConfig (StartupConfig mDyreParams ghcEnv)- () conf startPluginThreads startupConf allPlugins >>= \case Left e -> do- errorM logger $ "Error initializing plugins: " <> oneLineErrorMessage e+ errorM logger $ "Error initializing plugins: " <> show (oneLineErrorMessage e) putMVar (Internal.transitionTo conf) $ Internal.Failure e transitionHandler [ehTid, srTid] conf @@ -217,11 +217,11 @@ Internal.Restart -> do debugM logger "Trying to restart nvim-hs"- mapM_ killThread threads+ mapM_ cancel threads Dyre.relaunchMaster Nothing Internal.Failure e ->- errorM logger $ oneLineErrorMessage e+ errorM logger . show $ oneLineErrorMessage e Internal.Quit -> return ()
library/Neovim/Plugin.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {- |@@ -24,17 +25,16 @@ CommandOption(..), addAutocmd,- addAutocmd', - registerInStatelessContext,- registerInStatefulContext,+ registerPlugin, ) where import Neovim.API.String import Neovim.Classes import Neovim.Config import Neovim.Context-import Neovim.Context.Internal (FunctionType (..), runNeovimInternal)+import Neovim.Context.Internal (FunctionType (..),+ runNeovimInternal) import qualified Neovim.Context.Internal as Internal import Neovim.Plugin.Classes hiding (register) import Neovim.Plugin.Internal@@ -43,10 +43,7 @@ import Neovim.RPC.FunctionCall import Control.Applicative-import Control.Concurrent (ThreadId, forkIO)-import Control.Concurrent.STM import Control.Monad (foldM, void)-import Control.Monad.Catch (SomeException, try) import Control.Monad.Trans.Resource hiding (register) import Data.ByteString (ByteString) import Data.ByteString.UTF8 (toString)@@ -57,7 +54,10 @@ import Data.MessagePack import Data.Traversable (forM) import System.Log.Logger-import Text.PrettyPrint.ANSI.Leijen (Doc)+import UnliftIO.Async (Async, async, race)+import UnliftIO.Concurrent (threadDelay)+import UnliftIO.Exception (SomeException, try)+import UnliftIO.STM import Prelude @@ -69,36 +69,26 @@ type StartupConfig = Plugin.StartupConfig NeovimConfig -startPluginThreads :: Internal.Config StartupConfig ()- -> [Neovim StartupConfig () NeovimPlugin]- -> IO (Either Doc ([FunctionMapEntry],[ThreadId]))-startPluginThreads cfg = fmap (fmap fst)- . runNeovimInternal return cfg ()- . foldM go ([], [])+startPluginThreads :: Internal.Config StartupConfig+ -> [Neovim StartupConfig NeovimPlugin]+ -> IO (Either (Doc AnsiStyle) ([FunctionMapEntry],[Async ()]))+startPluginThreads cfg = runNeovimInternal return cfg . foldM go ([], []) where- go :: ([FunctionMapEntry], [ThreadId])- -> Neovim StartupConfig () NeovimPlugin- -> Neovim StartupConfig () ([FunctionMapEntry], [ThreadId])- go acc iop = do+ go :: ([FunctionMapEntry], [Async ()])+ -> Neovim StartupConfig NeovimPlugin+ -> Neovim StartupConfig ([FunctionMapEntry], [Async ()])+ go (es, tids) iop = do NeovimPlugin p <- iop-- (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)+ (es', tid) <- registerStatefulFunctionality p - return $ (catMaybes es' ++ es, tids)+ return $ (es ++ es', tid: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 :: FunctionalityDescription -> Neovim anyEnv Bool registerWithNeovim = \case Function (F functionName) s -> do pName <- getProviderName@@ -165,7 +155,7 @@ -- | 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 :: Neovim env (Either String Int) getProviderName = do mp <- Internal.asks' Internal.providerName (liftIO . atomically . tryReadTMVar) mp >>= \case@@ -176,9 +166,10 @@ api <- nvim_get_api_info case api of Right (i:_) -> do- case fromObject i :: Either Doc Int of+ case fromObject i :: Either (Doc AnsiStyle) Int of Left _ ->- err "Expected an integral value as the first argument of nvim_get_api_info"+ err $ "Expected an integral value as the first"+ <+> "argument of nvim_get_api_info" Right channelId -> do liftIO . atomically . putTMVar mp . Right $ fromIntegral channelId return . Right $ fromIntegral channelId@@ -188,25 +179,18 @@ registerFunctionality :: FunctionalityDescription- -> ([Object] -> Neovim r st Object)- -> Neovim r st (Maybe (FunctionMapEntry, Either (Neovim anyR anySt ()) ReleaseKey))+ -> ([Object] -> Neovim env Object)+ -> Neovim env (Maybe (FunctionMapEntry, Either (Neovim anyEnv ()) 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'+ cfg <- Internal.retypeConfig () <$> Internal.ask' rk <- fst <$> allocate (return ()) (free cfg (fst e)) return $ Just (e, Right rk) @@ -228,26 +212,10 @@ liftIO $ warningM logger "Free not implemented for functions." - free cfg = const . void . liftIO . runNeovimInternal return 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+ free cfg = const . void . liftIO . runNeovimInternal return cfg . freeFun -registerInGlobalFunctionMap :: FunctionMapEntry -> Neovim r st ()+registerInGlobalFunctionMap :: FunctionMapEntry -> Neovim env () registerInGlobalFunctionMap e = do liftIO . debugM logger $ "Adding function to global function map." ++ show (fst e) funMap <- Internal.asks' Internal.globalFunctionMap@@ -256,14 +224,14 @@ 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 ())+registerPlugin+ :: (FunctionMapEntry -> Neovim env ()) -> FunctionalityDescription- -> ([Object] -> Neovim r st Object)+ -> ([Object] -> Neovim env 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+ -> TVar (Map FunctionName ([Object] -> Neovim env Object))+ -> Neovim env (Maybe FunctionMapEntry)+registerPlugin reg d f q tm = registerWithNeovim d >>= \case True -> do let n = name d e = (d, Stateful q)@@ -277,104 +245,99 @@ -- | 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.+-- thread and has access to the configuration and state of this thread. . -- -- 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 ())+ -> (Neovim env ()) -- ^ Fully applied function to register- -> Neovim r st (Maybe (Either (Neovim anyR anySt ()) ReleaseKey))+ -> Neovim env (Maybe (Either (Neovim anyEnv ()) 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- :: StatefulFunctionality r st- -> Neovim anyconfig anyState ([FunctionMapEntry], ThreadId)-registerStatefulFunctionality (StatefulFunctionality r st fs) = do- q <- liftIO newTQueueIO+ :: Plugin env+ -> Neovim anyEnv ([FunctionMapEntry], Async ())+registerStatefulFunctionality (Plugin { environment = env, exports = fs }) = do+ messageQueue <- liftIO newTQueueIO route <- liftIO $ newTVarIO Map.empty cfg <- Internal.ask' let startupConfig = cfg- { Internal.customConfig = r+ { Internal.customConfig = env , Internal.pluginSettings = Just $ Internal.StatefulSettings- (registerInStatefulContext (\_ -> return ())) q route+ (registerPlugin (\_ -> return ())) messageQueue route }- res <- liftIO . runNeovimInternal return startupConfig st . forM fs $ \f ->+ res <- liftIO . runNeovimInternal return startupConfig . forM fs $ \f -> registerFunctionality (getDescription f) (getFunction f) es <- case res of- Left e -> err e- Right (a,_) -> return $ catMaybes a+ Left e -> err e+ Right a -> return $ catMaybes a let pluginThreadConfig = cfg- { Internal.customConfig = r+ { Internal.customConfig = env , Internal.pluginSettings = Just $ Internal.StatefulSettings- (registerInStatefulContext registerInGlobalFunctionMap) q route+ (registerPlugin registerInGlobalFunctionMap) messageQueue route } - tid <- liftIO . forkIO . void . runNeovimInternal return pluginThreadConfig st $ do- listeningThread q route+ tid <- liftIO . async . void . runNeovim pluginThreadConfig $ do+ listeningThread messageQueue route return (map fst es, tid) -- NB: dropping release functions/keys here where executeFunction- :: ([Object] -> Neovim r st Object)+ :: ([Object] -> Neovim env Object) -> [Object]- -> Neovim r st (Either String Object)+ -> Neovim env (Either String Object) executeFunction f args = try (f args) >>= \case Left e -> return . Left $ show (e :: SomeException) Right res -> return $ Right res + timeoutAndLog :: Word -> FunctionName -> Neovim anyEnv String+ timeoutAndLog seconds functionName = do+ threadDelay (fromIntegral seconds * 1000 * 1000)+ return . show $+ pretty functionName <+> "has been aborted after"+ <+> pretty seconds <+> "seconds"++ listeningThread :: TQueue SomeMessage- -> TVar (Map FunctionName ([Object] -> Neovim r st Object))- -> Neovim r st ()+ -> TVar (Map FunctionName ([Object] -> Neovim env Object))+ -> Neovim env () listeningThread q route = do msg <- liftIO . atomically $ readTQueue q forM_ (fromMessage msg) $ \req@Request{..} -> do route' <- liftIO $ readTVarIO route- forM_ (Map.lookup reqMethod route') $ \f ->- respond req =<< executeFunction f reqArgs+ forM_ (Map.lookup reqMethod route') $ \f -> do+ respond req . either Left id =<< race+ (timeoutAndLog 10 reqMethod)+ (executeFunction f reqArgs) forM_ (fromMessage msg) $ \Notification{..} -> do route' <- liftIO $ readTVarIO route forM_ (Map.lookup notMethod route') $ \f ->- void $ executeFunction f notArgs+ void . async $ do+ result <- either Left id <$> race+ (timeoutAndLog 600 notMethod)+ (executeFunction f notArgs)+ case result of+ Left message ->+ nvim_err_writeln' message+ Right _ ->+ return ()+ listeningThread q route
library/Neovim/Plugin/Classes.hs view
@@ -32,7 +32,6 @@ import Control.Applicative hiding (empty) import Control.Monad.Error.Class import Data.ByteString (ByteString)-import Data.ByteString.UTF8 (toString) import Data.Char (isDigit) import Data.Default import Data.List (groupBy, sort)@@ -41,8 +40,10 @@ import Data.MessagePack import Data.String import Data.Traversable (sequence)-import Text.PrettyPrint.ANSI.Leijen hiding ((<$>))+import Data.Text.Encoding (decodeUtf8) +import Data.Text.Prettyprint.Doc+ import Prelude hiding (sequence) @@ -55,7 +56,7 @@ instance Pretty FunctionName where- pretty (F n) = blue . text $ toString n+ pretty (F n) = pretty $ decodeUtf8 n -- | Functionality specific functional description entries.@@ -97,13 +98,13 @@ instance Pretty FunctionalityDescription where pretty = \case Function fname s ->- text "Function" <+> pretty s <+> pretty fname+ "Function" <+> pretty s <+> pretty fname Command fname copts ->- text "Command" <+> pretty copts <+> pretty fname+ "Command" <+> pretty copts <+> pretty fname Autocmd t fname aopts ->- text "Autocmd" <+> (text . toString) t+ "Autocmd" <+> pretty (decodeUtf8 t) <+> pretty aopts <+> pretty fname @@ -128,8 +129,8 @@ instance Pretty Synchronous where pretty = \case- Async -> red $ text "async"- Sync -> blue $ text "sync"+ Async -> "async"+ Sync -> "sync" instance IsString Synchronous where@@ -200,19 +201,19 @@ pretty s CmdRegister ->- text "\""+ "\"" CmdNargs n ->- text n+ pretty n CmdRange rs -> pretty rs CmdCount c ->- text (show c)+ pretty c CmdBang ->- text "!"+ "!" instance IsString CommandOption where@@ -273,8 +274,8 @@ CmdNargs n -> Just ("nargs" , toObject n) _ -> Nothing - fromObject o = throwError . text $- "Did not expect to receive a CommandOptions object: " ++ show o+ fromObject o = throwError $+ "Did not expect to receive a CommandOptions object:" <+> viaShow o -- | Specification of a range that acommand can operate on.@@ -295,13 +296,13 @@ instance Pretty RangeSpecification where pretty = \case CurrentLine ->- empty+ mempty WholeFile ->- text "%"+ "%" RangeCount c ->- text $ show c+ pretty c instance NvimObject RangeSpecification where@@ -344,12 +345,12 @@ instance Pretty CommandArguments where pretty CommandArguments{..} = cat $ catMaybes- [ (\b -> if b then (text "!") else empty) <$> bang- , (\(s,e) -> lparen <> (text . show) s <> comma- <+> (text . show) e <> rparen)+ [ (\b -> if b then "!" else mempty) <$> bang+ , (\(s,e) -> lparen <> pretty s <> comma+ <+> pretty e <> rparen) <$> range- , (text . show) <$> count- , (text . show) <$> register+ , pretty <$> count+ , pretty <$> register ] instance Default CommandArguments where@@ -382,7 +383,8 @@ fromObject ObjectNil = return def fromObject o =- throwError . text $ "Expected a map for CommandArguments object, but got: " ++ show o+ throwError $ "Expected a map for CommandArguments object, but got: "+ <+> viaShow o -- | Options that can be used to register an autocmd. See @:h :autocmd@ or any@@ -407,9 +409,9 @@ instance Pretty AutocmdOptions where pretty AutocmdOptions{..} =- text acmdPattern- <+> text (if acmdNested then "nested" else "unnested")- <> maybe empty (\g -> empty <+> text g) acmdGroup+ pretty acmdPattern+ <+> if acmdNested then "nested" else "unnested"+ <> maybe mempty (\g -> mempty <+> pretty g) acmdGroup instance Default AutocmdOptions where@@ -428,8 +430,8 @@ ] ++ catMaybes [ acmdGroup >>= \g -> return ("group", toObject g) ]- fromObject o = throwError . text $- "Did not expect to receive an AutocmdOptions object: " ++ show o+ fromObject o = throwError $+ "Did not expect to receive an AutocmdOptions object: " <+> viaShow o -- | Conveniennce class to extract a name from some value. class HasFunctionName a where
library/Neovim/Plugin/ConfigHelper.hs view
@@ -25,33 +25,28 @@ import Config.Dyre.Paths (getPaths) import Data.Default+import UnliftIO.STM -plugin :: Neovim (StartupConfig NeovimConfig) () NeovimPlugin+plugin :: Neovim (StartupConfig NeovimConfig) NeovimPlugin plugin = asks dyreParams >>= \case Nothing ->- wrapPlugin Plugin { exports = [], statefulExports = [] }+ wrapPlugin Plugin { environment = (), exports = [] } Just params -> do ghcEnv <- asks ghcEnvironmentVariables (_, _, cfgFile, _, libsDir) <- liftIO $ getPaths params+ emptyQuickfixList <- newTVarIO [] wrapPlugin Plugin- { exports =+ { environment = ConfigHelperEnv params ghcEnv emptyQuickfixList+ , exports = [ $(function' 'pingNvimhs) Sync- ]- , statefulExports =- [ StatefulFunctionality- { readOnly = (params, ghcEnv)- , writable = []- , functionalities =- [ $(autocmd 'recompileNvimhs) "BufWritePost" def- { acmdPattern = cfgFile- }- , $(autocmd 'recompileNvimhs) "BufWritePost" def- { acmdPattern = libsDir++"/*"- }- , $(command' 'restartNvimhs) [CmdSync Async, CmdBang, CmdRegister]- ]+ , $(autocmd 'recompileNvimhs) "BufWritePost" def+ { acmdPattern = cfgFile }+ , $(autocmd 'recompileNvimhs) "BufWritePost" def+ { acmdPattern = libsDir++"/*"+ }+ , $(command' 'restartNvimhs) [CmdSync Async, CmdBang, CmdRegister] ] }
library/Neovim/Plugin/ConfigHelper/Internal.hs view
@@ -26,29 +26,38 @@ import Config.Dyre (Params) import Config.Dyre.Compile import Config.Dyre.Paths (getPaths)-import Control.Applicative hiding (many, (<|>))+import Control.Applicative hiding ((<|>)) import Control.Monad (void, forM_) import Data.Char import System.SetEnv import System.Directory (removeDirectoryRecursive)+import UnliftIO.STM import Prelude -- | Simple function that will return @"Pong"@ if the plugin provider is -- running.-pingNvimhs :: Neovim' String+pingNvimhs :: Neovim env String pingNvimhs = return "Pong" +data ConfigHelperEnv = ConfigHelperEnv+ { dyreParameters :: Params NeovimConfig+ , environmentVariables :: [(String, Maybe String)]+ , quickfixList :: TVar [QuickfixListItem String]+ } -- | Recompile the plugin provider and put comile errors in the quickfix list.-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- void $ vim_command "cwindow"+recompileNvimhs :: Neovim ConfigHelperEnv ()+recompileNvimhs = ask >>= \ConfigHelperEnv{..} ->+ withCustomEnvironment environmentVariables $ do+ mErrString <- liftIO $ do+ customCompile dyreParameters+ getErrorString dyreParameters+ let qs = maybe [] parseQuickfixItems mErrString+ atomically $ modifyTVar' quickfixList (const qs)+ setqflist qs Replace+ void $ vim_command "cwindow" -- | Note that restarting the plugin provider implies compilation because Dyre@@ -59,11 +68,11 @@ -- If you provide a bang to the command, the cache directory of /nvim-hs/ is -- forcibly removed. restartNvimhs :: CommandArguments- -> Neovim (Params NeovimConfig, [(String, Maybe String)]) [QuickfixListItem String] ()+ -> Neovim ConfigHelperEnv () restartNvimhs CommandArguments{..} = do case bang of Just True -> do- (_,_,_, cacheDir,_) <- liftIO . getPaths =<< asks fst+ (_,_,_, cacheDir,_) <- liftIO . getPaths =<< asks dyreParameters liftIO $ removeDirectoryRecursive cacheDir _ ->@@ -71,9 +80,8 @@ recompileNvimhs - (_, env) <- ask- forM_ env $ \(var, val) -> liftIO $ do- maybe (unsetEnv var) (setEnv var) val+ envVars <- asks environmentVariables+ forM_ envVars $ \(var, val) -> liftIO $ maybe (unsetEnv var) (setEnv var) val restart -- Parsing {{{1@@ -95,7 +103,7 @@ e <- pSeverity desc <- try pShortDesrciption <|> pLongDescription return $ (quickfixListItem (Right f) (Left l))- { col = Just (c, True)+ { col = VisualColumn c , text = desc , errorType = e }
library/Neovim/Plugin/IPC/Classes.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {- | Module : Neovim.Plugin.IPC.Classes@@ -27,17 +28,17 @@ ) where import Neovim.Classes-import Neovim.Plugin.Classes (FunctionName)+import Neovim.Plugin.Classes (FunctionName) import Control.Concurrent.STM-import Data.Data (Typeable, cast)-import Data.Int (Int64)+import Data.Data (Typeable, cast)+import Data.Int (Int64) import Data.MessagePack-import Data.Time (UTCTime, formatTime,- getCurrentTime)-import Data.Time.Locale.Compat (defaultTimeLocale)-import Text.PrettyPrint.ANSI.Leijen hiding ((<$>))+import Data.Time (UTCTime, formatTime, getCurrentTime)+import Data.Time.Locale.Compat (defaultTimeLocale) +import Data.Text.Prettyprint.Doc (Pretty (..), nest, hardline, (<+>), (<>), viaShow)+ import Prelude -- | Taken from xmonad and based on ideas in /An Extensible Dynamically-Typed@@ -73,10 +74,10 @@ instance Pretty FunctionCall where pretty (FunctionCall fname args _ t) =- nest 2 $ text "Function call for:" <+> pretty fname- <$$> text "Arguments:" <+> text (show args)- <$$> text "Timestamp:"- <+> (yellow . text . formatTime defaultTimeLocale "%H:%M:%S (%q)") t+ nest 2 $ "Function call for:" <+> pretty fname+ <> hardline <> "Arguments:" <+> viaShow args+ <> hardline <> "Timestamp:"+ <+> (viaShow . formatTime defaultTimeLocale "%H:%M:%S (%q)") t -- | A request is a data type containing the method to call, its arguments and@@ -99,9 +100,9 @@ instance Pretty Request where pretty Request{..} =- nest 2 $ text "Request" <+> (yellow . text . ('#':) . show) reqId- <$$> (text "Method:" <+> pretty reqMethod)- <$$> (text "Arguments:" <+> text (show reqArgs))+ nest 2 $ "Request" <+> "#" <> pretty reqId+ <> hardline <> "Method:" <+> pretty reqMethod+ <> hardline <> "Arguments:" <+> viaShow reqArgs -- | A notification is similar to a 'Request'. It essentially does the same@@ -124,7 +125,7 @@ instance Pretty Notification where pretty Notification{..} =- nest 2 $ text "Notification"- <$$> (text "Method:" <+> pretty notMethod)- <$$> (text "Arguments:" <+> text (show notArgs))+ nest 2 $ "Notification"+ <> hardline <> "Method:" <+> pretty notMethod+ <> hardline <> "Arguments:" <+> viaShow notArgs
library/Neovim/Plugin/Internal.hs view
@@ -12,7 +12,6 @@ -} module Neovim.Plugin.Internal ( ExportedFunctionality(..),- StatefulFunctionality(..), getFunction, getDescription, NeovimPlugin(..),@@ -28,47 +27,38 @@ -- | 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)+newtype ExportedFunctionality env+ = EF (FunctionalityDescription, [Object] -> Neovim env Object) -- | Extract the description of an 'ExportedFunctionality'.-getDescription :: ExportedFunctionality r st -> FunctionalityDescription+getDescription :: ExportedFunctionality env -> FunctionalityDescription getDescription (EF (d,_)) = d -- | Extract the function of an 'ExportedFunctionality'.-getFunction :: ExportedFunctionality r st -> [Object] -> Neovim r st Object+getFunction :: ExportedFunctionality env -> [Object] -> Neovim env Object getFunction (EF (_, f)) = f -instance HasFunctionName (ExportedFunctionality r st) where+instance HasFunctionName (ExportedFunctionality env) where name = name . getDescription --- | This datatype contains the initial state (mutable and immutable) for the--- functionalities defined here.-data StatefulFunctionality r st = StatefulFunctionality- { readOnly :: r- , writable :: st- , functionalities :: [ExportedFunctionality r st]- }-- -- | This data type contains meta information for the plugin manager. ---data Plugin r st = Plugin- { exports :: [ExportedFunctionality () ()]- , statefulExports :: [StatefulFunctionality r st]+data Plugin env = Plugin+ { environment :: env+ , exports :: [ExportedFunctionality env] } -- | 'Plugin' values are wraped inside this data type via 'wrapPlugin' so that -- we can put plugins in an ordinary list.-data NeovimPlugin = forall r st. NeovimPlugin (Plugin r st)+data NeovimPlugin = forall env. NeovimPlugin (Plugin env) -- | Wrap a 'Plugin' in some nice blankets, so that we can put them in a simple -- list.-wrapPlugin :: Applicative m => Plugin r st -> m NeovimPlugin+wrapPlugin :: Applicative m => Plugin env -> m NeovimPlugin wrapPlugin = pure . NeovimPlugin
library/Neovim/Quickfix.hs view
@@ -26,8 +26,8 @@ import Neovim.API.String import Neovim.Classes import Neovim.Context-import Text.PrettyPrint.ANSI.Leijen (Doc)-import qualified Text.PrettyPrint.ANSI.Leijen as P+import Data.Text.Prettyprint.Doc (Doc, viaShow, (<+>))+import Data.Text.Prettyprint.Doc.Render.Terminal (AnsiStyle) import Prelude @@ -37,10 +37,28 @@ setqflist :: (Monoid strType, NvimObject strType) => [QuickfixListItem strType] -> QuickfixAction- -> Neovim r st ()+ -> Neovim env () setqflist qs a = void $ vim_call_function "setqflist" $ qs +: a +: [] +data ColumnNumber+ = VisualColumn Int+ | ByteIndexColumn Int+ | NoColumn+ deriving (Eq, Ord, Show, Generic)+++instance NFData ColumnNumber++data SignLocation strType+ = LineNumber Int+ | SearchPattern strType+ deriving (Eq, Ord, Show, Generic)+++instance (NFData strType) => NFData (SignLocation strType)++ -- | Quickfix list item. The parameter names should mostly conform to those in -- @:h setqflist()@. Some fields are merged to explicitly state mutually -- exclusive elements or some other behavior of the fields.@@ -55,7 +73,7 @@ , lnumOrPattern :: Either Int strType -- ^ Line number or search pattern to locate the error. - , col :: Maybe (Int, Bool)+ , col :: ColumnNumber -- ^ A tuple of a column number and a boolean indicating which kind of -- indexing should be used. 'True' means that the visual column should be -- used. 'False' means to use the byte index.@@ -87,7 +105,7 @@ Warning -> ObjectBinary "W" Error -> ObjectBinary "E" - fromObject o = case fromObject o :: Either Doc String of+ fromObject o = case fromObject o :: Either (Doc AnsiStyle) String of Right "W" -> return Warning Right "E" -> return Error _ -> return Error@@ -102,7 +120,7 @@ quickfixListItem bufferOrFile lineOrPattern = QFItem { bufOrFile = bufferOrFile , lnumOrPattern = lineOrPattern- , col = Nothing+ , col = NoColumn , nr = Nothing , text = mempty , errorType = Error@@ -121,27 +139,28 @@ lnumOrPattern , ("type", toObject errorType) , ("text", toObject text)- ] ++ catMaybes- [ (\n -> ("nr", toObject n)) <$> nr- , (\(c,_) -> ("col", toObject c)) <$> col- , (\(_,t) -> ("vcol", toObject t)) <$> col+ ] ++ concat+ [ case col of+ NoColumn -> []+ ByteIndexColumn i -> [ ("col", toObject i), ("vcol", toObject False) ]+ VisualColumn i -> [ ("col", toObject i), ("vcol", toObject True) ] ] fromObject objectMap@(ObjectMap _) = do m <- fromObject objectMap- let l :: NvimObject o => ByteString -> Either Doc o+ let l :: NvimObject o => ByteString -> Either (Doc AnsiStyle) o l key = case Map.lookup key m of Just o -> fromObject o- Nothing -> throwError . P.text $ "Key not found."+ Nothing -> throwError $ "Key not found." bufOrFile <- case (l "bufnr", l "filename") of (Right b, _) -> return $ Left b (_, Right f) -> return $ Right f- _ -> throwError . P.text $ "No buffer number or file name inside quickfix list item."+ _ -> throwError $ "No buffer number or file name inside quickfix list item." lnumOrPattern <- case (l "lnum", l "pattern") of (Right lnum, _) -> return $ Left lnum (_, Right pat) -> return $ Right pat- _ -> throwError . P.text $ "No line number or search pattern inside quickfix list item."- let l' :: NvimObject o => ByteString -> Either Doc (Maybe o)+ _ -> throwError $ "No line number or search pattern inside quickfix list item."+ let l' :: NvimObject o => ByteString -> Either (Doc AnsiStyle) (Maybe o) l' key = case Map.lookup key m of Just o -> Just <$> fromObject o Nothing -> return Nothing@@ -150,17 +169,20 @@ nr' -> return nr' c <- l' "col" v <- l' "vcol"- let col = do+ let col = maybe NoColumn id $ do c' <- c v' <- v- case c' of- 0 -> Nothing- _ -> Just (c',v')+ case (c',v') of+ (0, _) -> return $ NoColumn+ (_, True) -> return $ VisualColumn c'+ (_, False) -> return $ ByteIndexColumn c' text <- fromMaybe mempty <$> l' "text" errorType <- fromMaybe Error <$> l' "type" return QFItem{..} - fromObject o = throwError . P.text $ "Could not deserialize QuickfixListItem, expected a map but received: " ++ show o+ fromObject o = throwError $ "Could not deserialize QuickfixListItem,"+ <+> "expected a map but received:"+ <+> viaShow o data QuickfixAction
library/Neovim/RPC/Classes.hs view
@@ -1,7 +1,8 @@ {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE DeriveGeneric #-} {- | Module : Neovim.RPC.Classes Description : Data types and classes for the RPC components@@ -19,16 +20,18 @@ ) where import Neovim.Classes-import Neovim.Plugin.Classes (FunctionName (..))-import qualified Neovim.Plugin.IPC.Classes as IPC+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 Text.PrettyPrint.ANSI.Leijen hiding ((<$>))+import Data.Data (Typeable)+import Data.Int (Int64)+import Data.MessagePack (Object (..)) +import Data.Text.Prettyprint.Doc (Pretty (..), hardline, nest,+ viaShow, (<+>), (<>))+ import Prelude -- | See https://github.com/msgpack-rpc/msgpack-rpc/blob/master/spec.md for@@ -97,7 +100,7 @@ return $ Notification n o ->- throwError . text $ "Not a known/valid msgpack-rpc message" ++ show o+ throwError $ "Not a known/valid msgpack-rpc message:" <+> viaShow o instance Pretty Message where@@ -106,8 +109,8 @@ pretty request Response i ret ->- nest 2 $ text "Response" <+> (yellow . text . ('#':) . show) i- <$$> either (red . text . show) (green . text. show) ret+ nest 2 $ "Response" <+> "#" <> pretty i+ <> hardline <> either viaShow viaShow ret Notification notification -> pretty notification
library/Neovim/RPC/Common.hs view
@@ -41,6 +41,9 @@ -- ^ A map from message identifiers (as per RPC spec) to a tuple with a -- timestamp and a 'TMVar' that is used to communicate the result back to -- the calling thread.++ , nextMessageId :: TVar Int64+ -- ^ Message identifier for the next message as per RPC spec. } -- | Create a new basic configuration containing a communication channel for@@ -49,6 +52,7 @@ newRPCConfig :: (Applicative io, MonadIO io) => io RPCConfig newRPCConfig = RPCConfig <$> liftIO (newTVarIO mempty)+ <*> liftIO (newTVarIO 1) -- | Simple data type defining the kind of socket the socket reader should use. data SocketType = Stdout Handle
library/Neovim/RPC/EventHandler.hs view
@@ -26,15 +26,9 @@ import Control.Applicative import Control.Concurrent.STM hiding (writeTQueue) import Control.Monad.Reader-import Control.Monad.State.Strict import Control.Monad.Trans.Resource import Data.ByteString (ByteString)-import Data.Conduit as C-#if MIN_VERSION_conduit_extra(1,2,2)-import Data.Conduit.Binary (sinkHandleFlush)-#else-import Data.Conduit.Binary (sinkHandle)-#endif+import Conduit as C import qualified Data.Map as Map import Data.Serialize (encode) import System.IO (Handle)@@ -46,35 +40,29 @@ -- | This function will establish a connection to the given socket and write -- msgpack-rpc requests to it. runEventHandler :: Handle- -> Internal.Config RPCConfig Int64+ -> Internal.Config RPCConfig -> IO () runEventHandler writeableHandle env =- runEventHandlerContext env $ do+ runEventHandlerContext env . runConduit $ do eventHandlerSource- $= eventHandler- $$ addCleanup- (cleanUpHandle writeableHandle)-#if MIN_VERSION_conduit_extra(1,2,2)- (sinkHandleFlush writeableHandle)-#else- (sinkHandle writeableHandle)-#endif+ .| eventHandler+ .| (sinkHandleFlush writeableHandle) -- | Convenient monad transformer stack for the event handler newtype EventHandler a =- EventHandler (ResourceT (ReaderT (Internal.Config RPCConfig Int64) (StateT Int64 IO)) a)- deriving ( Functor, Applicative, Monad, MonadState Int64, MonadIO- , MonadReader (Internal.Config RPCConfig Int64))+ EventHandler (ResourceT (ReaderT (Internal.Config RPCConfig) IO) a)+ deriving ( Functor, Applicative, Monad, MonadIO+ , MonadReader (Internal.Config RPCConfig)) runEventHandlerContext- :: Internal.Config RPCConfig Int64 -> EventHandler a -> IO a+ :: Internal.Config RPCConfig -> EventHandler a -> IO a runEventHandlerContext env (EventHandler a) =- evalStateT (runReaderT (runResourceT a) env) 1+ runReaderT (runResourceT a) env -eventHandlerSource :: Source EventHandler SomeMessage+eventHandlerSource :: ConduitT () SomeMessage EventHandler () eventHandlerSource = asks Internal.eventQueue >>= \q -> forever $ yield =<< atomically' (readTQueue q) @@ -89,37 +77,31 @@ eventHandler -#if MIN_VERSION_conduit_extra(1,2,2)-type EncodedResponse = Flush ByteString-#else-type EncodedResponse = ByteString-#endif+type EncodedResponse = C.Flush ByteString yield' :: (MonadIO io) => MsgpackRPC.Message -> ConduitM i EncodedResponse io () yield' o = do liftIO . debugM "EventHandler" $ "Sending: " ++ show o-#if MIN_VERSION_conduit_extra(1,2,2) yield . Chunk . encode $ toObject o yield Flush-#else- yield . encode $ toObject o-#endif handleMessage :: (Maybe FunctionCall, Maybe MsgpackRPC.Message) -> ConduitM i EncodedResponse EventHandler () handleMessage = \case (Just (FunctionCall fn params reply time), _) -> do- i <- get- modify succ- rs <- asks (recipients . Internal.customConfig)- atomically' . modifyTVar rs $ Map.insert i (time, reply)- yield' $ MsgpackRPC.Request (Request fn i params)+ cfg <- asks (Internal.customConfig)+ messageId <- atomically' $ do+ i <- readTVar (nextMessageId cfg)+ modifyTVar' (nextMessageId cfg) succ+ modifyTVar' (recipients cfg) $ Map.insert i (time, reply)+ return i+ yield' $ MsgpackRPC.Request (Request fn messageId params) (_, Just r@MsgpackRPC.Response{}) ->- yield' $ r+ yield' r (_, Just n@MsgpackRPC.Notification{}) ->- yield' $ n+ yield' n _ -> return () -- i.e. skip to next message
library/Neovim/RPC/FunctionCall.hs view
@@ -30,15 +30,13 @@ import Neovim.Plugin.Classes (FunctionName) import Neovim.Plugin.IPC.Classes import qualified Neovim.RPC.Classes as MsgpackRPC-import Neovim.Exceptions (NeovimException(..))+import Neovim.Exceptions (NeovimException(..), exceptionToDoc) import Control.Applicative import Control.Concurrent.STM-import Control.Exception.Lifted (throwIO) import Control.Monad.Reader import Data.MessagePack-import Data.Monoid-import qualified Text.PrettyPrint.ANSI.Leijen as P+import UnliftIO.Exception (throwIO) import Prelude @@ -49,7 +47,7 @@ unexpectedException :: String -> err -> a unexpectedException fn _ = error $ "Function threw an exception even though it was declared not to throw one: "- <> fn+ ++ fn -- | Strip the error result from the function call. This should only be used by@@ -66,7 +64,7 @@ acall :: (NvimObject result) => FunctionName -> [Object]- -> Neovim r st (STM (Either NeovimException result))+ -> Neovim env (STM (Either NeovimException result)) acall fn parameters = do q <- Internal.asks' Internal.eventQueue mv <- liftIO newEmptyTMVarIO@@ -87,7 +85,7 @@ acall' :: (NvimObject result) => FunctionName -> [Object]- -> Neovim r st (STM result)+ -> Neovim env (STM result) acall' fn parameters = withIgnoredException fn <$> acall fn parameters @@ -96,7 +94,7 @@ scall :: (NvimObject result) => FunctionName -> [Object] -- ^ Parameters in an 'Object' array- -> Neovim r st (Either NeovimException result)+ -> Neovim env (Either NeovimException result) -- ^ result value of the call or the thrown exception scall fn parameters = acall fn parameters >>= atomically' @@ -104,13 +102,13 @@ scallThrow :: (NvimObject result) => FunctionName -> [Object]- -> Neovim r st result+ -> Neovim env result scallThrow fn parameters = scall fn parameters >>= either throwIO return -- | Helper function similar to 'scall' that throws a runtime exception if the -- result is an error object.-scall' :: NvimObject result => FunctionName -> [Object] -> Neovim r st result+scall' :: NvimObject result => FunctionName -> [Object] -> Neovim env result scall' fn = withIgnoredException fn . scall fn @@ -123,34 +121,36 @@ -- -- This action possibly blocks as it is an alias for -- @ \ioSTM -> ioSTM >>= liftIO . atomically@.-wait :: Neovim r st (STM result) -> Neovim r st result+wait :: Neovim env (STM result) -> Neovim env result wait = (=<<) atomically' -- | Variant of 'wait' that discards the result.-wait' :: Neovim r st (STM result) -> Neovim r st ()+wait' :: Neovim env (STM result) -> Neovim env () wait' = void . wait -- | Wait for the result of the 'STM' action and call @'err' . (loc++) . show@ -- if the action returned an error.-waitErr :: (P.Pretty e)- => String -- ^ Prefix error message with this.- -> Neovim r st (STM (Either e result)) -- ^ Function call to neovim- -> Neovim r st result-waitErr loc act = wait act >>= either (err . (P.<>) (P.text loc) . P.pretty) return+waitErr :: String -- ^ Prefix error message with this.+ -> Neovim env (STM (Either NeovimException result)) -- ^ Function call to neovim+ -> Neovim env result+waitErr loc act = wait act >>= \case+ Left e ->+ err $ pretty loc <+> exceptionToDoc e+ Right result ->+ return result -- | 'waitErr' that discards the result.-waitErr' :: (P.Pretty e)- => String- -> Neovim r st (STM (Either e result))- -> Neovim r st ()+waitErr' :: String+ -> Neovim env (STM (Either NeovimException result))+ -> Neovim env () waitErr' loc = void . waitErr loc -- | Send the result back to the neovim instance.-respond :: (NvimObject result) => Request -> Either String result -> Neovim r st ()+respond :: (NvimObject result) => Request -> Either String result -> Neovim env () respond Request{..} result = do q <- Internal.asks' Internal.eventQueue atomically' . writeTQueue q . SomeMessage . MsgpackRPC.Response reqId $
library/Neovim/RPC/SocketReader.hs view
@@ -26,19 +26,16 @@ 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.STM import Control.Monad (void) import Control.Monad.Trans.Class (lift)-import Data.Conduit as C-import Data.Conduit.Binary-import Data.Conduit.Cereal+import Conduit as C+import Data.Conduit.Cereal (conduitGet2) import Data.Default (def) import Data.Foldable (foldl', forM_) import qualified Data.Map as Map@@ -47,7 +44,8 @@ import qualified Data.Serialize (get) import System.IO (Handle) import System.Log.Logger-import Text.PrettyPrint.ANSI.Leijen (renderCompact, displayS)+import UnliftIO.Async (async, race)+import UnliftIO.Concurrent (threadDelay) import Prelude @@ -55,30 +53,24 @@ logger = "Socket Reader" -type SocketHandler = Neovim RPCConfig ()+type SocketHandler = Neovim RPCConfig -- | This function will establish a connection to the given socket and read -- msgpack-rpc events from it. runSocketReader :: Handle- -> Internal.Config RPCConfig st+ -> Internal.Config RPCConfig -> 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).+ void . runNeovim (Internal.retypeConfig (Internal.customConfig cfg) cfg) . runConduit $ do sourceHandle readableHandle- $= conduitGet2 Data.Serialize.get- $$ messageHandlerSink+ .| conduitGet2 Data.Serialize.get+ .| messageHandlerSink -- | Sink that delegates the messages depending on their type. -- <https://github.com/msgpack-rpc/msgpack-rpc/blob/master/spec.md>-messageHandlerSink :: Sink Object SocketHandler ()+messageHandlerSink :: ConduitT Object Void SocketHandler () messageHandlerSink = awaitForever $ \rpc -> do liftIO . debugM logger $ "Received: " <> show rpc case fromObject rpc of@@ -95,7 +87,8 @@ "Unhandled rpc message: " <> show e -handleResponse :: Int64 -> Either Object Object -> Sink a SocketHandler ()+handleResponse :: Int64 -> Either Object Object+ -> ConduitT a Void SocketHandler () handleResponse i result = do answerMap <- asks recipients mReply <- Map.lookup i <$> liftIO (readTVarIO answerMap)@@ -106,57 +99,53 @@ atomically' . modifyTVar' answerMap $ Map.delete i 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 -> FunctionName -> [Object] -> Sink a SocketHandler ()-handleRequestOrNotification mi m params = do+handleRequestOrNotification :: Maybe Int64 -> FunctionName -> [Object]+ -> ConduitT a Void SocketHandler ()+handleRequestOrNotification requestId functionToCall params = do cfg <- lift Internal.ask'- void . liftIO . forkIO $ handle cfg+ void . liftIO . async $ race logTimeout (handle cfg)+ return () where lookupFunction :: TMVar Internal.FunctionMap -> STM (Maybe (FunctionalityDescription, Internal.FunctionType))- lookupFunction funMap = Map.lookup m <$> readTMVar funMap+ lookupFunction funMap = Map.lookup functionToCall <$> readTMVar funMap - handle :: Internal.Config RPCConfig () -> IO ()+ logTimeout :: IO ()+ logTimeout = do+ let seconds = 1000 * 1000+ threadDelay (10 * seconds)+ debugM logger $ "Cancelled another action before it was finished"++ handle :: Internal.Config RPCConfig -> IO () handle rpc = atomically (lookupFunction (Internal.globalFunctionMap rpc)) >>= \case Nothing -> do- let errM = "No provider for: " <> show m+ let errM = "No provider for: " <> show functionToCall debugM logger errM- forM_ mi $ \i -> atomically' . writeTQueue (Internal.eventQueue rpc)+ forM_ requestId $ \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 <$>)- 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 (Internal.eventQueue rpc)- . SomeMessage . MsgpackRPC.Response i $ either (Left . toObject . flip displayS "" . renderCompact) Right res+ Just (copts, Internal.Stateful c) -> do now <- liftIO getCurrentTime reply <- liftIO newEmptyTMVarIO let q = (recipients . Internal.customConfig) rpc- liftIO . debugM logger $ "Executing stateful function with ID: " <> show mi- case mi of+ liftIO . debugM logger $ "Executing stateful function with ID: " <> show requestId+ case requestId of Just i -> do atomically' . modifyTVar q $ Map.insert i (now, reply) atomically' . writeTQueue c . SomeMessage $- Request m i (parseParams copts params)+ Request functionToCall i (parseParams copts params) Nothing -> atomically' . writeTQueue c . SomeMessage $- Notification m (parseParams copts params)+ Notification functionToCall (parseParams copts params) parseParams :: FunctionalityDescription -> [Object] -> [Object]
library/Neovim/Test.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-} {- | Module : Neovim.Test Description : Testing functions@@ -16,23 +17,27 @@ ) 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 qualified Neovim.Context.Internal as Internal+import Neovim.RPC.Common (RPCConfig,+ newRPCConfig)+import Neovim.RPC.EventHandler (runEventHandler)+import Neovim.RPC.SocketReader (runSocketReader) -import Control.Concurrent-import Control.Concurrent.STM (atomically, putTMVar)-import Control.Exception.Lifted-import Control.Monad.Reader (runReaderT)-import Control.Monad.State (runStateT)-import Control.Monad.Trans.Resource (runResourceT)-import GHC.IO.Exception (ioe_filename)+import Control.Monad.Reader (runReaderT)+import Control.Monad.Trans.Resource (runResourceT)+import Data.Text.Prettyprint.Doc (annotate, vsep)+import Data.Text.Prettyprint.Doc.Render.Terminal (Color (..), color,+ putDoc)+import GHC.IO.Exception (ioe_filename) import System.Directory-import System.Exit (ExitCode (..))-import System.IO (Handle)+import System.Exit (ExitCode (..))+import System.IO (Handle) import System.Process-import Text.PrettyPrint.ANSI.Leijen (red, text, putDoc, (<$$>))+import UnliftIO.Async (async, cancel)+import UnliftIO.Concurrent (threadDelay)+import UnliftIO.Exception+import UnliftIO.STM (atomically,+ putTMVar) -- | Type synonym for 'Word'.@@ -49,25 +54,24 @@ 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+ -> env -- ^ Read-only configuration+ -> Neovim env a -- ^ Test case -> IO ()-testWithEmbeddedNeovim file timeout r st (Internal.Neovim a) =+testWithEmbeddedNeovim file timeout r (Internal.Neovim a) = runTest `catch` catchIfNvimIsNotOnPath where runTest = do- (_, _, ph, cfg) <- startEmbeddedNvim file timeout+ (_, _, ph, cfg, cleanUp) <- startEmbeddedNvim file timeout - let testCfg = Internal.retypeConfig r st cfg+ let testCfg = Internal.retypeConfig r cfg - void $ runReaderT (runStateT (runResourceT a) st) testCfg+ void $ runReaderT (runResourceT a) 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+ testRunner <- async . void $ runReaderT (runResourceT q) testCfg waitForProcess ph >>= \case ExitFailure i ->@@ -75,21 +79,25 @@ ExitSuccess -> return ()+ cancel testRunner+ cleanUp catchIfNvimIsNotOnPath :: IOException -> IO () catchIfNvimIsNotOnPath e = case ioe_filename e of Just "nvim" ->- putDoc . red $ text "The neovim executable 'nvim' is not on the PATH."- <$$> text "You may not be testing fully!"+ putDoc . annotate (color Red) $ vsep+ [ "The neovim executable 'nvim' is not on the PATH."+ , "You may not be testing fully!"+ ] _ ->- throw e+ throwIO e startEmbeddedNvim :: Maybe FilePath -> Seconds- -> IO (Handle, Handle, ProcessHandle, Internal.Config RPCConfig st)+ -> IO (Handle, Handle, ProcessHandle, Internal.Config RPCConfig, IO ()) startEmbeddedNvim file (Seconds timeout) = do args <- case file of Nothing ->@@ -109,11 +117,11 @@ cfg <- Internal.newConfig (pure Nothing) newRPCConfig - void . forkIO $ runSocketReader+ socketReader <- async . void $ runSocketReader hout (cfg { Internal.pluginSettings = Nothing }) - void . forkIO $ runEventHandler+ eventHandler <- async . void $ runEventHandler hin (cfg { Internal.pluginSettings = Nothing }) @@ -121,9 +129,11 @@ (Internal.globalFunctionMap cfg) (Internal.mkFunctionMap []) - void . forkIO $ do+ timeoutAsync <- async . void $ do threadDelay $ (fromIntegral timeout) * 1000 * 1000 getProcessExitCode ph >>= maybe (terminateProcess ph) (\_ -> return ()) - return (hin, hout, ph, cfg)+ let cleanUp = mapM_ cancel [socketReader, eventHandler, timeoutAsync]++ return (hin, hout, ph, cfg, cleanUp)
library/Neovim/Util.hs view
@@ -18,17 +18,21 @@ ) where import Control.Monad (forM, forM_, when, unless)-import Control.Monad.Catch (MonadMask, bracket) import Neovim.Context import System.SetEnv import System.Environment-import qualified Text.PrettyPrint.ANSI.Leijen as P+import qualified Data.Text as T+import UnliftIO (MonadUnliftIO)+import UnliftIO.Exception (bracket) -- | 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+ :: (Traversable t, MonadUnliftIO m)+ => t (String, Maybe String)+ -> m c+ -> m c withCustomEnvironment modifiedEnvironment action = bracket saveAndSet unset (const action) @@ -54,7 +58,7 @@ unlessM mp a = mp >>= \p -> unless p a -oneLineErrorMessage :: P.Doc -> String-oneLineErrorMessage d = case lines $ P.displayS (P.renderCompact d) "" of+oneLineErrorMessage :: Doc AnsiStyle -> T.Text+oneLineErrorMessage d = case T.lines $ docToText d of (x:_) -> x- [] -> ""+ [] -> mempty
nvim-hs.cabal view
@@ -1,5 +1,5 @@ name: nvim-hs-version: 0.2.5+version: 1.0.0.0 synopsis: Haskell plugin backend for neovim description: This package provides a plugin provider for neovim. It allows you to write@@ -30,7 +30,6 @@ category: Editor build-type: Simple cabal-version: >=1.18-tested-with: GHC == 7.10.3, GHC == 8.0.2 extra-source-files: nvim-hs-devel.sh , test-files/compile-error-for-quickfix-test1 , test-files/compile-error-for-quickfix-test2@@ -95,40 +94,28 @@ , Neovim.API.TH other-extensions: DeriveGeneric build-depends: base >=4.6 && < 5- , ansi-wl-pprint , bytestring , cereal- , cereal-conduit >= 0.7.3- , conduit-- -- sinkHandle flushed after every yield in the releases- -- [1.1.2, 1.1.17) and in release 1.2.2 an API was added- -- to flush manually, so any other version probably does- -- not work unless you set NoBuffering on the handle (see #61)- -- I think having NoBuffering on TCP-Handles is kind of- -- ridicilous, so the version range [1.1.17, 1.2.2) is- -- simply excluded- , conduit-extra >= 1.1.2 && < 1.1.17 || >= 1.2.2-+ , cereal-conduit >= 0.8.0+ , conduit >= 1.3.0 , containers , data-default , deepseq >= 1.1 && < 1.5 , directory , dyre- , exceptions , filepath , foreign-store , hslogger , messagepack >= 0.5.4- , monad-control , network- , lifted-base , mtl >= 2.2.1 && < 2.3 , optparse-applicative , time-locale-compat , megaparsec+ , prettyprinter >= 1.2 && < 2+ , prettyprinter-ansi-terminal , process- , resourcet+ , resourcet >= 1.1.11 , setenv >= 0.1.1.3 , stm , streaming-commons@@ -137,6 +124,8 @@ , time , transformers , transformers-base+ , unliftio >= 0.2+ , unliftio-core , utf8-string , void hs-source-dirs: library@@ -156,30 +145,28 @@ , hspec-discover , QuickCheck >=2.6 - , ansi-wl-pprint , bytestring , cereal , cereal-conduit , conduit- , conduit-extra , containers , data-default , directory , dyre- , exceptions , filepath , foreign-store , hslogger- , lifted-base , mtl , messagepack , time-locale-compat , network , optparse-applicative , megaparsec+ , prettyprinter+ , prettyprinter-ansi-terminal , process , resourcet- , setenv >= 0.1.1.3+ , setenv , stm , streaming-commons , text@@ -187,6 +174,8 @@ , time , transformers , transformers-base+ , unliftio+ , unliftio-core , utf8-string , HUnit
test-suite/Neovim/API/THSpec.hs view
@@ -20,14 +20,14 @@ import Control.Applicative -call :: ([Object] -> Neovim () () Object) -> [Object]+call :: ([Object] -> Neovim () Object) -> [Object] -> IO Object call f args = do cfg <- Internal.newConfig (pure Nothing) (pure ())- res <- fmap fst <$> runNeovim cfg () (f args)+ res <- runNeovim cfg (f args) case res of Right x -> return x- Left e -> (throw . ErrorMessage) e+ Left e -> (throwIO . ErrorMessage) e isNeovimException :: NeovimException -> Bool
test-suite/Neovim/API/THSpecFunctions.hs view
@@ -4,19 +4,19 @@ import qualified Data.Map as Map import Neovim -testFunction0 :: Neovim' Int+testFunction0 :: Neovim env Int testFunction0 = return 42 -testFunction2 :: CommandArguments -> String -> [String] -> Neovim' Double+testFunction2 :: CommandArguments -> String -> [String] -> Neovim env Double testFunction2 _ _ _ = return 2 -testFunctionMap :: Map.Map String Int -> String -> Neovim' (Maybe Int)+testFunctionMap :: Map.Map String Int -> String -> Neovim env (Maybe Int) testFunctionMap m k = return $ Map.lookup k m -testSucc :: Int -> Neovim r st Int+testSucc :: Int -> Neovim env Int testSucc = return . succ -testCommandOptArgument :: CommandArguments -> Maybe String -> Neovim' String+testCommandOptArgument :: CommandArguments -> Maybe String -> Neovim env String testCommandOptArgument _ ms = case ms of Just x -> return x Nothing -> return "default"
test-suite/Neovim/EmbeddedRPCSpec.hs view
@@ -18,7 +18,6 @@ import Control.Concurrent.STM import Control.Monad.Reader (runReaderT) import Control.Monad.State (runStateT)-import Control.Monad.Trans.Resource (runResourceT) import qualified Data.Map as Map import System.Directory import System.Exit (ExitCode (..))@@ -29,7 +28,7 @@ spec :: Spec spec = parallel $ do let helloFile = "test-files/hello"- withNeovimEmbedded f a = testWithEmbeddedNeovim f (Seconds 3) () () a+ withNeovimEmbedded f a = testWithEmbeddedNeovim f (Seconds 3) () a describe "Read hello test file" . it "should match 'Hello, World!'" . withNeovimEmbedded (Just helloFile) $ do bs <- vim_get_buffers