diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,12 @@ +# 2.3.1.0 + +* Add `subscribe` and `unsubscribe` function. Neovim doesn't automatically send + event notifications to nvim-hs (or any other remote plugin) and for the + callback of the `subscribe` funtion to trigger, you have to call a specific + function before (e.g. `nvim_buf_attach`). In any case, if you want to subscribe + to a specific event, you have to read the documentation of the neovim + documentation. Some events are still better handled with autocommands. + # 2.3.0.0 * Windows is now rudimentarily supported. Since I couldn't find a library to diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,3 +1,3 @@ -import Distribution.Simple +import Distribution.Simple main = defaultMain diff --git a/library/Neovim.hs b/library/Neovim.hs --- a/library/Neovim.hs +++ b/library/Neovim.hs @@ -54,6 +54,12 @@ ask, asks, + -- ** Subscribing to notifications or events + Subscription, + subscribe, + unsubscribe, + NeovimEventId(..), + -- ** Creating a stateful plugin -- $statefulplugin @@ -106,7 +112,7 @@ NeovimException(..), exceptionToDoc, ask, asks, err, - errOnInvalidResult) + errOnInvalidResult, subscribe, unsubscribe) import Neovim.Main (neovim) import Neovim.Exceptions (catchNeovimException) import Neovim.Plugin (addAutocmd) @@ -114,13 +120,14 @@ CommandArguments (..), CommandOption (CmdBang, CmdCount, CmdRange, CmdRegister, CmdSync), RangeSpecification (..), - Synchronous (..)) + Synchronous (..), + Subscription, NeovimEventId(..)) import Neovim.Plugin.Internal (NeovimPlugin (..), Plugin (..), wrapPlugin) import Neovim.RPC.FunctionCall (wait, wait') import Neovim.Util (unlessM, whenM) import System.Log.Logger (Priority (..)) -import Data.Text.Prettyprint.Doc.Render.Terminal (putDoc) +import Prettyprinter.Render.Terminal (putDoc) -- Installation {{{1 {- $installation diff --git a/library/Neovim/API/ByteString.hs b/library/Neovim/API/ByteString.hs --- a/library/Neovim/API/ByteString.hs +++ b/library/Neovim/API/ByteString.hs @@ -1,8 +1,9 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE NoOverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TemplateHaskell #-} + {- | Module : Neovim.API.ByteString Description : ByteString based API @@ -12,12 +13,9 @@ Maintainer : woozletoff@gmail.com Stability : experimental Portability : GHC - -} -module Neovim.API.ByteString - where +module Neovim.API.ByteString where -import Neovim.API.TH +import Neovim.API.TH $(generateAPI bytestringVectorTypeMap) - diff --git a/library/Neovim/API/String.hs b/library/Neovim/API/String.hs --- a/library/Neovim/API/String.hs +++ b/library/Neovim/API/String.hs @@ -1,8 +1,9 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE NoOverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TemplateHaskell #-} + {- | Module : Neovim.API.String Description : String based API @@ -17,10 +18,8 @@ available to you. All the functions in this module depend on the neovim version that was used when this package was compiled. -} -module Neovim.API.String - where +module Neovim.API.String where -import Neovim.API.TH +import Neovim.API.TH $(generateAPI stringListTypeMap) - diff --git a/library/Neovim/API/TH.hs b/library/Neovim/API/TH.hs --- a/library/Neovim/API/TH.hs +++ b/library/Neovim/API/TH.hs @@ -40,7 +40,7 @@ import Neovim.Plugin.Internal (ExportedFunctionality (..)) import Neovim.RPC.FunctionCall -import Language.Haskell.TH hiding (dataD, instanceD, conP) +import Language.Haskell.TH hiding (conP, dataD, instanceD) import TemplateHaskell.Compat.V0208 import Control.Applicative @@ -59,8 +59,8 @@ import Data.Monoid import qualified Data.Set as Set import Data.Text (Text) -import Data.Text.Prettyprint.Doc (viaShow) import Data.Vector (Vector) +import Prettyprinter (viaShow) import UnliftIO.Exception import Prelude @@ -203,7 +203,8 @@ vars <- mapM ( \(t, n) -> - (,) <$> apiTypeToHaskellType typeMap t + (,) + <$> apiTypeToHaskellType typeMap t <*> newName n ) $ applyPrefixWithNumber nf @@ -272,11 +273,12 @@ let fromObjectClause :: Name -> Int64 -> Q Clause fromObjectClause n i = do bs <- newName "bs" - let objectExtMatch = conP + let objectExtMatch = + conP (mkName "ObjectExt") [(LitP . integerL . fromIntegral) i, VarP bs] clause - [ pure objectExtMatch ] + [pure objectExtMatch] (normalB [|return $ $(conE n) $(varE bs)|]) [] fromObjectErrorClause :: Q Clause @@ -518,7 +520,7 @@ [varP args] ( caseE (varE args) - (zipWith matchingCase [n, n -1 ..] [0 .. minLength] ++ [errorCase]) + (zipWith matchingCase [n, n - 1 ..] [0 .. minLength] ++ [errorCase]) ) -- _ -> err "Wrong number of arguments" diff --git a/library/Neovim/API/Text.hs b/library/Neovim/API/Text.hs --- a/library/Neovim/API/Text.hs +++ b/library/Neovim/API/Text.hs @@ -1,8 +1,9 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE NoOverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TemplateHaskell #-} + {- | Module : Neovim.API.Text Description : Text based API @@ -12,12 +13,9 @@ Maintainer : woozletoff@gmail.com Stability : experimental Portability : GHC - -} -module Neovim.API.Text - where +module Neovim.API.Text where -import Neovim.API.TH +import Neovim.API.TH $(generateAPI textVectorTypeMap) - diff --git a/library/Neovim/Classes.hs b/library/Neovim/Classes.hs --- a/library/Neovim/Classes.hs +++ b/library/Neovim/Classes.hs @@ -1,11 +1,9 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -#if __GLASGOW_HASKELL__ < 710 -{-# LANGUAGE OverlappingInstances #-} -#endif +{-# LANGUAGE RankNTypes #-} + {- | Module : Neovim.Classes Description : Type classes used for conversion of msgpack and Haskell types @@ -14,121 +12,119 @@ Maintainer : woozletoff@gmail.com Stability : experimental - -} -module Neovim.Classes - ( NvimObject(..) - , Dictionary - , (+:) - , Generic - , docToObject - , docFromObject - , docToText - - , Doc - , AnsiStyle - , Pretty(..) - , (<+>) - , module Data.Int - , module Data.Word - , module Control.DeepSeq - ) where +module Neovim.Classes ( + NvimObject (..), + Dictionary, + (+:), + Generic, + docToObject, + docFromObject, + docToText, + Doc, + AnsiStyle, + Pretty (..), + (<+>), + module Data.Int, + module Data.Word, + module Control.DeepSeq, +) where import Neovim.Exceptions (NeovimException (..)) -import Control.Applicative -import Control.Arrow ((***)) -import Control.DeepSeq -import Control.Monad.Except -import Data.ByteString (ByteString) -import Data.Int - ( Int16 - , Int32 - , Int64 - , Int8 - ) -import qualified Data.Map.Strict as SMap -import Data.MessagePack -import Data.Monoid -import Data.Text as Text (Text) -import Data.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.Vector (Vector) -import qualified Data.Vector as V -import Data.Word - ( Word - , Word16 - , Word32 - , Word64 - , Word8 - ) -import GHC.Generics (Generic) +import Control.Applicative +import Control.Arrow ((***)) +import Control.DeepSeq +import Control.Monad.Except +import Data.ByteString (ByteString) +import Data.Int ( + Int16, + Int32, + Int64, + Int8, + ) +import qualified Data.Map.Strict as SMap +import Data.MessagePack +import Data.Monoid +import Data.Text as Text (Text) +import Data.Traversable hiding (forM, mapM) +import Data.Vector (Vector) +import qualified Data.Vector as V +import Data.Word ( + Word, + Word16, + Word32, + Word64, + Word8, + ) +import GHC.Generics (Generic) +import Prettyprinter ( + Doc, + Pretty (..), + defaultLayoutOptions, + layoutPretty, + viaShow, + (<+>), + ) +import qualified Prettyprinter as P +import Prettyprinter.Render.Terminal ( + AnsiStyle, + renderStrict, + ) import qualified Data.ByteString.UTF8 as UTF8 (fromString, toString) -import Data.Text.Encoding (decodeUtf8, encodeUtf8) -import UnliftIO.Exception (throwIO) +import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import UnliftIO.Exception (throwIO) import Prelude - infixr 5 +: --- | Convenient operator to create a list of 'Object' from normal values. --- @ --- values +: of :+ different :+ types :+ can +: be +: combined +: this +: way +: [] --- @ +{- | Convenient operator to create a list of 'Object' from normal values. + @ + values +: of :+ different :+ types :+ can +: be +: combined +: this +: way +: [] + @ +-} (+:) :: (NvimObject o) => o -> [Object] -> [Object] o +: os = toObject o : os - --- | Convert a 'Doc'-ument to a messagepack 'Object'. This is more a convenience --- method to transport error message from and to neovim. It generally does not --- hold that 'docToObject . docFromObject' = 'id'. +{- | Convert a 'Doc'-ument to a messagepack 'Object'. This is more a convenience + method to transport error message from and to neovim. It generally does not + hold that 'docToObject . docFromObject' = 'id'. +-} docToObject :: Doc AnsiStyle -> Object docToObject = ObjectString . encodeUtf8 . docToText - -- | See 'docToObject'. docFromObject :: Object -> Either (Doc AnsiStyle) (Doc AnsiStyle) docFromObject o = (P.viaShow :: Text -> Doc AnsiStyle) <$> fromObject o - docToText :: Doc AnsiStyle -> Text docToText = renderStrict . layoutPretty defaultLayoutOptions - --- | A generic vim dictionary is a simply a map from strings to objects. This --- type alias is sometimes useful as a type annotation especially if the --- OverloadedStrings extension is enabled. +{- | A generic vim dictionary is a simply a map from strings to objects. This + type alias is sometimes useful as a type annotation especially if the + OverloadedStrings extension is enabled. +-} type Dictionary = SMap.Map ByteString Object +{- | Conversion from 'Object' files to Haskell types and back with respect + to neovim's interpretation. --- | Conversion from 'Object' files to Haskell types and back with respect --- to neovim's interpretation. --- --- The 'NFData' constraint has been added to allow forcing results of function --- evaluations in order to catch exceptions from pure code. This adds more --- stability to the plugin provider and seems to be a cleaner approach. + The 'NFData' constraint has been added to allow forcing results of function + evaluations in order to catch exceptions from pure code. This adds more + stability to the plugin provider and seems to be a cleaner approach. +-} class NFData o => NvimObject o where toObject :: o -> Object fromObjectUnsafe :: Object -> o fromObjectUnsafe o = case fromObject o of - Left e -> error . show $ - "Not the expected object:" <+> P.viaShow o - <+> P.lparen <> e <> P.rparen + Left e -> + error . show $ + "Not the expected object:" + <+> P.viaShow o + <+> P.lparen <> e <> P.rparen Right obj -> obj fromObject :: Object -> Either (Doc AnsiStyle) o @@ -139,226 +135,211 @@ {-# MINIMAL toObject, (fromObject | fromObjectUnsafe) #-} - -- Instances for NvimObject {{{1 instance NvimObject () where - toObject _ = ObjectNil + toObject _ = ObjectNil fromObject ObjectNil = return () - fromObject o = throwError $ "Expected ObjectNil, but got" <+> P.viaShow o - + fromObject o = throwError $ "Expected ObjectNil, but got" <+> P.viaShow o -- We may receive truthy values from neovim, so we should be more forgiving -- here. instance NvimObject Bool where - toObject = ObjectBool + toObject = ObjectBool - fromObject (ObjectBool o) = return o - fromObject (ObjectInt 0) = return False - fromObject (ObjectUInt 0) = return False - fromObject ObjectNil = return False + fromObject (ObjectBool o) = return o + fromObject (ObjectInt 0) = return False + fromObject (ObjectUInt 0) = return False + fromObject ObjectNil = return False fromObject (ObjectBinary "0") = return False - fromObject (ObjectBinary "") = return False + fromObject (ObjectBinary "") = return False fromObject (ObjectString "0") = return False - fromObject (ObjectString "") = return False - fromObject _ = return True - + fromObject (ObjectString "") = return False + fromObject _ = return True instance NvimObject Double where - toObject = ObjectDouble + toObject = ObjectDouble fromObject (ObjectDouble o) = return o - fromObject (ObjectFloat o) = return $ realToFrac o - fromObject (ObjectInt o) = return $ fromIntegral o - fromObject (ObjectUInt o) = return $ fromIntegral o - fromObject o = throwError $ "Expected ObjectDouble, but got" - <+> viaShow o - + fromObject (ObjectFloat o) = return $ realToFrac o + fromObject (ObjectInt o) = return $ fromIntegral o + fromObject (ObjectUInt o) = return $ fromIntegral o + fromObject o = + throwError $ + "Expected ObjectDouble, but got" + <+> viaShow o instance NvimObject Integer where - toObject = ObjectInt . fromIntegral + toObject = ObjectInt . fromIntegral - fromObject (ObjectInt o) = return $ toInteger o - fromObject (ObjectUInt o) = return $ toInteger o + fromObject (ObjectInt o) = return $ toInteger o + fromObject (ObjectUInt o) = return $ toInteger o fromObject (ObjectDouble o) = return $ round o - fromObject (ObjectFloat o) = return $ round o - fromObject o = throwError $ "Expected ObjectInt, but got" <+> viaShow o - + fromObject (ObjectFloat o) = return $ round o + fromObject o = throwError $ "Expected ObjectInt, but got" <+> viaShow o instance NvimObject Int64 where - toObject = ObjectInt + toObject = ObjectInt - fromObject (ObjectInt i) = return i - fromObject (ObjectUInt o) = return $ fromIntegral o + fromObject (ObjectInt i) = return i + fromObject (ObjectUInt o) = return $ fromIntegral o fromObject (ObjectDouble o) = return $ round o - fromObject (ObjectFloat o) = return $ round o - fromObject o = throwError $ "Expected any Integer value, but got" <+> viaShow o - + fromObject (ObjectFloat o) = return $ round o + fromObject o = throwError $ "Expected any Integer value, but got" <+> viaShow o instance NvimObject Int32 where - toObject = ObjectInt . fromIntegral + toObject = ObjectInt . fromIntegral - fromObject (ObjectInt i) = return $ fromIntegral i - fromObject (ObjectUInt i) = return $ fromIntegral i + fromObject (ObjectInt i) = return $ fromIntegral i + fromObject (ObjectUInt i) = return $ fromIntegral i fromObject (ObjectDouble o) = return $ round o - fromObject (ObjectFloat o) = return $ round o - fromObject o = throwError $ "Expected any Integer value, but got" <+> viaShow o - + fromObject (ObjectFloat o) = return $ round o + fromObject o = throwError $ "Expected any Integer value, but got" <+> viaShow o instance NvimObject Int16 where - toObject = ObjectInt . fromIntegral + toObject = ObjectInt . fromIntegral - fromObject (ObjectInt i) = return $ fromIntegral i - fromObject (ObjectUInt i) = return $ fromIntegral i + fromObject (ObjectInt i) = return $ fromIntegral i + fromObject (ObjectUInt i) = return $ fromIntegral i fromObject (ObjectDouble o) = return $ round o - fromObject (ObjectFloat o) = return $ round o - fromObject o = throwError $ "Expected any Integer value, but got" <+> viaShow o - + fromObject (ObjectFloat o) = return $ round o + fromObject o = throwError $ "Expected any Integer value, but got" <+> viaShow o instance NvimObject Int8 where - toObject = ObjectInt . fromIntegral + toObject = ObjectInt . fromIntegral - fromObject (ObjectInt i) = return $ fromIntegral i - fromObject (ObjectUInt i) = return $ fromIntegral i + fromObject (ObjectInt i) = return $ fromIntegral i + fromObject (ObjectUInt i) = return $ fromIntegral i fromObject (ObjectDouble o) = return $ round o - fromObject (ObjectFloat o) = return $ round o - fromObject o = throwError $ "Expected any Integer value, but got" <+> viaShow o - + fromObject (ObjectFloat o) = return $ round o + fromObject o = throwError $ "Expected any Integer value, but got" <+> viaShow o instance NvimObject Word where - toObject = ObjectInt . fromIntegral + toObject = ObjectInt . fromIntegral - fromObject (ObjectInt i) = return $ fromIntegral i - fromObject (ObjectUInt i) = return $ fromIntegral i + fromObject (ObjectInt i) = return $ fromIntegral i + fromObject (ObjectUInt i) = return $ fromIntegral i fromObject (ObjectDouble o) = return $ round o - fromObject (ObjectFloat o) = return $ round o - fromObject o = throwError $ "Expected any Integer value, but got" <+> viaShow o - + fromObject (ObjectFloat o) = return $ round o + fromObject o = throwError $ "Expected any Integer value, but got" <+> viaShow o instance NvimObject Word64 where - toObject = ObjectInt . fromIntegral + toObject = ObjectInt . fromIntegral - fromObject (ObjectInt i) = return $ fromIntegral i - fromObject (ObjectUInt i) = return $ fromIntegral i + fromObject (ObjectInt i) = return $ fromIntegral i + fromObject (ObjectUInt i) = return $ fromIntegral i fromObject (ObjectDouble o) = return $ round o - fromObject (ObjectFloat o) = return $ round o - fromObject o = throwError $ "Expected any Integer value, but got" <+> viaShow o - + fromObject (ObjectFloat o) = return $ round o + fromObject o = throwError $ "Expected any Integer value, but got" <+> viaShow o instance NvimObject Word32 where - toObject = ObjectInt . fromIntegral + toObject = ObjectInt . fromIntegral - fromObject (ObjectInt i) = return $ fromIntegral i - fromObject (ObjectUInt i) = return $ fromIntegral i + fromObject (ObjectInt i) = return $ fromIntegral i + fromObject (ObjectUInt i) = return $ fromIntegral i fromObject (ObjectDouble o) = return $ round o - fromObject (ObjectFloat o) = return $ round o - fromObject o = throwError $ "Expected any Integer value, but got" <+> viaShow o - + fromObject (ObjectFloat o) = return $ round o + fromObject o = throwError $ "Expected any Integer value, but got" <+> viaShow o instance NvimObject Word16 where - toObject = ObjectInt . fromIntegral + toObject = ObjectInt . fromIntegral - fromObject (ObjectInt i) = return $ fromIntegral i - fromObject (ObjectUInt i) = return $ fromIntegral i + fromObject (ObjectInt i) = return $ fromIntegral i + fromObject (ObjectUInt i) = return $ fromIntegral i fromObject (ObjectDouble o) = return $ round o - fromObject (ObjectFloat o) = return $ round o - fromObject o = throwError $ "Expected any Integer value, but got" <+> viaShow o - + fromObject (ObjectFloat o) = return $ round o + fromObject o = throwError $ "Expected any Integer value, but got" <+> viaShow o instance NvimObject Word8 where - toObject = ObjectInt . fromIntegral + toObject = ObjectInt . fromIntegral - fromObject (ObjectInt i) = return $ fromIntegral i - fromObject (ObjectUInt i) = return $ fromIntegral i + fromObject (ObjectInt i) = return $ fromIntegral i + fromObject (ObjectUInt i) = return $ fromIntegral i fromObject (ObjectDouble o) = return $ round o - fromObject (ObjectFloat o) = return $ round o - fromObject o = throwError $ "Expected any Integer value, but got" <+> viaShow o - + fromObject (ObjectFloat o) = return $ round o + fromObject o = throwError $ "Expected any Integer value, but got" <+> viaShow o instance NvimObject Int where - toObject = ObjectInt . fromIntegral + toObject = ObjectInt . fromIntegral - fromObject (ObjectInt i) = return $ fromIntegral i - fromObject (ObjectUInt i) = return $ fromIntegral i + fromObject (ObjectInt i) = return $ fromIntegral i + fromObject (ObjectUInt i) = return $ fromIntegral i fromObject (ObjectDouble o) = return $ round o - fromObject (ObjectFloat o) = return $ round o - fromObject o = throwError $ "Expected any Integer value, but got" <+> viaShow o - + fromObject (ObjectFloat o) = return $ round o + fromObject o = throwError $ "Expected any Integer value, but got" <+> viaShow o instance {-# OVERLAPPING #-} NvimObject [Char] where - toObject = ObjectBinary . UTF8.fromString + toObject = ObjectBinary . UTF8.fromString fromObject (ObjectBinary o) = return $ UTF8.toString o fromObject (ObjectString o) = return $ UTF8.toString o - fromObject o = throwError $ "Expected ObjectString, but got" <+> viaShow o - + fromObject o = throwError $ "Expected ObjectString, but got" <+> viaShow o instance {-# OVERLAPPABLE #-} NvimObject o => NvimObject [o] where - toObject = ObjectArray . map toObject + toObject = ObjectArray . map toObject fromObject (ObjectArray os) = mapM fromObject os - fromObject o = throwError $ "Expected ObjectArray, but got" <+> viaShow 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 instance NvimObject o => NvimObject (Vector o) where toObject = ObjectArray . V.toList . V.map toObject fromObject (ObjectArray os) = V.fromList <$> mapM fromObject os - fromObject o = throwError $ "Expected ObjectArray, but got" <+> viaShow o - + fromObject o = throwError $ "Expected ObjectArray, but got" <+> viaShow o -- | Right-biased instance for toObject. instance (NvimObject l, NvimObject r) => NvimObject (Either l r) where toObject = either toObject toObject fromObject o = case fromObject o of - Right r -> - return $ Right r - - Left e1 -> case fromObject o of - Right l -> - return $ Left l - - Left e2 -> - throwError $ e1 <+> "--" <+> e2 - - -instance (Ord key, NvimObject key, NvimObject val) - => NvimObject (SMap.Map key val) where - toObject = ObjectMap - . SMap.fromList . map (toObject *** toObject) . SMap.toList + Right r -> + return $ Right r + Left e1 -> case fromObject o of + Right l -> + return $ Left l + Left e2 -> + throwError $ e1 <+> "--" <+> e2 - fromObject (ObjectMap om) = SMap.fromList <$> - (sequenceA - . map (uncurry (liftA2 (,)) - . (fromObject *** fromObject)) - . SMap.toList) om +instance + (Ord key, NvimObject key, NvimObject val) => + NvimObject (SMap.Map key val) + where + toObject = + ObjectMap + . SMap.fromList + . map (toObject *** toObject) + . SMap.toList + fromObject (ObjectMap om) = + SMap.fromList + <$> ( traverse + ( uncurry (liftA2 (,)) + . (fromObject *** fromObject) + ) + . SMap.toList + ) + om fromObject o = throwError $ "Expected ObjectMap, but got" <+> viaShow o - instance NvimObject Text where - toObject = ObjectBinary . encodeUtf8 + toObject = ObjectBinary . encodeUtf8 fromObject (ObjectBinary o) = return $ decodeUtf8 o fromObject (ObjectString o) = return $ decodeUtf8 o - fromObject o = throwError $ "Expected ObjectBinary, but got" <+> viaShow o - + fromObject o = throwError $ "Expected ObjectBinary, but got" <+> viaShow o instance NvimObject ByteString where - toObject = ObjectBinary + toObject = ObjectBinary fromObject (ObjectBinary o) = return o fromObject (ObjectString o) = return o - fromObject o = throwError $ "Expected ObjectBinary, but got" <+> viaShow o - + fromObject o = throwError $ "Expected ObjectBinary, but got" <+> viaShow o instance NvimObject Object where toObject = id @@ -366,105 +347,105 @@ fromObject = return fromObjectUnsafe = id - -- By the magic of vim, i will create these. instance (NvimObject o1, NvimObject o2) => NvimObject (o1, o2) where toObject (o1, o2) = ObjectArray $ [toObject o1, toObject o2] - fromObject (ObjectArray [o1, o2]) = (,) - <$> fromObject o1 - <*> fromObject o2 + fromObject (ObjectArray [o1, o2]) = + (,) + <$> fromObject o1 + <*> fromObject o2 fromObject o = throwError $ "Expected ObjectArray, but got" <+> viaShow o instance (NvimObject o1, NvimObject o2, NvimObject o3) => NvimObject (o1, o2, o3) where toObject (o1, o2, o3) = ObjectArray $ [toObject o1, toObject o2, toObject o3] - fromObject (ObjectArray [o1, o2, o3]) = (,,) - <$> fromObject o1 - <*> fromObject o2 - <*> fromObject o3 + fromObject (ObjectArray [o1, o2, o3]) = + (,,) + <$> fromObject o1 + <*> fromObject o2 + <*> fromObject o3 fromObject o = throwError $ "Expected ObjectArray, but got" <+> viaShow o - instance (NvimObject o1, NvimObject o2, NvimObject o3, NvimObject o4) => NvimObject (o1, o2, o3, o4) where - toObject (o1, o2, o3, o4) = ObjectArray $ [toObject o1, toObject o2, toObject o3, toObject o4] + toObject (o1, o2, o3, o4) = ObjectArray [toObject o1, toObject o2, toObject o3, toObject o4] - fromObject (ObjectArray [o1, o2, o3, o4]) = (,,,) - <$> fromObject o1 - <*> fromObject o2 - <*> fromObject o3 - <*> fromObject o4 + fromObject (ObjectArray [o1, o2, o3, o4]) = + (,,,) + <$> fromObject o1 + <*> fromObject o2 + <*> fromObject o3 + <*> fromObject o4 fromObject o = throwError $ "Expected ObjectArray, but got" <+> viaShow o - instance (NvimObject o1, NvimObject o2, NvimObject o3, NvimObject o4, NvimObject o5) => NvimObject (o1, o2, o3, o4, o5) where - toObject (o1, o2, o3, o4, o5) = ObjectArray $ [toObject o1, toObject o2, toObject o3, toObject o4, toObject o5] + toObject (o1, o2, o3, o4, o5) = ObjectArray [toObject o1, toObject o2, toObject o3, toObject o4, toObject o5] - fromObject (ObjectArray [o1, o2, o3, o4, o5]) = (,,,,) - <$> fromObject o1 - <*> fromObject o2 - <*> fromObject o3 - <*> fromObject o4 - <*> fromObject o5 + fromObject (ObjectArray [o1, o2, o3, o4, o5]) = + (,,,,) + <$> fromObject o1 + <*> fromObject o2 + <*> fromObject o3 + <*> fromObject o4 + <*> fromObject o5 fromObject o = throwError $ "Expected ObjectArray, but got" <+> viaShow o - instance (NvimObject o1, NvimObject o2, NvimObject o3, NvimObject o4, NvimObject o5, NvimObject o6) => NvimObject (o1, o2, o3, o4, o5, o6) where - toObject (o1, o2, o3, o4, o5, o6) = ObjectArray $ [toObject o1, toObject o2, toObject o3, toObject o4, toObject o5, toObject o6] + toObject (o1, o2, o3, o4, o5, o6) = ObjectArray [toObject o1, toObject o2, toObject o3, toObject o4, toObject o5, toObject o6] - fromObject (ObjectArray [o1, o2, o3, o4, o5, o6]) = (,,,,,) - <$> fromObject o1 - <*> fromObject o2 - <*> fromObject o3 - <*> fromObject o4 - <*> fromObject o5 - <*> fromObject o6 + fromObject (ObjectArray [o1, o2, o3, o4, o5, o6]) = + (,,,,,) + <$> fromObject o1 + <*> fromObject o2 + <*> fromObject o3 + <*> fromObject o4 + <*> fromObject o5 + <*> fromObject o6 fromObject o = throwError $ "Expected ObjectArray, but got" <+> viaShow o - instance (NvimObject o1, NvimObject o2, NvimObject o3, NvimObject o4, NvimObject o5, NvimObject o6, NvimObject o7) => NvimObject (o1, o2, o3, o4, o5, o6, o7) where - toObject (o1, o2, o3, o4, o5, o6, o7) = ObjectArray $ [toObject o1, toObject o2, toObject o3, toObject o4, toObject o5, toObject o6, toObject o7] + toObject (o1, o2, o3, o4, o5, o6, o7) = ObjectArray [toObject o1, toObject o2, toObject o3, toObject o4, toObject o5, toObject o6, toObject o7] - fromObject (ObjectArray [o1, o2, o3, o4, o5, o6, o7]) = (,,,,,,) - <$> fromObject o1 - <*> fromObject o2 - <*> fromObject o3 - <*> fromObject o4 - <*> fromObject o5 - <*> fromObject o6 - <*> fromObject o7 + fromObject (ObjectArray [o1, o2, o3, o4, o5, o6, o7]) = + (,,,,,,) + <$> fromObject o1 + <*> fromObject o2 + <*> fromObject o3 + <*> fromObject o4 + <*> fromObject o5 + <*> fromObject o6 + <*> fromObject o7 fromObject o = throwError $ "Expected ObjectArray, but got" <+> viaShow o - instance (NvimObject o1, NvimObject o2, NvimObject o3, NvimObject o4, NvimObject o5, NvimObject o6, NvimObject o7, NvimObject o8) => NvimObject (o1, o2, o3, o4, o5, o6, o7, o8) where toObject (o1, o2, o3, o4, o5, o6, o7, o8) = ObjectArray $ [toObject o1, toObject o2, toObject o3, toObject o4, toObject o5, toObject o6, toObject o7, toObject o8] - fromObject (ObjectArray [o1, o2, o3, o4, o5, o6, o7, o8]) = (,,,,,,,) - <$> fromObject o1 - <*> fromObject o2 - <*> fromObject o3 - <*> fromObject o4 - <*> fromObject o5 - <*> fromObject o6 - <*> fromObject o7 - <*> fromObject o8 + fromObject (ObjectArray [o1, o2, o3, o4, o5, o6, o7, o8]) = + (,,,,,,,) + <$> fromObject o1 + <*> fromObject o2 + <*> fromObject o3 + <*> fromObject o4 + <*> fromObject o5 + <*> fromObject o6 + <*> fromObject o7 + <*> fromObject o8 fromObject o = throwError $ "Expected ObjectArray, but got" <+> viaShow o - instance (NvimObject o1, NvimObject o2, NvimObject o3, NvimObject o4, NvimObject o5, NvimObject o6, NvimObject o7, NvimObject o8, NvimObject o9) => NvimObject (o1, o2, o3, o4, o5, o6, o7, o8, o9) where toObject (o1, o2, o3, o4, o5, o6, o7, o8, o9) = ObjectArray $ [toObject o1, toObject o2, toObject o3, toObject o4, toObject o5, toObject o6, toObject o7, toObject o8, toObject o9] - fromObject (ObjectArray [o1, o2, o3, o4, o5, o6, o7, o8, o9]) = (,,,,,,,,) - <$> fromObject o1 - <*> fromObject o2 - <*> fromObject o3 - <*> fromObject o4 - <*> fromObject o5 - <*> fromObject o6 - <*> fromObject o7 - <*> fromObject o8 - <*> fromObject o9 + fromObject (ObjectArray [o1, o2, o3, o4, o5, o6, o7, o8, o9]) = + (,,,,,,,,) + <$> fromObject o1 + <*> fromObject o2 + <*> fromObject o3 + <*> fromObject o4 + <*> fromObject o5 + <*> fromObject o6 + <*> fromObject o7 + <*> fromObject o8 + <*> fromObject o9 fromObject o = throwError $ "Expected ObjectArray, but got" <+> viaShow o - -- 1}}} diff --git a/library/Neovim/Config.hs b/library/Neovim/Config.hs --- a/library/Neovim/Config.hs +++ b/library/Neovim/Config.hs @@ -6,28 +6,26 @@ Maintainer : woozletoff@gmail.com Stability : experimental - -} module Neovim.Config ( - NeovimConfig(..), + NeovimConfig (..), module System.Log, - ) where +) where -import Neovim.Context (Neovim) -import Neovim.Plugin.Internal (NeovimPlugin) +import Neovim.Context (Neovim) +import Neovim.Plugin.Internal (NeovimPlugin) -import System.Log (Priority (..)) +import System.Log (Priority (..)) --- | This data type contains information about the configuration of neovim. See --- the fields' documentation for what you possibly want to change. Also, the --- tutorial in the "Neovim" module should get you started. +{- | This data type contains information about the configuration of neovim. See + the fields' documentation for what you possibly want to change. Also, the + tutorial in the "Neovim" module should get you started. +-} data NeovimConfig = Config - { plugins :: [Neovim () 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'. - - , logOptions :: Maybe (FilePath, Priority) - -- ^ Set the general logging options. + { -- | The list of plugins. The IO type inside the list allows the plugin + -- author to run some arbitrary startup code before creating a value of + -- type 'NeovimPlugin'. + plugins :: [Neovim () NeovimPlugin] + , -- | Set the general logging options. + logOptions :: Maybe (FilePath, Priority) } - diff --git a/library/Neovim/Context.hs b/library/Neovim/Context.hs --- a/library/Neovim/Context.hs +++ b/library/Neovim/Context.hs @@ -23,6 +23,8 @@ errOnInvalidResult, restart, quit, + subscribe, + unsubscribe, ask, asks, @@ -46,7 +48,7 @@ import Neovim.Classes import Neovim.Context.Internal (FunctionMap, FunctionMapEntry, Neovim, mkFunctionMap, - newUniqueFunctionName, runNeovim) + newUniqueFunctionName, runNeovim, subscribe, unsubscribe) import Neovim.Exceptions (NeovimException (..), exceptionToDoc) import qualified Neovim.Context.Internal as Internal diff --git a/library/Neovim/Context/Internal.hs b/library/Neovim/Context/Internal.hs --- a/library/Neovim/Context/Internal.hs +++ b/library/Neovim/Context/Internal.hs @@ -1,10 +1,9 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE MultiParamTypeClasses #-} + {- | Module : Neovim.Context.Internal Description : Abstract description of the plugin provider's internal context @@ -17,115 +16,115 @@ To shorten function and data type names, import this qualfied as @Internal@. -} -module Neovim.Context.Internal - where +module Neovim.Context.Internal where -import Neovim.Classes -import Neovim.Exceptions (NeovimException (..), - exceptionToDoc) -import Neovim.Plugin.Classes -import Neovim.Plugin.IPC (SomeMessage) +import Neovim.Classes +import Neovim.Exceptions ( + NeovimException (..), + exceptionToDoc, + ) +import Neovim.Plugin.Classes +import Neovim.Plugin.IPC (SomeMessage) -import Control.Applicative -import Control.Exception (ArithException, - ArrayException, - ErrorCall, - PatternMatchFail) -import Control.Monad.Except -import Control.Monad.Reader -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 Data.Monoid (Ap(Ap)) -import System.Log.Logger -import UnliftIO +import Control.Applicative +import Control.Exception ( + ArithException, + ArrayException, + ErrorCall, + PatternMatchFail, + ) +import Control.Monad.Except +import Control.Monad.Reader +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 Data.Monoid (Ap (Ap)) +import Data.Text (Text) +import System.Log.Logger +import UnliftIO -import Data.Text.Prettyprint.Doc (viaShow) +import Prettyprinter (viaShow) import qualified Control.Monad.Fail as Fail -import Prelude +import Prelude +{- | This is the environment in which all plugins are initially started. --- | This is the environment in which all plugins are initially started. --- --- Functions have to run in this transformer stack to communicate with neovim. --- If parts of your own functions dont need to communicate with neovim, it is --- good practice to factor them out. This allows you to write tests and spot --- errors easier. Essentially, you should treat this similar to 'IO' in general --- haskell programs. + Functions have to run in this transformer stack to communicate with neovim. + If parts of your own functions dont need to communicate with neovim, it is + good practice to factor them out. This allows you to write tests and spot + errors easier. Essentially, you should treat this similar to 'IO' in general + haskell programs. +-} newtype Neovim env a = Neovim - { unNeovim :: ResourceT (ReaderT (Config env) IO) a } - - deriving newtype (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadUnliftIO) - deriving (Semigroup, Monoid) via (Ap (Neovim env) a) - + {unNeovim :: ResourceT (ReaderT (Config env) IO) a} + deriving newtype (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadUnliftIO) + deriving (Semigroup, Monoid) via (Ap (Neovim env) a) -- | User facing instance declaration for the reader state. instance MonadReader env (Neovim env) where ask = Neovim $ asks customConfig local f (Neovim a) = do r <- Neovim ask - liftIO $ runReaderT (runResourceT a) - (r { customConfig = f (customConfig r)}) - + liftIO $ + runReaderT + (runResourceT a) + (r{customConfig = f (customConfig r)}) instance MonadResource (Neovim env) where liftResourceT m = Neovim $ liftResourceT m - instance Fail.MonadFail (Neovim env) where - fail = throwIO . ErrorMessage . pretty - + fail = throwIO . ErrorMessage . pretty -- | Same as 'ask' for the 'InternalConfig'. ask' :: Neovim env (Config env) ask' = Neovim ask - -- | Same as 'asks' for the 'InternalConfig'. asks' :: (Config env -> a) -> Neovim env a asks' = Neovim . asks - exceptionHandlers :: [Handler IO (Either (Doc ann) a)] exceptionHandlers = - [ Handler $ \(_ :: ArithException) -> ret "ArithException (e.g. division by 0)" - , Handler $ \(_ :: ArrayException) -> ret "ArrayException" - , Handler $ \(_ :: ErrorCall) -> ret "ErrorCall (e.g. call of undefined or error" + [ Handler $ \(_ :: ArithException) -> ret "ArithException (e.g. division by 0)" + , Handler $ \(_ :: ArrayException) -> ret "ArrayException" + , Handler $ \(_ :: ErrorCall) -> ret "ErrorCall (e.g. call of undefined or error" , Handler $ \(_ :: PatternMatchFail) -> ret "Pattern match failure" - , Handler $ \(_ :: SomeException) -> ret "Unhandled exception" + , Handler $ \(_ :: SomeException) -> ret "Unhandled exception" ] where ret = return . Left -- | Initialize a 'Neovim' context by supplying an 'InternalEnvironment'. -runNeovim :: NFData a - => Config env - -> Neovim env a - -> IO (Either (Doc AnsiStyle) a) +runNeovim :: + NFData a => + Config env -> + Neovim env a -> + IO (Either (Doc AnsiStyle) a) runNeovim = runNeovimInternal (\a -> a `deepseq` return a) -runNeovimInternal :: (a -> IO a) - -> Config env - -> Neovim env a - -> IO (Either (Doc AnsiStyle) a) +runNeovimInternal :: + (a -> IO a) -> + Config env -> + Neovim env a -> + IO (Either (Doc AnsiStyle) a) runNeovimInternal f r (Neovim a) = (try . runReaderT (runResourceT a)) r >>= \case Left e -> case fromException e of Just e' -> return . Left . exceptionToDoc $ (e' :: NeovimException) - Nothing -> do liftIO . errorM "Context" $ "Converting Exception to Error message: " ++ show e (return . Left . viaShow) e Right res -> (Right <$> f res) `catches` exceptionHandlers - --- | Create a new unique function name. To prevent possible name clashes, digits --- are stripped from the given suffix. +{- | Create a new unique function name. To prevent possible name clashes, digits + are stripped from the given suffix. +-} newUniqueFunctionName :: Neovim env FunctionName newUniqueFunctionName = do tu <- asks' uniqueCounter @@ -136,140 +135,178 @@ modifyTVar' tu succ return u - --- | This data type is used to dispatch a remote function call to the appopriate --- recipient. -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. - +{- | This data type is used to dispatch a remote function call to the appopriate + recipient. +-} +newtype FunctionType + = -- | 'Stateful' functions are handled within a special thread, the 'TQueue' + -- is the communication endpoint for the arguments we have to pass. + Stateful (TQueue SomeMessage) instance Pretty FunctionType where pretty = \case - Stateful _ -> "\\os -> Neovim env o" - + Stateful _ -> "\\os -> Neovim env o" -- | Type of the values stored in the function map. type FunctionMapEntry = (FunctionalityDescription, FunctionType) +{- | A function map is a map containing the names of functions as keys and some + context dependent value which contains all the necessary information to + execute that function in the intended way. --- | A function map is a map containing the names of functions as keys and some --- context dependent value which contains all the necessary information to --- execute that function in the intended way. --- --- This type is only used internally and handles two distinct cases. One case --- is a direct function call, wich is simply a function that accepts a list of --- 'Object' values and returns a result in the 'Neovim' context. The second --- case is calling a function that has a persistent state. This is mediated to --- a thread that reads from a 'TQueue'. (NB: persistent currently means, that --- state is stored for as long as the plugin provider is running and not --- restarted.) + This type is only used internally and handles two distinct cases. One case + is a direct function call, wich is simply a function that accepts a list of + 'Object' values and returns a result in the 'Neovim' context. The second + case is calling a function that has a persistent state. This is mediated to + a thread that reads from a 'TQueue'. (NB: persistent currently means, that + state is stored for as long as the plugin provider is running and not + restarted.) +-} type FunctionMap = Map NvimMethod FunctionMapEntry - -- | Create a new function map from the given list of 'FunctionMapEntry' values. mkFunctionMap :: [FunctionMapEntry] -> FunctionMap mkFunctionMap = Map.fromList . map (\e -> (nvimMethod (fst e), e)) - --- | A wrapper for a reader value that contains extra fields required to --- communicate with the messagepack-rpc components and provide necessary data to --- provide other globally available operations. --- --- Note that you most probably do not want to change the fields prefixed with an --- underscore. -data Config env = Config - -- Global settings; initialized once - { eventQueue :: TQueue SomeMessage - -- ^ A queue of messages that the event handler will propagate to - -- appropriate threads and handlers. - - , transitionTo :: MVar StateTransition - -- ^ The main thread will wait for this 'MVar' to be filled with a value - -- and then perform an action appropriate for the value of type - -- 'StateTransition'. +data Subscriptions = Subscriptions + { nextSubscriptionId :: SubscriptionId + , byEventId :: Map NeovimEventId [Subscription] + } - , providerName :: TMVar (Either String Int) - -- ^ Since nvim-hs must have its "Neovim.RPC.SocketReader" and - -- "Neovim.RPC.EventHandler" running to determine the actual channel id - -- (i.e. the 'Int' value here) this field can only be set properly later. - -- Hence, the value of this field is put in an 'TMVar'. - -- Name that is used to identify this provider. Assigning such a name is - -- done in the neovim config (e.g. ~\/.nvim\/nvimrc). +{- | Subscribe to an event. When the event is received, the given callback function + is run. It is usually necessary to call the appropriate API function in order for + /neovim/ to send the notifications to /nvim-hs/. The returned subscription can be + used to 'unsubscribe'. +-} +subscribe :: Text -> ([Object] -> Neovim env ()) -> Neovim env Subscription +subscribe event action = do + let eventId = NeovimEventId event + cfg <- ask' + let subscriptions' = subscriptions cfg + atomically $ do + s <- takeTMVar subscriptions' + let subscriptionId = nextSubscriptionId s + let newSubscription = + Subscription + { subId = subscriptionId + , subEventId = eventId + , subAction = void . runNeovim cfg . action + } + putTMVar + subscriptions' + s + { nextSubscriptionId = succ subscriptionId + , byEventId = Map.insertWith (<>) eventId [newSubscription] (byEventId s) + } + pure newSubscription - , uniqueCounter :: TVar Integer - -- ^ This 'TVar' is used to generate uniqe function names on the side of - -- /nvim-hs/. This is useful if you don't want to overwrite existing - -- functions or if you create autocmd functions. +-- | Remove the subscription that has been returned by 'subscribe'. +unsubscribe :: Subscription -> Neovim env () +unsubscribe subscription = do + subscriptions' <- asks' subscriptions + void . atomically $ do + s <- takeTMVar subscriptions' + let eventId = subEventId subscription + deleteSubscription = Just . filter ((/= subId subscription) . subId) + putTMVar + subscriptions' + s + { byEventId = Map.update deleteSubscription eventId (byEventId s) + } - , globalFunctionMap :: TMVar FunctionMap - -- ^ This map is used to dispatch received messagepack function calls to - -- it's appropriate targets. +{- | A wrapper for a reader value that contains extra fields required to + communicate with the messagepack-rpc components and provide necessary data to + provide other globally available operations. - -- Local settings; intialized for each stateful component - , pluginSettings :: Maybe (PluginSettings env) - -- ^ In a registered functionality this field contains a function (and - -- possibly some context dependent values) to register new functionality. + Note that you most probably do not want to change the fields prefixed with an + underscore. +-} +data Config env = Config + -- Global settings; initialized once + { -- | A queue of messages that the event handler will propagate to + -- appropriate threads and handlers. + eventQueue :: TQueue SomeMessage + , -- | The main thread will wait for this 'MVar' to be filled with a value + -- and then perform an action appropriate for the value of type + -- 'StateTransition'. + transitionTo :: MVar StateTransition + , -- | Since nvim-hs must have its "Neovim.RPC.SocketReader" and + -- "Neovim.RPC.EventHandler" running to determine the actual channel id + -- (i.e. the 'Int' value here) this field can only be set properly later. + -- Hence, the value of this field is put in an 'TMVar'. + -- Name that is used to identify this provider. Assigning such a name is + -- done in the neovim config (e.g. ~\/.nvim\/nvimrc). + providerName :: TMVar (Either String Int) + , -- | This 'TVar' is used to generate uniqe function names on the side of + -- /nvim-hs/. This is useful if you don't want to overwrite existing + -- functions or if you create autocmd functions. + uniqueCounter :: TVar Integer + , -- | This map is used to dispatch received messagepack function calls to + -- it's appropriate targets. + globalFunctionMap :: TMVar FunctionMap + , -- Local settings; intialized for each stateful component - , customConfig :: env - -- ^ Plugin author supplyable custom configuration. Queried on the - -- user-facing side with 'ask' or 'asks'. + -- | In a registered functionality this field contains a function (and + -- possibly some context dependent values) to register new functionality. + pluginSettings :: Maybe (PluginSettings env) + , -- | Plugins can dynamically subscribe to events that neovim sends. + subscriptions :: TMVar Subscriptions + , -- | Plugin author supplyable custom configuration. Queried on the + -- user-facing side with 'ask' or 'asks'. + customConfig :: env } +{- | Convenient helper to create a new config for the given state and read-only + config. --- | Convenient helper to create a new config for the given state and read-only --- config. --- --- Sets the 'pluginSettings' field to 'Nothing'. + Sets the 'pluginSettings' field to 'Nothing'. +-} retypeConfig :: env -> Config anotherEnv -> Config env -retypeConfig r cfg = cfg { pluginSettings = Nothing, customConfig = r } - +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. +{- | This GADT is used to share information between stateless and stateful + plugin threads since they work fundamentally in the same way. They both + contain a function to register some functionality in the plugin provider + as well as some values which are specific to the one or the other context. +-} data PluginSettings env where - StatefulSettings - :: (FunctionalityDescription - -> ([Object] -> Neovim env Object) - -> TQueue SomeMessage - -> TVar (Map NvimMethod ([Object] -> Neovim env Object)) - -> Neovim env (Maybe FunctionMapEntry)) - -> TQueue SomeMessage - -> TVar (Map NvimMethod ([Object] -> Neovim env Object)) - -> PluginSettings env + StatefulSettings :: + ( FunctionalityDescription -> + ([Object] -> Neovim env Object) -> + TQueue SomeMessage -> + TVar (Map NvimMethod ([Object] -> Neovim env Object)) -> + Neovim env (Maybe FunctionMapEntry) + ) -> + TQueue SomeMessage -> + TVar (Map NvimMethod ([Object] -> Neovim env Object)) -> + PluginSettings env +{- | Create a new 'InternalConfig' object by providing the minimal amount of + necessary information. --- | Create a new 'InternalConfig' object by providing the minimal amount of --- necessary information. --- --- This function should only be called once per /nvim-hs/ session since the --- arguments are shared across processes. + This function should only be called once per /nvim-hs/ session since the + arguments are shared across processes. +-} newConfig :: IO (Maybe String) -> IO env -> IO (Config env) -newConfig ioProviderName r = Config - <$> newTQueueIO - <*> newEmptyMVar - <*> (maybe (atomically newEmptyTMVar) (newTMVarIO . Left) =<< ioProviderName) - <*> newTVarIO 100 - <*> atomically newEmptyTMVar - <*> pure Nothing - <*> r - +newConfig ioProviderName r = + Config + <$> newTQueueIO + <*> newEmptyMVar + <*> (maybe newEmptyTMVarIO (newTMVarIO . Left) =<< ioProviderName) + <*> newTVarIO 100 + <*> newEmptyTMVarIO + <*> pure Nothing + <*> newTMVarIO (Subscriptions (SubscriptionId 1) mempty) + <*> r -- | The state that the plugin provider wants to transition to. data StateTransition - = Quit - -- ^ Quit the plugin provider. - - | Restart - -- ^ Restart the plugin provider. - - | Failure (Doc AnsiStyle) - -- ^ The plugin provider failed to start or some other error occured. - - | InitSuccess - -- ^ The plugin provider started successfully. - + = -- | Quit the plugin provider. + Quit + | -- | Restart the plugin provider. + Restart + | -- | The plugin provider failed to start or some other error occured. + Failure (Doc AnsiStyle) + | -- | The plugin provider started successfully. + InitSuccess deriving (Show) - diff --git a/library/Neovim/Debug.hs b/library/Neovim/Debug.hs --- a/library/Neovim/Debug.hs +++ b/library/Neovim/Debug.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NamedFieldPuns #-} + {- | Module : Neovim.Debug Description : Utilities to debug Neovim and nvim-hs functionality @@ -8,204 +9,219 @@ Maintainer : woozletoff@gmail.com Stability : experimental Portability : GHC - -} module Neovim.Debug ( debug, debug', - - NvimHSDebugInstance(..), + NvimHSDebugInstance (..), develMain, quitDevelMain, restartDevelMain, - printGlobalFunctionMap, - runNeovim, runNeovim', module Neovim, - ) where +) where -import Neovim -import Neovim.Classes -import Neovim.Context (runNeovim) -import qualified Neovim.Context.Internal as Internal -import Neovim.Log (disableLogger) -import Neovim.Main (CommandLineOptions (..), - runPluginProvider) -import Neovim.RPC.Common (RPCConfig) +import Neovim +import Neovim.Classes +import Neovim.Context (runNeovim) +import qualified Neovim.Context.Internal as Internal +import Neovim.Log (disableLogger) +import Neovim.Main ( + CommandLineOptions (..), + runPluginProvider, + ) +import Neovim.RPC.Common (RPCConfig) -import Control.Monad -import qualified Data.Map as Map -import Foreign.Store +import Control.Monad +import qualified Data.Map as Map +import Foreign.Store -import UnliftIO.Async (Async, async, - cancel) -import UnliftIO.Concurrent (putMVar, takeMVar) -import UnliftIO.STM +import UnliftIO.Async ( + Async, + async, + cancel, + ) +import UnliftIO.Concurrent (putMVar, takeMVar) +import UnliftIO.STM -import Data.Text.Prettyprint.Doc (nest, softline, - vcat, vsep) +import Prettyprinter ( + nest, + softline, + vcat, + vsep, + ) -import Prelude +import Prelude +{- | Run a 'Neovim' function. --- | Run a 'Neovim' function. --- --- This function connects to the socket pointed to by the environment variable --- @$NVIM@ and executes the command. It does not register itself --- as a real plugin provider, you can simply call neovim-functions from the --- module "Neovim.API.String" this way. --- --- Tip: If you run a terminal inside a neovim instance, then this variable is --- automatically set. + This function connects to the socket pointed to by the environment variable + @$NVIM@ and executes the command. It does not register itself + as a real plugin provider, you can simply call neovim-functions from the + module "Neovim.API.String" this way. + + Tip: If you run a terminal inside a neovim instance, then this variable is + automatically set. +-} debug :: env -> Internal.Neovim env a -> IO (Either (Doc AnsiStyle) a) debug env a = disableLogger $ do - runPluginProvider def { envVar = True } Nothing transitionHandler + runPluginProvider def{envVar = True} Nothing transitionHandler where - transitionHandler tids cfg = takeMVar (Internal.transitionTo cfg) >>= \case - Internal.Failure e -> - return $ Left e - - Internal.InitSuccess -> do - res <- Internal.runNeovimInternal - return - (cfg { Internal.customConfig = env, Internal.pluginSettings = Nothing }) - a + transitionHandler tids cfg = + takeMVar (Internal.transitionTo cfg) >>= \case + Internal.Failure e -> + return $ Left e + Internal.InitSuccess -> do + res <- + Internal.runNeovimInternal + return + (cfg{Internal.customConfig = env, Internal.pluginSettings = Nothing}) + a - mapM_ cancel tids - return res + mapM_ cancel tids + return res + _ -> + return . Left $ "Unexpected transition state." - _ -> - return . Left $ "Unexpected transition state." +{- | Run a 'Neovim'' function. + @ + debug' = debug () + @ --- | Run a 'Neovim'' function. --- --- @ --- debug' = debug () --- @ --- --- See documentation for 'debug'. + See documentation for 'debug'. +-} debug' :: Internal.Neovim () a -> IO (Either (Doc AnsiStyle) a) debug' = debug () --- | Simple datatype storing neccessary information to start, stop and reload a --- set of plugins. This is passed to most of the functions in this module for --- storing state even when the ghci-session has been reloaded. +{- | Simple datatype storing neccessary information to start, stop and reload a + set of plugins. This is passed to most of the functions in this module for + storing state even when the ghci-session has been reloaded. +-} data NvimHSDebugInstance = NvimHSDebugInstance - { threads :: [Async ()] - , neovimConfig :: NeovimConfig - , internalConfig :: Internal.Config RPCConfig - } + { threads :: [Async ()] + , neovimConfig :: NeovimConfig + , internalConfig :: Internal.Config RPCConfig + } --- | This function is intended to be run _once_ in a ghci session that to --- give a REPL based workflow when developing a plugin. --- --- Note that the dyre-based reload mechanisms, i.e. the --- "Neovim.Plugin.ConfigHelper" plugin, is not started this way. --- --- To use this in ghci, you simply bind the results to some variables. After --- each reload of ghci, you have to rebind those variables. --- --- Example: --- --- @ --- λ di <- 'develMain' 'Nothing' --- --- λ 'runNeovim'' di \$ vim_call_function \"getqflist\" [] --- 'Right' ('Right' ('ObjectArray' [])) --- --- λ :r --- --- λ di <- 'develMain' 'Nothing' --- @ --- --- You can also create a GHCI alias to get rid of most the busy-work: --- @ --- :def! x \\_ -> return \":reload\\nJust di <- develMain 'defaultConfig'{ 'plugins' = [ myDebugPlugin ] }\" --- @ --- -develMain - :: NeovimConfig - -> IO (Maybe NvimHSDebugInstance) -develMain neovimConfig = lookupStore 0 >>= \case - Nothing -> do - x <- disableLogger $ runPluginProvider - def{ envVar = True } - (Just neovimConfig) - transitionHandler - void $ newStore x - return x +{- | This function is intended to be run _once_ in a ghci session that to + give a REPL based workflow when developing a plugin. - Just x -> - readStore x - where - transitionHandler tids cfg = takeMVar (Internal.transitionTo cfg) >>= \case - Internal.Failure e -> do - putDoc e - return Nothing + Note that the dyre-based reload mechanisms, i.e. the + "Neovim.Plugin.ConfigHelper" plugin, is not started this way. - Internal.InitSuccess -> do - transitionHandlerThread <- async $ do - void $ transitionHandler (tids) cfg - return . Just $ NvimHSDebugInstance - { threads = (transitionHandlerThread:tids) - , neovimConfig = neovimConfig - , internalConfig = cfg - } + To use this in ghci, you simply bind the results to some variables. After + each reload of ghci, you have to rebind those variables. - Internal.Quit -> do - lookupStore 0 >>= \case - Nothing -> - return () + Example: - Just x -> - deleteStore x + @ + λ di <- 'develMain' 'Nothing' - mapM_ cancel tids - putStrLn "Quit develMain" - return Nothing + λ 'runNeovim'' di \$ vim_call_function \"getqflist\" [] + 'Right' ('Right' ('ObjectArray' [])) - _ -> do - putStrLn $ "Unexpected transition state for develMain." - return Nothing + λ :r + λ di <- 'develMain' 'Nothing' + @ + You can also create a GHCI alias to get rid of most the busy-work: + @ + :def! x \\_ -> return \":reload\\nJust di <- develMain 'defaultConfig'{ 'plugins' = [ myDebugPlugin ] }\" + @ +-} +develMain :: + NeovimConfig -> + IO (Maybe NvimHSDebugInstance) +develMain neovimConfig = + lookupStore 0 >>= \case + Nothing -> do + x <- + disableLogger $ + runPluginProvider + def{envVar = True} + (Just neovimConfig) + transitionHandler + void $ newStore x + return x + Just x -> + readStore x + where + transitionHandler tids cfg = + takeMVar (Internal.transitionTo cfg) >>= \case + Internal.Failure e -> do + putDoc e + return Nothing + Internal.InitSuccess -> do + transitionHandlerThread <- async $ do + void $ transitionHandler (tids) cfg + return . Just $ + NvimHSDebugInstance + { threads = (transitionHandlerThread : tids) + , neovimConfig = neovimConfig + , internalConfig = cfg + } + Internal.Quit -> do + lookupStore 0 >>= \case + Nothing -> + return () + Just x -> + deleteStore x + + mapM_ cancel tids + putStrLn "Quit develMain" + return Nothing + _ -> do + putStrLn $ "Unexpected transition state for develMain." + return Nothing + -- | Quit a previously started plugin provider. quitDevelMain :: NvimHSDebugInstance -> IO () quitDevelMain NvimHSDebugInstance{internalConfig} = - putMVar (Internal.transitionTo internalConfig) Internal.Quit - + putMVar (Internal.transitionTo internalConfig) Internal.Quit -- | Restart the development plugin provider. -restartDevelMain - :: NvimHSDebugInstance - -> IO (Maybe NvimHSDebugInstance) +restartDevelMain :: + NvimHSDebugInstance -> + IO (Maybe NvimHSDebugInstance) restartDevelMain di = do quitDevelMain di develMain (neovimConfig di) - -- | Convenience function to run a stateless 'Neovim' function. -runNeovim' :: NFData a - => NvimHSDebugInstance -> Neovim () a -> IO (Either (Doc AnsiStyle) a) +runNeovim' :: + NFData a => + NvimHSDebugInstance -> + Neovim () a -> + IO (Either (Doc AnsiStyle) a) runNeovim' NvimHSDebugInstance{internalConfig} = runNeovim (Internal.retypeConfig () (internalConfig)) - -- | Print the global function map to the console. printGlobalFunctionMap :: NvimHSDebugInstance -> IO () printGlobalFunctionMap NvimHSDebugInstance{internalConfig} = do - es <- fmap Map.toList . atomically $ + es <- + fmap Map.toList . atomically $ readTMVar (Internal.globalFunctionMap internalConfig) let header = "Printing global function map:" - funs = map (\(fname, (d, f)) -> - nest 3 (pretty fname - <> softline <> "->" - <> softline <> pretty d <+> ":" - <+> pretty f)) es + funs = + map + ( \(fname, (d, f)) -> + nest + 3 + ( pretty fname + <> softline + <> "->" + <> softline + <> pretty d + <+> ":" + <+> pretty f + ) + ) + es putDoc $ - nest 2 $ vsep [header, vcat funs, mempty] - - + nest 2 $ + vsep [header, vcat funs, mempty] diff --git a/library/Neovim/Exceptions.hs b/library/Neovim/Exceptions.hs --- a/library/Neovim/Exceptions.hs +++ b/library/Neovim/Exceptions.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveDataTypeable #-} + {- | Module : Neovim.Exceptions Description : General Exceptions @@ -8,45 +9,40 @@ Maintainer : woozletoff@gmail.com Stability : experimental Portability : GHC - -} -module Neovim.Exceptions - ( NeovimException(..) - , exceptionToDoc - , catchNeovimException - ) where +module Neovim.Exceptions ( + NeovimException (..), + exceptionToDoc, + catchNeovimException, +) where -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) -import UnliftIO (MonadUnliftIO, catch) +import Control.Exception (Exception) +import Data.MessagePack (Object (..)) +import Data.String (IsString (..)) +import Data.Typeable (Typeable) +import Prettyprinter (Doc, viaShow, (<+>)) +import Prettyprinter.Render.Terminal (AnsiStyle) +import UnliftIO (MonadUnliftIO, catch) -- | Exceptions specific to /nvim-hs/. data NeovimException - = ErrorMessage (Doc AnsiStyle) - -- ^ Simple error message that is passed to neovim. It should currently only - -- contain one line of text. - | ErrorResult (Doc AnsiStyle) Object - -- ^ Error that can be returned by a remote API call. The 'Doc' argument is - -- the name of the remote function that threw this exception. + = -- | Simple error message that is passed to neovim. It should currently only + -- contain one line of text. + ErrorMessage (Doc AnsiStyle) + | -- | Error that can be returned by a remote API call. The 'Doc' argument is + -- the name of the remote function that threw this exception. + ErrorResult (Doc AnsiStyle) Object deriving (Typeable, Show) - instance Exception NeovimException - instance IsString NeovimException where fromString = ErrorMessage . fromString - exceptionToDoc :: NeovimException -> Doc AnsiStyle exceptionToDoc = \case ErrorMessage e -> "Error message:" <+> e - ErrorResult fn o -> "Function" <+> fn <+> "has thrown an error:" <+> viaShow o diff --git a/library/Neovim/Log.hs b/library/Neovim/Log.hs --- a/library/Neovim/Log.hs +++ b/library/Neovim/Log.hs @@ -7,20 +7,18 @@ Maintainer : woozletoff@gmail.com Stability : experimental Portability : GHC - -} module Neovim.Log ( disableLogger, withLogger, - module System.Log.Logger, - ) where +) where -import Control.Exception -import System.Log.Formatter (simpleLogFormatter) -import System.Log.Handler (setFormatter) -import System.Log.Handler.Simple -import System.Log.Logger +import Control.Exception +import System.Log.Formatter (simpleLogFormatter) +import System.Log.Handler (setFormatter) +import System.Log.Handler.Simple +import System.Log.Logger -- | Disable logging to stderr. disableLogger :: IO a -> IO a @@ -28,19 +26,21 @@ updateGlobalLogger rootLoggerName removeHandler action --- | Initialize the root logger to avoid stderr and set it to log the given --- file instead. Simply wrap the main entry point with this function to --- initialze the logger. --- --- @ --- main = 'withLogger' "\/home\/dude\/nvim.log" 'Debug' \$ do --- 'putStrLn' "Hello, World!" --- @ +{- | Initialize the root logger to avoid stderr and set it to log the given + file instead. Simply wrap the main entry point with this function to + initialze the logger. + + @ + main = 'withLogger' "\/home\/dude\/nvim.log" 'Debug' \$ do + 'putStrLn' "Hello, World!" + @ +-} withLogger :: FilePath -> Priority -> IO a -> IO a -withLogger fp p action = bracket - setupRootLogger - (\fh -> closeFunc fh (privData fh)) - (const action) +withLogger fp p action = + bracket + setupRootLogger + (\fh -> closeFunc fh (privData fh)) + (const action) where setupRootLogger = do -- We shouldn't log to stderr or stdout as it is not unlikely that our @@ -56,5 +56,3 @@ logM "Neovim.Debug" DEBUG $ unwords ["Initialized root looger with priority", show p, "and file: ", fp] return fh' - - diff --git a/library/Neovim/Main.hs b/library/Neovim/Main.hs --- a/library/Neovim/Main.hs +++ b/library/Neovim/Main.hs @@ -6,167 +6,183 @@ Maintainer : woozletoff@gmail.com Stability : experimental - -} -module Neovim.Main - where +module Neovim.Main where -import Neovim.Config +import Neovim.Config import qualified Neovim.Context.Internal as Internal -import Neovim.Log -import qualified Neovim.Plugin as P -import Neovim.RPC.Common as RPC -import Neovim.RPC.EventHandler -import Neovim.RPC.SocketReader -import Neovim.Util (oneLineErrorMessage) +import Neovim.Log +import qualified Neovim.Plugin as P +import Neovim.RPC.Common as RPC +import Neovim.RPC.EventHandler +import Neovim.RPC.SocketReader +import Neovim.Util (oneLineErrorMessage) -import Control.Concurrent -import Control.Concurrent.STM (atomically, putTMVar) -import Control.Monad -import Data.Default -import Data.Maybe -import Data.Monoid -import Options.Applicative -import System.IO (stdin, stdout) -import UnliftIO.Async (Async, async) +import Control.Concurrent +import Control.Concurrent.STM (atomically, putTMVar) +import Control.Monad +import Data.Default +import Data.Maybe +import Data.Monoid +import Options.Applicative +import System.IO (stdin, stdout) +import UnliftIO.Async (Async, async) import Prelude - logger :: String logger = "Neovim.Main" - -data CommandLineOptions = - Opt { providerName :: Maybe String - , hostPort :: Maybe (String, Int) - , unix :: Maybe FilePath - , envVar :: Bool - , logOpts :: Maybe (FilePath, Priority) - } - +data CommandLineOptions = Opt + { providerName :: Maybe String + , hostPort :: Maybe (String, Int) + , unix :: Maybe FilePath + , envVar :: Bool + , logOpts :: Maybe (FilePath, Priority) + } instance Default CommandLineOptions where - def = Opt + def = + Opt { providerName = Nothing - , hostPort = Nothing - , unix = Nothing - , envVar = False - , logOpts = Nothing + , hostPort = Nothing + , unix = Nothing + , envVar = False + , logOpts = Nothing } - optParser :: Parser CommandLineOptions -optParser = Opt - <$> optional (strArgument - (metavar "NAME" - <> help (unlines - [ "Name that associates the plugin provider with neovim." - , "This option has only an effect if you start nvim-hs" - , "with rpcstart()/jobstart() and use the factory method approach." - , "Since it is extremely hard to figure that out inside" - , "nvim-hs, this option is assumed to used if the input" - , "and output is tied to standard in and standard out." - ]))) - <*> optional ((,) - <$> strOption - (long "host" - <> short 'a' - <> metavar "HOSTNAME" - <> help "Connect to the specified host. (requires -p)") - <*> option auto - (long "port" - <> short 'p' - <> metavar "PORT" - <> help "Connect to the specified port. (requires -a)")) - <*> optional (strOption - (long "unix" - <> short 'u' - <> help "Connect to the given unix domain socket.")) - <*> switch - ( long "environment" - <> short 'e' - <> help "Read connection information from $NVIM.") - <*> optional ((,) - <$> strOption - (long "log-file" - <> short 'l' - <> help "File to log to.") - <*> option auto - (long "log-level" - <> short 'v' - <> help ("Log level. Must be one of: " ++ (unwords . map show) logLevels))) +optParser = + Opt + <$> optional + ( strArgument + ( metavar "NAME" + <> help + ( unlines + [ "Name that associates the plugin provider with neovim." + , "This option has only an effect if you start nvim-hs" + , "with rpcstart()/jobstart() and use the factory method approach." + , "Since it is extremely hard to figure that out inside" + , "nvim-hs, this option is assumed to used if the input" + , "and output is tied to standard in and standard out." + ] + ) + ) + ) + <*> optional + ( (,) + <$> strOption + ( long "host" + <> short 'a' + <> metavar "HOSTNAME" + <> help "Connect to the specified host. (requires -p)" + ) + <*> option + auto + ( long "port" + <> short 'p' + <> metavar "PORT" + <> help "Connect to the specified port. (requires -a)" + ) + ) + <*> optional + ( strOption + ( long "unix" + <> short 'u' + <> help "Connect to the given unix domain socket." + ) + ) + <*> switch + ( long "environment" + <> short 'e' + <> help "Read connection information from $NVIM." + ) + <*> optional + ( (,) + <$> strOption + ( long "log-file" + <> short 'l' + <> help "File to log to." + ) + <*> option + auto + ( long "log-level" + <> short 'v' + <> help ("Log level. Must be one of: " ++ (unwords . map show) logLevels) + ) + ) where -- [minBound..maxBound] would have been nice here. logLevels :: [Priority] - logLevels = [ DEBUG, INFO, NOTICE, WARNING, ERROR, CRITICAL, ALERT, EMERGENCY ] - + logLevels = [DEBUG, INFO, NOTICE, WARNING, ERROR, CRITICAL, ALERT, EMERGENCY] opts :: ParserInfo CommandLineOptions -opts = info (helper <*> optParser) - (fullDesc - <> header "Start a neovim plugin provider for Haskell plugins." - <> progDesc "This is still work in progress. Feel free to contribute.") - +opts = + info + (helper <*> optParser) + ( fullDesc + <> header "Start a neovim plugin provider for Haskell plugins." + <> progDesc "This is still work in progress. Feel free to contribute." + ) --- | This is essentially the main function for /nvim-hs/, at least if you want --- to use "Config.Dyre" for the configuration. +{- | This is essentially the main function for /nvim-hs/, at least if you want + to use "Config.Dyre" for the configuration. +-} neovim :: NeovimConfig -> IO () neovim = realMain standalone - --- | A 'TransitionHandler' function receives the 'ThreadId's of all running --- threads which have been started by the plugin provider as well as the --- 'Internal.Config' with the custom field set to 'RPCConfig'. These information --- can be used to properly clean up a session and then do something else. --- The transition handler is first called after the plugin provider has started. +{- | A 'TransitionHandler' function receives the 'ThreadId's of all running + threads which have been started by the plugin provider as well as the + 'Internal.Config' with the custom field set to 'RPCConfig'. These information + can be used to properly clean up a session and then do something else. + The transition handler is first called after the plugin provider has started. +-} type TransitionHandler a = [Async ()] -> Internal.Config RPCConfig -> IO a - --- | This main functions can be used to create a custom executable without --- using the "Config.Dyre" library while still using the /nvim-hs/ specific --- configuration facilities. -realMain :: TransitionHandler a - -> NeovimConfig - -> IO () +{- | This main functions can be used to create a custom executable without + using the "Config.Dyre" library while still using the /nvim-hs/ specific + configuration facilities. +-} +realMain :: + TransitionHandler a -> + NeovimConfig -> + IO () realMain transitionHandler cfg = do os <- execParser opts maybe disableLogger (uncurry withLogger) (logOpts os <|> logOptions cfg) $ do debugM logger "Starting up neovim haskell plguin provider" void $ runPluginProvider os (Just cfg) transitionHandler - -- | Generic main function. Most arguments are optional or have sane defaults. -runPluginProvider - :: CommandLineOptions -- ^ See /nvim-hs/ executables --help function or 'optParser' - -> Maybe NeovimConfig - -> TransitionHandler a - -> IO a +runPluginProvider :: + -- | See /nvim-hs/ executables --help function or 'optParser' + CommandLineOptions -> + Maybe NeovimConfig -> + TransitionHandler a -> + IO a runPluginProvider os mcfg transitionHandler = case (hostPort os, unix os) of - (Just (h,p), _) -> + (Just (h, p), _) -> createHandle (TCP p h) >>= \s -> run s s - (_, Just fp) -> createHandle (UnixSocket fp) >>= \s -> run s s - - _ | envVar os -> - createHandle Environment >>= \s -> run s s - + _ + | envVar os -> + createHandle Environment >>= \s -> run s s _ -> run stdout stdin - where run evHandlerHandle sockreaderHandle = do - -- The plugins to register depend on the given arguments and may need -- special initialization methods. let allPlugins = maybe [] plugins mcfg conf <- Internal.newConfig (pure (providerName os)) newRPCConfig - ehTid <- async $ runEventHandler - evHandlerHandle - conf { Internal.pluginSettings = Nothing } + ehTid <- + async $ + runEventHandler + evHandlerHandle + conf{Internal.pluginSettings = Nothing} srTid <- async $ runSocketReader sockreaderHandle conf @@ -176,28 +192,24 @@ errorM logger $ "Error initializing plugins: " <> show (oneLineErrorMessage e) putMVar (Internal.transitionTo conf) $ Internal.Failure e transitionHandler [ehTid, srTid] conf - Right (funMapEntries, pluginTids) -> do - atomically $ putTMVar - (Internal.globalFunctionMap conf) - (Internal.mkFunctionMap funMapEntries) + atomically $ + putTMVar + (Internal.globalFunctionMap conf) + (Internal.mkFunctionMap funMapEntries) putMVar (Internal.transitionTo conf) $ Internal.InitSuccess - transitionHandler (srTid:ehTid:pluginTids) conf - + transitionHandler (srTid : ehTid : pluginTids) conf standalone :: TransitionHandler () -standalone threads cfg = takeMVar (Internal.transitionTo cfg) >>= \case - Internal.InitSuccess -> do - debugM logger "Initialization Successful" - standalone threads cfg - - Internal.Restart -> do - errorM logger "Cannot restart" - standalone threads cfg - - Internal.Failure e -> - errorM logger . show $ oneLineErrorMessage e - - Internal.Quit -> - return () - +standalone threads cfg = + takeMVar (Internal.transitionTo cfg) >>= \case + Internal.InitSuccess -> do + debugM logger "Initialization Successful" + standalone threads cfg + Internal.Restart -> do + errorM logger "Cannot restart" + standalone threads cfg + Internal.Failure e -> + errorM logger . show $ oneLineErrorMessage e + Internal.Quit -> + return () diff --git a/library/Neovim/Plugin.hs b/library/Neovim/Plugin.hs --- a/library/Neovim/Plugin.hs +++ b/library/Neovim/Plugin.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE GADTs #-} + {- | Module : Neovim.Plugin Description : Plugin and functionality registration code @@ -9,83 +9,82 @@ Maintainer : woozletoff@gmail.com Stability : experimental Portability : GHC - -} - module Neovim.Plugin ( startPluginThreads, wrapPlugin, NeovimPlugin, - Plugin(..), - Synchronous(..), - CommandOption(..), - + Plugin (..), + Synchronous (..), + CommandOption (..), addAutocmd, - registerPlugin, - ) where - -import Neovim.API.String -import Neovim.Classes -import Neovim.Context -import Neovim.Context.Internal (FunctionType (..), - runNeovimInternal) -import qualified Neovim.Context.Internal as Internal -import Neovim.Plugin.Classes hiding (register) -import Neovim.Plugin.Internal -import Neovim.Plugin.IPC.Classes -import Neovim.RPC.FunctionCall +) where -import Control.Applicative -import Control.Monad (foldM, void) -import Control.Monad.Trans.Resource hiding (register) -import Data.ByteString (ByteString) -import Data.Foldable (forM_) -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Maybe (catMaybes) -import Data.MessagePack -import Data.Traversable (forM) -import System.Log.Logger -import UnliftIO.Async (Async, async, race) -import UnliftIO.Concurrent (threadDelay) -import UnliftIO.Exception (SomeException, try, catch) -import UnliftIO.STM +import Neovim.API.String +import Neovim.Classes +import Neovim.Context +import Neovim.Context.Internal ( + FunctionType (..), + runNeovimInternal, + ) +import qualified Neovim.Context.Internal as Internal +import Neovim.Plugin.Classes hiding (register) +import Neovim.Plugin.IPC.Classes +import Neovim.Plugin.Internal +import Neovim.RPC.FunctionCall -import Prelude +import Control.Applicative +import Control.Monad (foldM, void) +import Control.Monad.Trans.Resource hiding (register) +import Data.ByteString (ByteString) +import Data.Foldable (forM_) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe (catMaybes) +import Data.MessagePack +import Data.Traversable (forM) +import System.Log.Logger +import UnliftIO.Async (Async, async, race) +import UnliftIO.Concurrent (threadDelay) +import UnliftIO.Exception (SomeException, catch, try) +import UnliftIO.STM +import Prelude logger :: String logger = "Neovim.Plugin" - -startPluginThreads :: Internal.Config () - -> [Neovim () NeovimPlugin] - -> IO (Either (Doc AnsiStyle) ([FunctionMapEntry],[Async ()])) +startPluginThreads :: + Internal.Config () -> + [Neovim () NeovimPlugin] -> + IO (Either (Doc AnsiStyle) ([FunctionMapEntry], [Async ()])) startPluginThreads cfg = runNeovimInternal return cfg . foldM go ([], []) where - go :: ([FunctionMapEntry], [Async ()]) - -> Neovim () NeovimPlugin - -> Neovim () ([FunctionMapEntry], [Async ()]) + go :: + ([FunctionMapEntry], [Async ()]) -> + Neovim () NeovimPlugin -> + Neovim () ([FunctionMapEntry], [Async ()]) go (es, tids) iop = do NeovimPlugin p <- iop (es', tid) <- registerStatefulFunctionality p - return $ (es ++ es', tid: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. --- | 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/. + Note that this does not have any effect on the side of /nvim-hs/. +-} registerWithNeovim :: FunctionalityDescription -> Neovim anyEnv Bool registerWithNeovim = \case func@(Function (F functionName) s) -> do pName <- getProviderName - let (defineFunction, host) = either - (\n -> ("remote#define#FunctionOnHost", toObject n)) - (\c -> ("remote#define#FunctionOnChannel", toObject c)) - pName + let (defineFunction, host) = + either + (\n -> ("remote#define#FunctionOnHost", toObject n)) + (\c -> ("remote#define#FunctionOnChannel", toObject c)) + pName reportError (e :: NeovimException) = do liftIO . errorM logger $ "Failed to register function: " ++ show functionName ++ show e @@ -96,22 +95,23 @@ return True flip catch reportError $ do - void $ vim_call_function defineFunction $ - host +: nvimMethodName (nvimMethod func) +: s +: functionName +: (Map.empty :: Dictionary) +: [] - logSuccess - + void $ + vim_call_function defineFunction $ + host +: nvimMethodName (nvimMethod func) +: s +: functionName +: (Map.empty :: Dictionary) +: [] + logSuccess cmd@(Command (F functionName) copts) -> do let sync = case getCommandOptions copts of - -- This works because CommandOptions are sorted and CmdSync is - -- the smallest element in the sorting - (CmdSync s:_) -> s - _ -> Sync + -- This works because CommandOptions are sorted and CmdSync is + -- the smallest element in the sorting + (CmdSync s : _) -> s + _ -> Sync pName <- getProviderName - let (defineFunction, host) = either - (\n -> ("remote#define#CommandOnHost", toObject n)) - (\c -> ("remote#define#CommandOnChannel", toObject c)) - pName + let (defineFunction, host) = + either + (\n -> ("remote#define#CommandOnHost", toObject n)) + (\c -> ("remote#define#CommandOnChannel", toObject c)) + pName reportError (e :: NeovimException) = do liftIO . errorM logger $ "Failed to register command: " ++ show functionName ++ show e @@ -121,16 +121,17 @@ "Registered command: " ++ show functionName return True flip catch reportError $ do - void $ vim_call_function defineFunction $ - host +: nvimMethodName (nvimMethod cmd) +: sync +: functionName +: copts +: [] - logSuccess - + void $ + vim_call_function defineFunction $ + host +: nvimMethodName (nvimMethod cmd) +: sync +: functionName +: copts +: [] + logSuccess Autocmd acmdType (F functionName) sync opts -> do pName <- getProviderName - let (defineFunction, host) = either - (\n -> ("remote#define#AutocmdOnHost", toObject n)) - (\c -> ("remote#define#AutocmdOnChannel", toObject c)) - pName + let (defineFunction, host) = + either + (\n -> ("remote#define#AutocmdOnHost", toObject n)) + (\c -> ("remote#define#AutocmdOnChannel", toObject c)) + pName reportError (e :: NeovimException) = do liftIO . errorM logger $ "Failed to register autocmd: " ++ show functionName ++ show e @@ -140,68 +141,63 @@ "Registered autocmd: " ++ show functionName return True flip catch reportError $ do - void $ vim_call_function defineFunction $ - host +: functionName +: sync +: acmdType +: opts +: [] - logSuccess - + void $ + vim_call_function defineFunction $ + host +: functionName +: sync +: acmdType +: opts +: [] + logSuccess --- | Return or retrive the provider name that the current instance is associated --- with on the neovim side. +{- | Return or retrive the provider name that the current instance is associated + with on the neovim side. +-} getProviderName :: Neovim env (Either String Int) getProviderName = do mp <- Internal.asks' Internal.providerName (liftIO . atomically . tryReadTMVar) mp >>= \case Just p -> return p - Nothing -> do api <- nvim_get_api_info case api of [] -> err "empty nvim_get_api_info" - (i:_) -> do + (i : _) -> do case fromObject i :: Either (Doc AnsiStyle) Int of - Left _ -> - err $ "Expected an integral value as the first" - <+> "argument of nvim_get_api_info" - Right channelId -> do - liftIO . atomically . putTMVar mp . Right $ fromIntegral channelId - return . Right $ fromIntegral channelId - - -registerFunctionality :: FunctionalityDescription - -> ([Object] -> Neovim env Object) - -> Neovim env (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.StatefulSettings reg q m) -> - reg d f q m >>= \case - Just e -> do - -- Redefine fields so that it gains a new type - cfg <- Internal.retypeConfig () <$> Internal.ask' - rk <- fst <$> allocate (return ()) (free cfg (fst e)) - return $ Just (e, Right rk) - - Nothing -> - return Nothing + Left _ -> + err $ + "Expected an integral value as the first" + <+> "argument of nvim_get_api_info" + Right channelId -> do + liftIO . atomically . putTMVar mp . Right $ fromIntegral channelId + return . Right $ fromIntegral channelId +registerFunctionality :: + FunctionalityDescription -> + ([Object] -> Neovim env Object) -> + Neovim env (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.StatefulSettings reg q m) -> + reg d f q m >>= \case + Just e -> do + -- Redefine fields so that it gains a new type + cfg <- Internal.retypeConfig () <$> Internal.ask' + rk <- fst <$> allocate (return ()) (free cfg (fst e)) + return $ Just (e, Right rk) + Nothing -> + return Nothing where freeFun = \case Autocmd _ _ _ AutocmdOptions{} -> do liftIO $ warningM logger "Free not implemented for autocmds." - Command{} -> liftIO $ warningM logger "Free not implemented for commands." - Function{} -> liftIO $ warningM logger "Free not implemented for functions." - free cfg fd _ = void . runNeovimInternal return cfg $ freeFun fd - registerInGlobalFunctionMap :: FunctionMapEntry -> Neovim env () registerInGlobalFunctionMap e = do liftIO . debugM logger $ "Adding function to global function map." ++ show (fst e) @@ -211,123 +207,128 @@ putTMVar funMap $ Map.insert ((nvimMethod . fst) e) e m liftIO . debugM logger $ "Added function to global function map." ++ show (fst e) -registerPlugin - :: (FunctionMapEntry -> Neovim env ()) - -> FunctionalityDescription - -> ([Object] -> Neovim env Object) - -> TQueue SomeMessage - -> TVar (Map NvimMethod ([Object] -> Neovim env Object)) - -> Neovim env (Maybe FunctionMapEntry) -registerPlugin reg d f q tm = registerWithNeovim d >>= \case - True -> do - let n = nvimMethod d - e = (d, Stateful q) - liftIO . atomically . modifyTVar tm $ Map.insert n f - reg e - return (Just e) - - False -> - return Nothing +registerPlugin :: + (FunctionMapEntry -> Neovim env ()) -> + FunctionalityDescription -> + ([Object] -> Neovim env Object) -> + TQueue SomeMessage -> + TVar (Map NvimMethod ([Object] -> Neovim env Object)) -> + Neovim env (Maybe FunctionMapEntry) +registerPlugin reg d f q tm = + registerWithNeovim d >>= \case + True -> do + let n = nvimMethod d + e = (d, Stateful q) + liftIO . atomically . modifyTVar tm $ Map.insert n f + reg e + return (Just e) + False -> + return Nothing +{- | Register an autocmd in the current context. This means that, if you are + currently in a stateful plugin, the function will be called in the current + thread and has access to the configuration and state of this thread. . --- | Register an autocmd in the current context. This means that, if you are --- currently in a stateful plugin, the function will be called in the current --- thread and has access to the configuration and state of this thread. . --- --- Note that the function you pass must be fully applied. --- -addAutocmd :: ByteString - -- ^ The event to register to (e.g. BufWritePost) - -> Synchronous - -> AutocmdOptions - -> (Neovim env ()) - -- ^ Fully applied function to register - -> Neovim env (Maybe (Either (Neovim anyEnv ()) ReleaseKey)) - -- ^ A 'ReleaseKey' if the registration worked + Note that the function you pass must be fully applied. +-} +addAutocmd :: + -- | The event to register to (e.g. BufWritePost) + ByteString -> + Synchronous -> + AutocmdOptions -> + -- | Fully applied function to register + (Neovim env ()) -> + -- | A 'ReleaseKey' if the registration worked + Neovim env (Maybe (Either (Neovim anyEnv ()) ReleaseKey)) addAutocmd event s (opts@AutocmdOptions{}) f = do n <- newUniqueFunctionName fmap snd <$> registerFunctionality (Autocmd event n s opts) (\_ -> toObject <$> f) - --- | Create a listening thread for events and add update the 'FunctionMap' with --- the corresponding 'TQueue's (i.e. communication channels). -registerStatefulFunctionality - :: Plugin env - -> Neovim anyEnv ([FunctionMapEntry], Async ()) -registerStatefulFunctionality (Plugin { environment = env, exports = fs }) = do +{- | Create a listening thread for events and add update the 'FunctionMap' with + the corresponding 'TQueue's (i.e. communication channels). +-} +registerStatefulFunctionality :: + Plugin env -> + Neovim anyEnv ([FunctionMapEntry], Async ()) +registerStatefulFunctionality (Plugin{environment = env, exports = fs}) = do messageQueue <- liftIO newTQueueIO route <- liftIO $ newTVarIO Map.empty + subscribers <- liftIO $ newTVarIO [] cfg <- Internal.ask' - let startupConfig = cfg - { Internal.customConfig = env - , Internal.pluginSettings = Just $ Internal.StatefulSettings - (registerPlugin (\_ -> return ())) messageQueue route - } + let startupConfig = + cfg + { Internal.customConfig = env + , Internal.pluginSettings = + Just $ + Internal.StatefulSettings + (registerPlugin (\_ -> return ())) + messageQueue + route + } res <- liftIO . runNeovimInternal return startupConfig . forM fs $ \f -> - registerFunctionality (getDescription f) (getFunction f) + registerFunctionality (getDescription f) (getFunction f) es <- case res of - Left e -> err e + Left e -> err e Right a -> return $ catMaybes a - let pluginThreadConfig = cfg - { Internal.customConfig = env - , Internal.pluginSettings = Just $ Internal.StatefulSettings - (registerPlugin registerInGlobalFunctionMap) messageQueue route - } + let pluginThreadConfig = + cfg + { Internal.customConfig = env + , Internal.pluginSettings = + Just $ + Internal.StatefulSettings + (registerPlugin registerInGlobalFunctionMap) + messageQueue + route + } tid <- liftIO . async . void . runNeovim pluginThreadConfig $ do - listeningThread messageQueue route + listeningThread messageQueue route subscribers return (map fst es, tid) -- NB: dropping release functions/keys here - - where - executeFunction - :: ([Object] -> Neovim env Object) - -> [Object] - -> Neovim env (Either String Object) - executeFunction f args = try (f args) >>= \case + executeFunction :: + ([Object] -> Neovim env Object) -> + [Object] -> + Neovim env (Either String Object) + executeFunction f args = + try (f args) >>= \case Left e -> return . Left $ show (e :: SomeException) Right res -> return $ Right res - timeoutAndLog :: Word -> FunctionName -> Neovim anyEnv String + killAfterSeconds :: Word -> Neovim anyEnv () + killAfterSeconds seconds = threadDelay (fromIntegral seconds * 1000 * 1000) + + timeoutAndLog :: Word -> FunctionName -> Neovim anyEnv String timeoutAndLog seconds functionName = do - threadDelay (fromIntegral seconds * 1000 * 1000) + killAfterSeconds seconds return . show $ pretty functionName <+> "has been aborted after" - <+> pretty seconds <+> "seconds" - + <+> pretty seconds + <+> "seconds" - listeningThread :: TQueue SomeMessage - -> TVar (Map NvimMethod ([Object] -> Neovim env Object)) - -> Neovim env () - listeningThread q route = do + listeningThread :: + TQueue SomeMessage -> + TVar (Map NvimMethod ([Object] -> Neovim env Object)) -> + TVar [Notification -> Neovim env ()] -> + Neovim env () + listeningThread q route subscribers = do msg <- readSomeMessage q forM_ (fromMessage msg) $ \req@(Request fun@(F methodName) _ args) -> do let method = NvimMethod methodName route' <- liftIO $ readTVarIO route forM_ (Map.lookup method route') $ \f -> do - respond req . either Left id =<< race - (timeoutAndLog 10 fun) - (executeFunction f args) - - forM_ (fromMessage msg) $ \(Notification fun@(F methodName) args) -> do - let method = NvimMethod methodName - route' <- liftIO $ readTVarIO route - forM_ (Map.lookup method route') $ \f -> - void . async $ do - result <- either Left id <$> race - (timeoutAndLog 600 fun) + respond req . either Left id + =<< race + (timeoutAndLog 10 fun) (executeFunction f args) - case result of - Left message -> - nvim_err_writeln message - Right _ -> - return () - - listeningThread q route + forM_ (fromMessage msg) $ \notification -> do + subscribers' <- liftIO $ readTVarIO subscribers + forM_ subscribers' $ \subscriber -> + async $ void $ race (subscriber notification) (killAfterSeconds 10) + listeningThread q route subscribers diff --git a/library/Neovim/Plugin/Classes.hs b/library/Neovim/Plugin/Classes.hs --- a/library/Neovim/Plugin/Classes.hs +++ b/library/Neovim/Plugin/Classes.hs @@ -1,5 +1,7 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE RecordWildCards #-} + {- | Module : Neovim.Plugin.Classes Description : Classes and data types related to plugins @@ -9,121 +11,130 @@ Maintainer : woozletoff@gmail.com Stability : experimental Portability : GHC - -} module Neovim.Plugin.Classes ( - FunctionalityDescription(..), - FunctionName(..), - NvimMethod(..), - Synchronous(..), - CommandOption(..), + FunctionalityDescription (..), + FunctionName (..), + NeovimEventId (..), + SubscriptionId (..), + Subscription (..), + NvimMethod (..), + Synchronous (..), + CommandOption (..), CommandOptions, - RangeSpecification(..), - CommandArguments(..), + RangeSpecification (..), + CommandArguments (..), getCommandOptions, mkCommandOptions, - AutocmdOptions(..), - HasFunctionName(..), - ) where - -import Neovim.Classes + AutocmdOptions (..), + HasFunctionName (..), +) where -import Control.Applicative hiding (empty) -import Control.Monad.Error.Class -import Data.ByteString (ByteString) -import Data.Char (isDigit) -import Data.Default -import Data.List (groupBy, sort) -import qualified Data.Map as Map -import Data.Maybe -import Data.MessagePack -import Data.String -import Data.Traversable (sequence) -import Data.Text.Encoding (decodeUtf8) +import Neovim.Classes -import Data.Text.Prettyprint.Doc +import Control.Applicative hiding (empty) +import Control.Monad.Error.Class +import Data.ByteString (ByteString) +import Data.Char (isDigit) +import Data.Default +import Data.List (groupBy, sort) +import qualified Data.Map as Map +import Data.Maybe +import Data.MessagePack +import Data.String +import Data.Text (Text) +import Data.Text.Encoding (decodeUtf8) -import Prelude hiding (sequence) +import Prettyprinter +import Prelude hiding (sequence) -- | Essentially just a string. newtype FunctionName = F ByteString deriving (Eq, Ord, Show, Read, Generic) - - -instance NFData FunctionName - + deriving (NFData) via ByteString instance Pretty FunctionName where pretty (F n) = pretty $ decodeUtf8 n +newtype NeovimEventId = NeovimEventId Text + deriving (Eq, Ord, Show, Read, Generic) + deriving (Pretty) via Text + deriving (NFData) via Text --- | Functionality specific functional description entries. --- --- All fields which are directly specified in these constructors are not --- optional, but can partialy be generated via the Template Haskell functions. --- The last field is a data type that contains all relevant options with --- sensible defaults, hence 'def' can be used as an argument. -data FunctionalityDescription - = Function FunctionName Synchronous - -- ^ Exported function. Callable via @call name(arg1,arg2)@. - -- - -- * Name of the function (must start with an uppercase letter) - -- * Option to indicate how neovim should behave when calling this function +instance NvimObject NeovimEventId where + toObject (NeovimEventId e) = toObject e + fromObject o = NeovimEventId <$> fromObject o - | Command FunctionName CommandOptions - -- ^ Exported Command. Callable via @:Name arg1 arg2@. - -- - -- * Name of the command (must start with an uppercase letter) - -- * Options to configure neovim's behavior for calling the command +newtype SubscriptionId = SubscriptionId Int64 + deriving (Eq, Ord, Show, Read) + deriving (Enum) via Int64 - | Autocmd ByteString FunctionName Synchronous AutocmdOptions - -- ^ Exported autocommand. Will call the given function if the type and - -- filter match. - -- - -- NB: Since we are registering this on the Haskell side of things, the - -- number of accepted arguments should be 0. - -- - -- * Type of the autocmd (e.g. \"BufWritePost\") - -- * Name for the function to call - -- * Whether to use rpcrequest or rpcnotify - -- * Options for the autocmd (use 'def' here if you don't want to change anything) +data Subscription = Subscription + { subId :: SubscriptionId + , subEventId :: NeovimEventId + , subAction :: [Object] -> IO () + } - deriving (Show, Read, Eq, Ord, Generic) +{- | Functionality specific functional description entries. + All fields which are directly specified in these constructors are not + optional, but can partialy be generated via the Template Haskell functions. + The last field is a data type that contains all relevant options with + sensible defaults, hence 'def' can be used as an argument. +-} +data FunctionalityDescription + = -- | Exported function. Callable via @call name(arg1,arg2)@. + -- + -- * Name of the function (must start with an uppercase letter) + -- * Option to indicate how neovim should behave when calling this function + Function FunctionName Synchronous + | -- | Exported Command. Callable via @:Name arg1 arg2@. + -- + -- * Name of the command (must start with an uppercase letter) + -- * Options to configure neovim's behavior for calling the command + Command FunctionName CommandOptions + | -- | Exported autocommand. Will call the given function if the type and + -- filter match. + -- + -- NB: Since we are registering this on the Haskell side of things, the + -- number of accepted arguments should be 0. + -- + -- * Type of the autocmd (e.g. \"BufWritePost\") + -- * Name for the function to call + -- * Whether to use rpcrequest or rpcnotify + -- * Options for the autocmd (use 'def' here if you don't want to change anything) + Autocmd ByteString FunctionName Synchronous AutocmdOptions + deriving (Show, Read, Eq, Ord, Generic) instance NFData FunctionalityDescription - instance Pretty FunctionalityDescription where pretty = \case Function fname s -> "Function" <+> pretty s <+> pretty fname - Command fname copts -> "Command" <+> pretty copts <+> pretty fname - Autocmd t fname s aopts -> "Autocmd" <+> pretty (decodeUtf8 t) <+> pretty s <+> pretty aopts <+> pretty fname - --- | This option detemines how neovim should behave when calling some --- functionality on a remote host. +{- | This option detemines how neovim should behave when calling some + functionality on a remote host. +-} data Synchronous - = Async - -- ^ Call the functionality entirely for its side effects and do not wait - -- for it to finish. Calling a functionality with this flag set is - -- completely asynchronous and nothing is really expected to happen. This - -- is why a call like this is called notification on the neovim side of - -- things. - - | Sync - -- ^ Call the function and wait for its result. This is only synchronous on - -- the neovim side. This means that the GUI will (probably) not - -- allow any user input until a reult is received. + = -- | Call the functionality entirely for its side effects and do not wait + -- for it to finish. Calling a functionality with this flag set is + -- completely asynchronous and nothing is really expected to happen. This + -- is why a call like this is called notification on the neovim side of + -- things. + Async + | -- | Call the function and wait for its result. This is only synchronous on + -- the neovim side. This means that the GUI will (probably) not + -- allow any user input until a reult is received. + Sync deriving (Show, Read, Eq, Ord, Enum, Generic) instance NFData Synchronous @@ -131,113 +142,99 @@ instance Pretty Synchronous where pretty = \case Async -> "async" - Sync -> "sync" - + Sync -> "sync" instance IsString Synchronous where fromString = \case - "sync" -> Sync + "sync" -> Sync "async" -> Async - _ -> error "Only \"sync\" and \"async\" are valid string representations" - + _ -> error "Only \"sync\" and \"async\" are valid string representations" instance NvimObject Synchronous where toObject = \case Async -> toObject False - Sync -> toObject True + Sync -> toObject True fromObject = \case - ObjectBool True -> return Sync + ObjectBool True -> return Sync ObjectBool False -> return Async - ObjectInt 0 -> return Async - _ -> return Sync - - --- | Options for commands. --- --- Some command can also be described by using the OverloadedString extensions. --- This means that you can write a literal 'String' inside your source file in --- place for a 'CommandOption' value. See the documentation for each value on --- how these strings should look like (Both versions are compile time checked.) -data CommandOption = CmdSync Synchronous - -- ^ Stringliteral "sync" or "async" - - | CmdRegister - -- ^ Register passed to the command. - -- - -- Stringliteral: @\"\\\"\"@ - - | CmdNargs String - -- ^ Command takes a specific amount of arguments - -- - -- Automatically set via template haskell functions. You - -- really shouldn't use this option yourself unless you have - -- to. - - | CmdRange RangeSpecification - -- ^ Determines how neovim passes the range. - -- - -- Stringliterals: \"%\" for 'WholeFile', \",\" for line - -- and \",123\" for 123 lines. - - | CmdCount Word - -- ^ Command handles a count. The argument defines the - -- default count. - -- - -- Stringliteral: string of numbers (e.g. "132") + ObjectInt 0 -> return Async + _ -> return Sync - | CmdBang - -- ^ Command handles a bang - -- - -- Stringliteral: \"!\" +{- | Options for commands. - | CmdComplete String - -- ^ Verbatim string passed to the @-complete=@ command attribute + Some command can also be described by using the OverloadedString extensions. + This means that you can write a literal 'String' inside your source file in + place for a 'CommandOption' value. See the documentation for each value on + how these strings should look like (Both versions are compile time checked.) +-} +data CommandOption + = -- | Stringliteral "sync" or "async" + CmdSync Synchronous + | -- | Register passed to the command. + -- + -- Stringliteral: @\"\\\"\"@ + CmdRegister + | -- | Command takes a specific amount of arguments + -- + -- Automatically set via template haskell functions. You + -- really shouldn't use this option yourself unless you have + -- to. + CmdNargs String + | -- | Determines how neovim passes the range. + -- + -- Stringliterals: \"%\" for 'WholeFile', \",\" for line + -- and \",123\" for 123 lines. + CmdRange RangeSpecification + | -- | Command handles a count. The argument defines the + -- default count. + -- + -- Stringliteral: string of numbers (e.g. "132") + CmdCount Word + | -- | Command handles a bang + -- + -- Stringliteral: \"!\" + CmdBang + | -- | Verbatim string passed to the @-complete=@ command attribute + CmdComplete String deriving (Eq, Ord, Show, Read, Generic) instance NFData CommandOption - instance Pretty CommandOption where pretty = \case CmdSync s -> pretty s - CmdRegister -> "\"" - CmdNargs n -> pretty n - CmdRange rs -> pretty rs - CmdCount c -> pretty c - CmdBang -> "!" - CmdComplete cs -> - pretty cs - + pretty cs instance IsString CommandOption where fromString = \case - "%" -> CmdRange WholeFile - "\"" -> CmdRegister - "!" -> CmdBang - "sync" -> CmdSync Sync + "%" -> CmdRange WholeFile + "\"" -> CmdRegister + "!" -> CmdBang + "sync" -> CmdSync Sync "async" -> CmdSync Async - "," -> CmdRange CurrentLine - ',':ds | not (null ds) && all isDigit ds -> CmdRange (read ds) + "," -> CmdRange CurrentLine + ',' : ds | not (null ds) && all isDigit ds -> CmdRange (read ds) ds | not (null ds) && all isDigit ds -> CmdCount (read ds) - _ -> error "Not a valid string for a CommandOptions. Check the docs!" + _ -> error "Not a valid string for a CommandOptions. Check the docs!" --- | Newtype wrapper for a list of 'CommandOption'. Any properly constructed --- object of this type is sorted and only contains zero or one object for each --- possible option. -newtype CommandOptions = CommandOptions { getCommandOptions :: [CommandOption] } +{- | Newtype wrapper for a list of 'CommandOption'. Any properly constructed + object of this type is sorted and only contains zero or one object for each + possible option. +-} +newtype CommandOptions = CommandOptions {getCommandOptions :: [CommandOption]} deriving (Eq, Ord, Show, Read, Generic) instance NFData CommandOptions @@ -246,56 +243,53 @@ pretty (CommandOptions os) = cat $ map pretty os --- | Smart constructor for 'CommandOptions'. This sorts the command options and --- removes duplicate entries for semantically the same thing. Note that the --- smallest option stays for whatever ordering is defined. It is best to simply --- not define the same thing multiple times. +{- | Smart constructor for 'CommandOptions'. This sorts the command options and + removes duplicate entries for semantically the same thing. Note that the + smallest option stays for whatever ordering is defined. It is best to simply + not define the same thing multiple times. +-} mkCommandOptions :: [CommandOption] -> CommandOptions mkCommandOptions = CommandOptions . map head . groupBy constructor . sort where - constructor a b = case (a,b) of - _ | a == b -> True + constructor a b = case (a, b) of + _ | a == b -> True -- Only CmdSync and CmdNargs may fail for the equality check, -- so we just have to check those. - (CmdSync _, CmdSync _) -> True - (CmdRange _, CmdRange _) -> True + (CmdSync _, CmdSync _) -> True + (CmdRange _, CmdRange _) -> True -- Range and conut are mutually recursive. -- XXX Actually '-range=N' and '-count=N' are, but the code in -- remote#define#CommandOnChannel treats it exclusive as a whole. -- (see :h :command-range) - (CmdRange _, CmdCount _) -> True - (CmdNargs _, CmdNargs _) -> True - _ -> False - + (CmdRange _, CmdCount _) -> True + (CmdNargs _, CmdNargs _) -> True + _ -> False instance NvimObject CommandOptions where toObject (CommandOptions opts) = (toObject :: Dictionary -> Object) . Map.fromList $ mapMaybe addOption opts where addOption = \case - CmdRange r -> Just ("range" , toObject r) - CmdCount n -> Just ("count" , toObject n) - CmdBang -> Just ("bang" , ObjectBinary "") - CmdRegister -> Just ("register", ObjectBinary "") - CmdNargs n -> Just ("nargs" , toObject n) + CmdRange r -> Just ("range", toObject r) + CmdCount n -> Just ("count", toObject n) + CmdBang -> Just ("bang", ObjectBinary "") + CmdRegister -> Just ("register", ObjectBinary "") + CmdNargs n -> Just ("nargs", toObject n) CmdComplete cs -> Just ("complete", toObject cs) - _ -> Nothing - - fromObject o = throwError $ - "Did not expect to receive a CommandOptions object:" <+> viaShow o + _ -> Nothing + fromObject o = + throwError $ + "Did not expect to receive a CommandOptions object:" <+> viaShow o -- | Specification of a range that acommand can operate on. data RangeSpecification - = CurrentLine - -- ^ The line the cursor is at when the command is invoked. - - | WholeFile - -- ^ Let the command operate on every line of the file. - - | RangeCount Int - -- ^ Let the command operate on each line in the given range. - + = -- | The line the cursor is at when the command is invoked. + CurrentLine + | -- | Let the command operate on every line of the file. + WholeFile + | -- | Let the command operate on each line in the given range. + RangeCount Int deriving (Eq, Ord, Show, Read, Generic) instance NFData RangeSpecification @@ -304,167 +298,160 @@ pretty = \case CurrentLine -> mempty - WholeFile -> "%" - RangeCount c -> pretty c - instance NvimObject RangeSpecification where toObject = \case - CurrentLine -> ObjectBinary "" - WholeFile -> ObjectBinary "%" + CurrentLine -> ObjectBinary "" + WholeFile -> ObjectBinary "%" RangeCount n -> toObject n - fromObject o = throwError $ - "Did not expect to receive a RangeSpecification object:" <+> viaShow o - + fromObject o = + throwError $ + "Did not expect to receive a RangeSpecification object:" <+> viaShow o --- | You can use this type as the first argument for a function which is --- intended to be exported as a command. It holds information about the special --- attributes a command can take. +{- | You can use this type as the first argument for a function which is + intended to be exported as a command. It holds information about the special + attributes a command can take. +-} data CommandArguments = CommandArguments - { bang :: Maybe Bool - -- ^ 'Nothing' means that the function was not defined to handle a bang, - -- otherwise it means that the bang was passed (@'Just' 'True'@) or that it - -- was not passed when called (@'Just' 'False'@). - - , range :: Maybe (Int, Int) - -- ^ Range passed from neovim. Only set if 'CmdRange' was used in the export - -- declaration of the command. - -- - -- Example: - -- - -- * @Just (1,12)@ - - , count :: Maybe Int - -- ^ Count passed by neovim. Only set if 'CmdCount' was used in the export - -- declaration of the command. - - , register :: Maybe String - -- ^ Register that the command can\/should\/must use. + { -- | 'Nothing' means that the function was not defined to handle a bang, + -- otherwise it means that the bang was passed (@'Just' 'True'@) or that it + -- was not passed when called (@'Just' 'False'@). + bang :: Maybe Bool + , -- | Range passed from neovim. Only set if 'CmdRange' was used in the export + -- declaration of the command. + -- + -- Example: + -- + -- * @Just (1,12)@ + range :: Maybe (Int, Int) + , -- | Count passed by neovim. Only set if 'CmdCount' was used in the export + -- declaration of the command. + count :: Maybe Int + , -- | Register that the command can\/should\/must use. + register :: Maybe String } deriving (Eq, Ord, Show, Read, Generic) - instance NFData CommandArguments - instance Pretty CommandArguments where pretty CommandArguments{..} = - cat $ catMaybes - [ (\b -> if b then "!" else mempty) <$> bang - , (\(s,e) -> lparen <> pretty s <> comma - <+> pretty e <> rparen) - <$> range - , pretty <$> count - , pretty <$> register - ] + cat $ + catMaybes + [ (\b -> if b then "!" else mempty) <$> bang + , ( \(s, e) -> + lparen <> pretty s <> comma + <+> pretty e <> rparen + ) + <$> range + , pretty <$> count + , pretty <$> register + ] instance Default CommandArguments where - def = CommandArguments - { bang = Nothing - , range = Nothing - , count = Nothing + def = + CommandArguments + { bang = Nothing + , range = Nothing + , count = Nothing , register = Nothing } - -- XXX This instance is used as a bit of a hack, so that I don't have to write -- special code handling in the code generator and "Neovim.RPC.SocketReader". instance NvimObject CommandArguments where - toObject CommandArguments{..} = (toObject :: Dictionary -> Object) - . Map.fromList . catMaybes $ - [ bang >>= \b -> return ("bang", toObject b) - , range >>= \r -> return ("range", toObject r) - , count >>= \c -> return ("count", toObject c) - , register >>= \r -> return ("register", toObject r) - ] + toObject CommandArguments{..} = + (toObject :: Dictionary -> Object) + . Map.fromList + . catMaybes + $ [ bang >>= \b -> return ("bang", toObject b) + , range >>= \r -> return ("range", toObject r) + , count >>= \c -> return ("count", toObject c) + , register >>= \r -> return ("register", toObject r) + ] fromObject (ObjectMap m) = do - let l key = sequence (fromObject <$> Map.lookup (ObjectBinary key) m) + let l key = mapM fromObject (Map.lookup (ObjectBinary key) m) bang <- l "bang" range <- l "range" count <- l "count" register <- l "register" return CommandArguments{..} - fromObject ObjectNil = return def fromObject o = - throwError $ "Expected a map for CommandArguments object, but got: " - <+> viaShow o - + throwError $ + "Expected a map for CommandArguments object, but got: " + <+> viaShow o --- | Options that can be used to register an autocmd. See @:h :autocmd@ or any --- referenced neovim help-page from the fields of this data type. +{- | Options that can be used to register an autocmd. See @:h :autocmd@ or any + referenced neovim help-page from the fields of this data type. +-} data AutocmdOptions = AutocmdOptions - { acmdPattern :: String - -- ^ Pattern to match on. (default: \"*\") - - , acmdNested :: Bool - -- ^ Nested autocmd. (default: False) - -- - -- See @:h autocmd-nested@ - - , acmdGroup :: Maybe String - -- ^ Group in which the autocmd should be registered. + { -- | Pattern to match on. (default: \"*\") + acmdPattern :: String + , -- | Nested autocmd. (default: False) + -- + -- See @:h autocmd-nested@ + acmdNested :: Bool + , -- | Group in which the autocmd should be registered. + acmdGroup :: Maybe String } deriving (Show, Read, Eq, Ord, Generic) - instance NFData AutocmdOptions - instance Pretty AutocmdOptions where pretty AutocmdOptions{..} = pretty acmdPattern - <+> if acmdNested then "nested" else "unnested" - <> maybe mempty (\g -> mempty <+> pretty g) acmdGroup - + <+> if acmdNested + then "nested" + else + "unnested" + <> maybe mempty (\g -> mempty <+> pretty g) acmdGroup instance Default AutocmdOptions where - def = AutocmdOptions - { acmdPattern = "*" - , acmdNested = False - , acmdGroup = Nothing - } - + def = + AutocmdOptions + { acmdPattern = "*" + , acmdNested = False + , acmdGroup = Nothing + } instance NvimObject AutocmdOptions where toObject AutocmdOptions{..} = (toObject :: Dictionary -> Object) . Map.fromList $ [ ("pattern", toObject acmdPattern) , ("nested", toObject acmdNested) - ] ++ catMaybes - [ acmdGroup >>= \g -> return ("group", toObject g) ] - fromObject o = throwError $ - "Did not expect to receive an AutocmdOptions object: " <+> viaShow o - -newtype NvimMethod = - NvimMethod { nvimMethodName :: ByteString } - deriving (Eq, Ord, Show, Read, Generic) + ++ catMaybes + [ acmdGroup >>= \g -> return ("group", toObject g) + ] + fromObject o = + throwError $ + "Did not expect to receive an AutocmdOptions object: " <+> viaShow o +newtype NvimMethod = NvimMethod {nvimMethodName :: ByteString} + deriving (Eq, Ord, Show, Read, Generic) instance NFData NvimMethod - instance Pretty NvimMethod where pretty (NvimMethod n) = pretty $ decodeUtf8 n - -- | Conveniennce class to extract a name from some value. class HasFunctionName a where name :: a -> FunctionName nvimMethod :: a -> NvimMethod - instance HasFunctionName FunctionalityDescription where name = \case - Function n _ -> n - Command n _ -> n + Function n _ -> n + Command n _ -> n Autocmd _ n _ _ -> n nvimMethod = \case diff --git a/library/Neovim/Plugin/IPC.hs b/library/Neovim/Plugin/IPC.hs --- a/library/Neovim/Plugin/IPC.hs +++ b/library/Neovim/Plugin/IPC.hs @@ -11,10 +11,8 @@ plugins (or more generally threads running in the same plugin provider). -} module Neovim.Plugin.IPC ( - SomeMessage(..), + SomeMessage (..), fromMessage, - - ) where - -import Neovim.Plugin.IPC.Classes +) where +import Neovim.Plugin.IPC.Classes diff --git a/library/Neovim/Plugin/IPC/Classes.hs b/library/Neovim/Plugin/IPC/Classes.hs --- a/library/Neovim/Plugin/IPC/Classes.hs +++ b/library/Neovim/Plugin/IPC/Classes.hs @@ -1,7 +1,8 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecordWildCards #-} + {- | Module : Neovim.Plugin.IPC.Classes Description : Classes used for Inter Plugin Communication @@ -11,52 +12,50 @@ Maintainer : woozletoff@gmail.com Stability : experimental Portability : GHC - -} module Neovim.Plugin.IPC.Classes ( - SomeMessage(..), - Message(..), - FunctionCall(..), - Request(..), - Notification(..), + SomeMessage (..), + Message (..), + FunctionCall (..), + Request (..), + Notification (..), writeMessage, readSomeMessage, - UTCTime, getCurrentTime, - module Data.Int, - ) where +) where -import Neovim.Classes -import Neovim.Plugin.Classes (FunctionName) +import Neovim.Classes +import Neovim.Plugin.Classes (FunctionName, NeovimEventId) -import Control.Exception (evaluate) -import Control.Concurrent.STM -import Control.Monad.IO.Class (MonadIO(..)) -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 Data.Text.Prettyprint.Doc (nest, hardline, viaShow) +import Control.Concurrent.STM +import Control.Exception (evaluate) +import Control.Monad.IO.Class (MonadIO (..)) +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 Prettyprinter (hardline, nest, viaShow) -import Prelude +import Prelude --- | Taken from xmonad and based on ideas in /An Extensible Dynamically-Typed --- Hierarchy of Exceptions/, Simon Marlow, 2006. --- --- User-extensible messages must be put into a value of this type, so that it --- can be sent to other plugins. -data SomeMessage = forall msg. Message msg => SomeMessage msg +{- | Taken from xmonad and based on ideas in /An Extensible Dynamically-Typed + Hierarchy of Exceptions/, Simon Marlow, 2006. + User-extensible messages must be put into a value of this type, so that it + can be sent to other plugins. +-} +data SomeMessage = forall msg. Message msg => SomeMessage msg --- | This class allows type safe casting of 'SomeMessage' to an actual message. --- The cast is successful if the type you're expecting matches the type in the --- 'SomeMessage' wrapper. This way, you can subscribe to an arbitrary message --- type withouth having to pattern match on the constructors. This also allows --- plugin authors to create their own message types without having to change the --- core code of /nvim-hs/. +{- | This class allows type safe casting of 'SomeMessage' to an actual message. + The cast is successful if the type you're expecting matches the type in the + 'SomeMessage' wrapper. This way, you can subscribe to an arbitrary message + type withouth having to pattern match on the constructors. This also allows + plugin authors to create their own message types without having to change the + core code of /nvim-hs/. +-} class (NFData message, Typeable message) => Message message where -- | Try to convert a given message to a value of the message type we are -- interested in. Will evaluate to 'Nothing' for any other type. @@ -73,70 +72,73 @@ -- | Haskell representation of supported Remote Procedure Call messages. data FunctionCall - = FunctionCall FunctionName [Object] (TMVar (Either Object Object)) UTCTime - -- ^ Method name, parameters, callback, timestamp + = -- | Method name, parameters, callback, timestamp + FunctionCall FunctionName [Object] (TMVar (Either Object Object)) UTCTime deriving (Typeable, Generic) instance NFData FunctionCall where - rnf (FunctionCall f os v t) = f `deepseq` os `deepseq` v `seq` t `deepseq` () + rnf (FunctionCall f os v t) = f `deepseq` os `deepseq` v `seq` t `deepseq` () instance Message FunctionCall - instance Pretty FunctionCall where pretty (FunctionCall fname args _ t) = - nest 2 $ "Function call for:" <+> pretty fname - <> hardline <> "Arguments:" <+> viaShow args - <> hardline <> "Timestamp:" - <+> (viaShow . formatTime defaultTimeLocale "%H:%M:%S (%q)") t - + nest 2 $ + "Function call for:" <+> pretty fname + <> hardline + <> "Arguments:" <+> viaShow args + <> hardline + <> "Timestamp:" + <+> (viaShow . formatTime defaultTimeLocale "%H:%M:%S (%q)") t --- | A request is a data type containing the method to call, its arguments and --- an identifier used to map the result to the function that has been called. +{- | A request is a data type containing the method to call, its arguments and + an identifier used to map the result to the function that has been called. +-} data Request = Request - { reqMethod :: FunctionName - -- ^ Name of the function to call. - , reqId :: !Int64 - -- ^ Identifier to map the result to a function call invocation. - , reqArgs :: [Object] - -- ^ Arguments for the function. - } deriving (Eq, Ord, Show, Typeable, Generic) - + { -- | Name of the function to call. + reqMethod :: FunctionName + , -- | Identifier to map the result to a function call invocation. + reqId :: !Int64 + , -- | Arguments for the function. + reqArgs :: [Object] + } + deriving (Eq, Ord, Show, Typeable, Generic) instance NFData Request - instance Message Request - instance Pretty Request where pretty Request{..} = - nest 2 $ "Request" <+> "#" <> pretty reqId - <> hardline <> "Method:" <+> pretty reqMethod - <> hardline <> "Arguments:" <+> viaShow reqArgs - + nest 2 $ + "Request" <+> "#" <> pretty reqId + <> hardline + <> "Method:" <+> pretty reqMethod + <> hardline + <> "Arguments:" <+> viaShow reqArgs --- | A notification is similar to a 'Request'. It essentially does the same --- thing, but the function is only called for its side effects. This type of --- message is sent by neovim if the caller there does not care about the result --- of the computation. +{- | A notification is similar to a 'Request'. It essentially does the same + thing, but the function is only called for its side effects. This type of + message is sent by neovim if the caller there does not care about the result + of the computation. +-} data Notification = Notification - { notMethod :: FunctionName - -- ^ Name of the function to call. - , notArgs :: [Object] - -- ^ Arguments for the function. - } deriving (Eq, Ord, Show, Typeable, Generic) - + { -- | Event name of the notification. + notEvent :: NeovimEventId + , -- | Arguments for the function. + notArgs :: [Object] + } + deriving (Eq, Ord, Show, Typeable, Generic) instance NFData Notification - instance Message Notification - instance Pretty Notification where pretty Notification{..} = - nest 2 $ "Notification" - <> hardline <> "Method:" <+> pretty notMethod - <> hardline <> "Arguments:" <+> viaShow notArgs - + nest 2 $ + "Notification" + <> hardline + <> "Event:" <+> pretty notEvent + <> hardline + <> "Arguments:" <+> viaShow notEvent diff --git a/library/Neovim/Plugin/Internal.hs b/library/Neovim/Plugin/Internal.hs --- a/library/Neovim/Plugin/Internal.hs +++ b/library/Neovim/Plugin/Internal.hs @@ -1,4 +1,5 @@ {-# LANGUAGE ExistentialQuantification #-} + {- | Module : Neovim.Plugin.Internal Description : Split module that can import Neovim.Context without creating import circles @@ -8,58 +9,52 @@ Maintainer : woozletoff@gmail.com Stability : experimental Portability : GHC - -} module Neovim.Plugin.Internal ( - ExportedFunctionality(..), + ExportedFunctionality (..), getFunction, getDescription, - NeovimPlugin(..), - Plugin(..), + NeovimPlugin (..), + Plugin (..), wrapPlugin, - ) where - -import Neovim.Context -import Neovim.Plugin.Classes +) where -import Data.MessagePack +import Neovim.Context +import Neovim.Plugin.Classes +import Data.MessagePack --- | This data type is used in the plugin registration to properly register the --- functions. +{- | This data type is used in the plugin registration to properly register the + functions. +-} newtype ExportedFunctionality env = EF (FunctionalityDescription, [Object] -> Neovim env Object) - -- | Extract the description of an 'ExportedFunctionality'. getDescription :: ExportedFunctionality env -> FunctionalityDescription -getDescription (EF (d,_)) = d - +getDescription (EF (d, _)) = d -- | Extract the function of an 'ExportedFunctionality'. getFunction :: ExportedFunctionality env -> [Object] -> Neovim env Object getFunction (EF (_, f)) = f - instance HasFunctionName (ExportedFunctionality env) where name = name . getDescription nvimMethod = nvimMethod . getDescription - -- | This data type contains meta information for the plugin manager. --- data Plugin env = Plugin { environment :: env - , exports :: [ExportedFunctionality env] + , exports :: [ExportedFunctionality env] } - --- | 'Plugin' values are wraped inside this data type via 'wrapPlugin' so that --- we can put plugins in an ordinary list. +{- | 'Plugin' values are wraped inside this data type via 'wrapPlugin' so that + we can put plugins in an ordinary list. +-} data NeovimPlugin = forall env. NeovimPlugin (Plugin env) - --- | Wrap a 'Plugin' in some nice blankets, so that we can put them in a simple --- list. +{- | Wrap a 'Plugin' in some nice blankets, so that we can put them in a simple + list. +-} wrapPlugin :: Applicative m => Plugin env -> m NeovimPlugin wrapPlugin = pure . NeovimPlugin diff --git a/library/Neovim/Quickfix.hs b/library/Neovim/Quickfix.hs --- a/library/Neovim/Quickfix.hs +++ b/library/Neovim/Quickfix.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE RecordWildCards #-} + {- | Module : Neovim.Quickfix Description : API for interacting with the quickfix list @@ -9,32 +10,33 @@ Maintainer : woozletoff@gmail.com Stability : experimental Portability : GHC - -} -module Neovim.Quickfix - where +module Neovim.Quickfix where -import Control.Applicative -import Control.Monad (void) -import Data.ByteString as BS (ByteString, all, elem) -import qualified Data.Map as Map -import Data.Maybe -import Data.MessagePack -import Data.Monoid -import Neovim.API.String -import Neovim.Classes -import Neovim.Context -import Data.Text.Prettyprint.Doc (viaShow) +import Control.Applicative +import Control.Monad (void) +import Data.ByteString as BS (ByteString, all, elem) +import qualified Data.Map as Map +import Data.Maybe +import Data.MessagePack +import Data.Monoid +import Prettyprinter (viaShow) -import Prelude +import Neovim.API.String +import Neovim.Classes +import Neovim.Context --- | This is a wrapper around neovim's @setqflist()@. @strType@ can be any --- string that you can append to (hence 'Monoid') that is also an instance --- of 'NvimObject'. You can e.g. use the plain old 'String'. -setqflist :: (Monoid strType, NvimObject strType) - => [QuickfixListItem strType] - -> QuickfixAction - -> Neovim env () +import Prelude + +{- | This is a wrapper around neovim's @setqflist()@. @strType@ can be any + string that you can append to (hence 'Monoid') that is also an instance + of 'NvimObject'. You can e.g. use the plain old 'String'. +-} +setqflist :: + (Monoid strType, NvimObject strType) => + [QuickfixListItem strType] -> + QuickfixAction -> + Neovim env () setqflist qs a = void $ vim_call_function "setqflist" $ qs +: a +: [] @@ -42,106 +44,104 @@ = VisualColumn Int | ByteIndexColumn Int | NoColumn - deriving (Eq, Ord, Show, Generic) - + deriving (Eq, Ord, Show, Generic) instance NFData ColumnNumber data SignLocation strType = LineNumber Int | SearchPattern strType - deriving (Eq, Ord, Show, Generic) - + 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. --- | Quickfix list item. The parameter names should mostly conform to those in --- @:h setqflist()@. Some fields are merged to explicitly state mutually --- exclusive elements or some other behavior of the fields. --- --- see 'quickfixListItem' for creating a value of this type without typing too --- much. + see 'quickfixListItem' for creating a value of this type without typing too + much. +-} data QuickfixListItem strType = QFItem - { bufOrFile :: Either Int strType - -- ^ Since the filename is only used if no buffer can be specified, this - -- field is a merge of @bufnr@ and @filename@. - - , lnumOrPattern :: Either Int strType - -- ^ Line number or search pattern to locate the error. - - , col :: 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. - - , nr :: Maybe Int - -- ^ Error number. - - , text :: strType - -- ^ Description of the error. - - , errorType :: QuickfixErrorType - -- ^ Type of error. - } deriving (Eq, Show, Generic) - + { -- | Since the filename is only used if no buffer can be specified, this + -- field is a merge of @bufnr@ and @filename@. + bufOrFile :: Either Int strType + , -- | Line number or search pattern to locate the error. + lnumOrPattern :: Either Int strType + , -- | A tuple of a column number and a boolean indicating which kind of + -- indexing should be used. 'True' means that the visual column should be + -- used. 'False' means to use the byte index. + col :: ColumnNumber + , -- | Error number. + nr :: Maybe Int + , -- | Description of the error. + text :: strType + , -- | Type of error. + errorType :: QuickfixErrorType + } + deriving (Eq, Show, Generic) instance (NFData strType) => NFData (QuickfixListItem strType) - -- | Simple error type enum. data QuickfixErrorType = Warning | Error deriving (Eq, Ord, Show, Read, Enum, Bounded, Generic) - instance NFData QuickfixErrorType - instance NvimObject QuickfixErrorType where toObject = \case Warning -> ObjectBinary "W" - Error -> ObjectBinary "E" + Error -> ObjectBinary "E" fromObject o = case fromObject o :: Either (Doc AnsiStyle) String of Right "W" -> return Warning Right "E" -> return Error - _ -> return Error - - --- | Create a 'QuickfixListItem' by providing the minimal amount of arguments --- needed. -quickfixListItem :: (Monoid strType) - => Either Int strType -- ^ buffer of file name - -> Either Int strType -- ^ line number or pattern - -> QuickfixListItem strType -quickfixListItem bufferOrFile lineOrPattern = QFItem - { bufOrFile = bufferOrFile - , lnumOrPattern = lineOrPattern - , col = NoColumn - , nr = Nothing - , text = mempty - , errorType = Error - } + _ -> return Error +{- | Create a 'QuickfixListItem' by providing the minimal amount of arguments + needed. +-} +quickfixListItem :: + (Monoid strType) => + -- | buffer of file name + Either Int strType -> + -- | line number or pattern + Either Int strType -> + QuickfixListItem strType +quickfixListItem bufferOrFile lineOrPattern = + QFItem + { bufOrFile = bufferOrFile + , lnumOrPattern = lineOrPattern + , col = NoColumn + , nr = Nothing + , text = mempty + , errorType = Error + } -instance (Monoid strType, NvimObject strType) - => NvimObject (QuickfixListItem strType) where +instance + (Monoid strType, NvimObject strType) => + NvimObject (QuickfixListItem strType) + where toObject QFItem{..} = (toObject :: Map.Map ByteString Object -> Object) . Map.fromList $ - [ either (\b -> ("bufnr", toObject b)) - (\f -> ("filename", toObject f)) - bufOrFile - , either (\l -> ("lnum", toObject l)) - (\p -> ("pattern", toObject p)) - lnumOrPattern + [ either + (\b -> ("bufnr", toObject b)) + (\f -> ("filename", toObject f)) + bufOrFile + , either + (\l -> ("lnum", toObject l)) + (\p -> ("pattern", toObject p)) + lnumOrPattern , ("type", toObject errorType) , ("text", toObject text) - ] ++ concat - [ case col of - NoColumn -> [] - ByteIndexColumn i -> [ ("col", toObject i), ("vcol", toObject False) ] - VisualColumn i -> [ ("col", toObject i), ("vcol", toObject True) ] ] + ++ 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 @@ -152,16 +152,17 @@ bufOrFile <- case (l "bufnr", l "filename") of (Right b, _) -> return $ Left b (_, Right f) -> return $ Right f - _ -> throwError $ "No buffer number or file name inside quickfix list item." + _ -> throwError $ "No buffer number or file name inside quickfix list item." lnumOrPattern <- case (l "lnum", l "pattern") of (Right lnum, _) -> return $ Left lnum - (_, Right pat) -> return $ Right pat - _ -> throwError $ "No line number or search pattern inside quickfix list item." + (_, Right pat) -> return $ Right pat + _ -> throwError $ "No line number or search pattern inside quickfix list item." let l' :: NvimObject o => ByteString -> Either (Doc AnsiStyle) (Maybe o) l' key = case Map.lookup key m of Just o -> Just <$> fromObject o Nothing -> return Nothing - nr <- l' "nr" >>= \case + nr <- + l' "nr" >>= \case Just 0 -> return Nothing nr' -> return nr' c <- l' "col" @@ -169,38 +170,38 @@ let col = maybe NoColumn id $ do c' <- c v' <- v - case (c',v') of + case (c', v') of (0, _) -> return $ NoColumn (_, True) -> return $ VisualColumn c' (_, False) -> return $ ByteIndexColumn c' text <- fromMaybe mempty <$> l' "text" errorType <- fromMaybe Error <$> l' "type" return QFItem{..} - - fromObject o = throwError $ "Could not deserialize QuickfixListItem," - <+> "expected a map but received:" - <+> viaShow o - + fromObject o = + throwError $ + "Could not deserialize QuickfixListItem," + <+> "expected a map but received:" + <+> viaShow o data QuickfixAction - = Append -- ^ Add items to the current list (or create a new one if none exists). - | Replace -- ^ Replace current list (or create a new one if none exists). - | New -- ^ Create a new list. + = -- | Add items to the current list (or create a new one if none exists). + Append + | -- | Replace current list (or create a new one if none exists). + Replace + | -- | Create a new list. + New deriving (Eq, Ord, Enum, Bounded, Show, Generic) - instance NFData QuickfixAction - instance NvimObject QuickfixAction where toObject = \case - Append -> ObjectBinary "a" + Append -> ObjectBinary "a" Replace -> ObjectBinary "r" - New -> ObjectBinary "" + New -> ObjectBinary "" fromObject o = case fromObject o of Right "a" -> return Append Right "r" -> return Replace Right s | BS.all (`BS.elem` " \t\n\r") s -> return New - _ -> Left "Could not convert to QuickfixAction" - + _ -> Left "Could not convert to QuickfixAction" diff --git a/library/Neovim/RPC/Classes.hs b/library/Neovim/RPC/Classes.hs --- a/library/Neovim/RPC/Classes.hs +++ b/library/Neovim/RPC/Classes.hs @@ -1,6 +1,6 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveGeneric #-} + {- | Module : Neovim.RPC.Classes Description : Data types and classes for the RPC components @@ -13,102 +13,89 @@ Import this module qualified as @MsgpackRPC@ -} -module Neovim.RPC.Classes - ( Message (..), - ) where +module Neovim.RPC.Classes ( + Message (..), +) where -import Neovim.Classes -import Neovim.Plugin.Classes (FunctionName (..)) +import Neovim.Classes +import Neovim.Plugin.Classes (FunctionName (..), NeovimEventId (..)) import qualified Neovim.Plugin.IPC.Classes as IPC -import Control.Applicative -import Control.Monad.Error.Class -import Data.Data (Typeable) -import Data.MessagePack (Object (..)) - -import Data.Text.Prettyprint.Doc (hardline, nest, viaShow) +import Control.Applicative +import Control.Monad.Error.Class +import Data.Data (Typeable) +import Data.MessagePack (Object (..)) +import Prettyprinter (hardline, nest, viaShow) -import Prelude +import Prelude --- | See https://github.com/msgpack-rpc/msgpack-rpc/blob/master/spec.md for --- details about the msgpack rpc specification. +{- | See https://github.com/msgpack-rpc/msgpack-rpc/blob/master/spec.md for + details about the msgpack rpc specification. +-} data Message - = Request IPC.Request - -- ^ Request in the sense of the msgpack rpc specification - -- - -- Parameters - -- * Message identifier that has to be put in the response to this request - -- * Function name - -- * Function arguments - - | Response !Int64 (Either Object Object) - -- ^ Response in the sense of the msgpack rpc specifcation - -- - -- Parameters - -- * Mesage identifier which matches a request - -- * 'Either' an error 'Object' or a result 'Object' - - | Notification IPC.Notification - -- ^ Notification in the sense of the msgpack rpc specification + = -- | Request in the sense of the msgpack rpc specification + -- + -- Parameters + -- * Message identifier that has to be put in the response to this request + -- * Function name + -- * Function arguments + Request IPC.Request + | -- | Response in the sense of the msgpack rpc specifcation + -- + -- Parameters + -- * Mesage identifier which matches a request + -- * 'Either' an error 'Object' or a result 'Object' + Response !Int64 (Either Object Object) + | -- | Notification in the sense of the msgpack rpc specification + Notification IPC.Notification deriving (Eq, Ord, Show, Typeable, Generic) - instance NFData Message - instance IPC.Message Message - instance NvimObject Message where toObject = \case Request (IPC.Request (F m) i ps) -> - ObjectArray $ (0 :: Int64) +: i +: m +: ps +: [] - + ObjectArray $ (0 :: Int64) +: i +: m +: ps +: [] Response i (Left e) -> ObjectArray $ (1 :: Int64) +: i +: e +: () +: [] - Response i (Right r) -> ObjectArray $ (1 :: Int64) +: i +: () +: r +: [] - - Notification (IPC.Notification (F m) ps) -> - ObjectArray $ (2 :: Int64) +: m +: ps +: [] - + Notification (IPC.Notification (NeovimEventId eventId) ps) -> + ObjectArray $ (2 :: Int64) +: eventId +: ps +: [] fromObject = \case ObjectArray [ObjectInt 0, i, m, ps] -> do - r <- IPC.Request - <$> (fmap F (fromObject m)) + r <- + IPC.Request + <$> fmap F (fromObject m) <*> fromObject i <*> fromObject ps return $ Request r - ObjectArray [ObjectInt 1, i, e, r] -> let eer = case e of - ObjectNil -> Right r - _ -> Left e - in Response <$> fromObject i - <*> pure eer - + ObjectNil -> Right r + _ -> Left e + in Response <$> fromObject i + <*> pure eer ObjectArray [ObjectInt 2, m, ps] -> do - n <- IPC.Notification - <$> (fmap F (fromObject m)) + n <- + IPC.Notification + <$> fmap NeovimEventId (fromObject m) <*> fromObject ps return $ Notification n - o -> throwError $ "Not a known/valid msgpack-rpc message:" <+> viaShow o - instance Pretty Message where pretty = \case Request request -> pretty request - Response i ret -> - nest 2 $ "Response" <+> "#" <> pretty i - <> hardline <> either viaShow viaShow ret - + nest 2 $ + "Response" <+> "#" <> pretty i + <> hardline + <> either viaShow viaShow ret Notification notification -> pretty notification - - diff --git a/library/Neovim/RPC/EventHandler.hs b/library/Neovim/RPC/EventHandler.hs --- a/library/Neovim/RPC/EventHandler.hs +++ b/library/Neovim/RPC/EventHandler.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} + {- | Module : Neovim.RPC.EventHandler Description : Event handling loop @@ -8,73 +9,74 @@ Maintainer : woozletoff@gmail.com Stability : experimental - -} module Neovim.RPC.EventHandler ( runEventHandler, - ) where - -import Neovim.Classes -import Neovim.Context -import qualified Neovim.Context.Internal as Internal -import Neovim.Plugin.IPC.Classes -import qualified Neovim.RPC.Classes as MsgpackRPC -import Neovim.RPC.Common -import Neovim.RPC.FunctionCall +) where -import Control.Applicative -import Control.Concurrent.STM hiding (writeTQueue) -import Control.Monad.Reader -import Control.Monad.Trans.Resource -import Data.ByteString (ByteString) -import Conduit as C -import qualified Data.Map as Map -import Data.Serialize (encode) -import System.IO (Handle) -import System.Log.Logger +import Neovim.Classes +import Neovim.Context +import qualified Neovim.Context.Internal as Internal +import Neovim.Plugin.IPC.Classes +import qualified Neovim.RPC.Classes as MsgpackRPC +import Neovim.RPC.Common +import Neovim.RPC.FunctionCall -import Prelude +import Conduit as C +import Control.Applicative +import Control.Concurrent.STM hiding (writeTQueue) +import Control.Monad.Reader +import Control.Monad.Trans.Resource +import Data.ByteString (ByteString) +import qualified Data.Map as Map +import Data.Serialize (encode) +import System.IO (Handle) +import System.Log.Logger +import Prelude --- | This function will establish a connection to the given socket and write --- msgpack-rpc requests to it. -runEventHandler :: Handle - -> Internal.Config RPCConfig - -> IO () +{- | This function will establish a connection to the given socket and write + msgpack-rpc requests to it. +-} +runEventHandler :: + Handle -> + Internal.Config RPCConfig -> + IO () runEventHandler writeableHandle env = runEventHandlerContext env . runConduit $ do eventHandlerSource .| eventHandler .| (sinkHandleFlush writeableHandle) - -- | Convenient monad transformer stack for the event handler -newtype EventHandler a = - EventHandler (ResourceT (ReaderT (Internal.Config RPCConfig) IO) a) - deriving ( Functor, Applicative, Monad, MonadIO - , MonadReader (Internal.Config RPCConfig)) - +newtype EventHandler a + = EventHandler (ResourceT (ReaderT (Internal.Config RPCConfig) IO) a) + deriving + ( Functor + , Applicative + , Monad + , MonadIO + , MonadReader (Internal.Config RPCConfig) + ) -runEventHandlerContext - :: Internal.Config RPCConfig -> EventHandler a -> IO a +runEventHandlerContext :: + Internal.Config RPCConfig -> EventHandler a -> IO a runEventHandlerContext env (EventHandler a) = runReaderT (runResourceT a) env - eventHandlerSource :: ConduitT () SomeMessage EventHandler () -eventHandlerSource = asks Internal.eventQueue >>= \q -> - forever $ yield =<< readSomeMessage q - +eventHandlerSource = + asks Internal.eventQueue >>= \q -> + forever $ yield =<< readSomeMessage q eventHandler :: ConduitM SomeMessage EncodedResponse EventHandler () -eventHandler = await >>= \case - Nothing -> - return () -- i.e. close the conduit -- TODO signal shutdown globally - - Just message -> do - handleMessage (fromMessage message, fromMessage message) - eventHandler - +eventHandler = + await >>= \case + Nothing -> + return () -- i.e. close the conduit -- TODO signal shutdown globally + Just message -> do + handleMessage (fromMessage message, fromMessage message) + eventHandler type EncodedResponse = C.Flush ByteString @@ -84,8 +86,9 @@ yield . Chunk . encode $ toObject o yield Flush -handleMessage :: (Maybe FunctionCall, Maybe MsgpackRPC.Message) - -> ConduitM i EncodedResponse EventHandler () +handleMessage :: + (Maybe FunctionCall, Maybe MsgpackRPC.Message) -> + ConduitM i EncodedResponse EventHandler () handleMessage = \case (Just (FunctionCall fn params reply time), _) -> do cfg <- asks (Internal.customConfig) @@ -95,13 +98,9 @@ modifyTVar' (recipients cfg) $ Map.insert i (time, reply) return i yield' $ MsgpackRPC.Request (Request fn messageId params) - (_, Just r@MsgpackRPC.Response{}) -> yield' r - (_, Just n@MsgpackRPC.Notification{}) -> yield' n - _ -> return () -- i.e. skip to next message - diff --git a/library/Neovim/RPC/FunctionCall.hs b/library/Neovim/RPC/FunctionCall.hs --- a/library/Neovim/RPC/FunctionCall.hs +++ b/library/Neovim/RPC/FunctionCall.hs @@ -1,4 +1,5 @@ {-# LANGUAGE RecordWildCards #-} + {- | Module : Neovim.RPC.FunctionCall Description : Functions for calling functions @@ -7,7 +8,6 @@ Maintainer : woozletoff@gmail.com Stability : experimental - -} module Neovim.RPC.FunctionCall ( acall, @@ -18,28 +18,29 @@ wait, wait', respond, - ) where +) where -import Neovim.Classes -import Neovim.Context -import qualified Neovim.Context.Internal as Internal -import Neovim.Plugin.Classes (FunctionName) -import Neovim.Plugin.IPC.Classes -import qualified Neovim.RPC.Classes as MsgpackRPC +import Neovim.Classes +import Neovim.Context +import qualified Neovim.Context.Internal as Internal +import Neovim.Plugin.Classes (FunctionName) +import Neovim.Plugin.IPC.Classes +import qualified Neovim.RPC.Classes as MsgpackRPC -import Control.Applicative -import Control.Concurrent.STM -import Control.Monad.Reader -import Data.MessagePack -import UnliftIO.Exception (throwIO) +import Control.Applicative +import Control.Concurrent.STM +import Control.Monad.Reader +import Data.MessagePack +import UnliftIO.Exception (throwIO) -import Prelude +import Prelude -- | Helper function that concurrently puts a 'Message' in the event queue and returns an 'STM' action that returns the result. -acall :: (NvimObject result) - => FunctionName - -> [Object] - -> Neovim env (STM (Either NeovimException result)) +acall :: + (NvimObject result) => + FunctionName -> + [Object] -> + Neovim env (STM (Either NeovimException result)) acall fn parameters = do q <- Internal.asks' Internal.eventQueue mv <- liftIO newEmptyTMVarIO @@ -47,59 +48,61 @@ writeMessage q $ FunctionCall fn parameters mv timestamp return $ convertObject <$> readTMVar mv where - convertObject :: (NvimObject result) - => Either Object Object -> Either NeovimException result + convertObject :: + (NvimObject result) => + Either Object Object -> + Either NeovimException result convertObject = \case Left e -> Left $ ErrorResult (pretty fn) e Right o -> case fromObject o of - Left e -> Left $ ErrorMessage e - Right r -> Right r + Left e -> Left $ ErrorMessage e + Right r -> Right r --- | Call a neovim function synchronously. This function blocks until the --- result is available. -scall :: (NvimObject result) - => FunctionName - -> [Object] -- ^ Parameters in an 'Object' array - -> Neovim env (Either NeovimException result) - -- ^ result value of the call or the thrown exception +{- | Call a neovim function synchronously. This function blocks until the + result is available. +-} +scall :: + (NvimObject result) => + FunctionName -> + -- | Parameters in an 'Object' array + [Object] -> + -- | result value of the call or the thrown exception + Neovim env (Either NeovimException result) scall fn parameters = acall fn parameters >>= atomically' -- | Similar to 'scall', but throw a 'NeovimException' instead of returning it. -scallThrow :: (NvimObject result) - => FunctionName - -> [Object] - -> Neovim env result +scallThrow :: + (NvimObject result) => + FunctionName -> + [Object] -> + Neovim env result scallThrow fn parameters = scall fn parameters >>= either throwIO return - --- | Helper function similar to 'scall' that throws a runtime exception if the --- result is an error object. +{- | Helper function similar to 'scall' that throws a runtime exception if the + result is an error object. +-} scall' :: NvimObject result => FunctionName -> [Object] -> Neovim env result scall' fn = either throwIO pure <=< scall fn - -- | Lifted variant of 'atomically'. atomically' :: (MonadIO io) => STM result -> io result atomically' = liftIO . atomically +{- | Wait for the result of the STM action. --- | Wait for the result of the STM action. --- --- This action possibly blocks as it is an alias for --- @ \ioSTM -> ioSTM >>= liftIO . atomically@. + This action possibly blocks as it is an alias for + @ \ioSTM -> ioSTM >>= liftIO . atomically@. +-} wait :: Neovim env (STM result) -> Neovim env result wait = (=<<) atomically' - -- | Variant of 'wait' that discards the result. wait' :: Neovim env (STM result) -> Neovim env () wait' = void . wait - -- | Send the result back to the neovim instance. respond :: (NvimObject result) => Request -> Either String result -> Neovim env () respond Request{..} result = do q <- Internal.asks' Internal.eventQueue writeMessage q . MsgpackRPC.Response reqId $ either (Left . toObject) (Right . toObject) result - diff --git a/library/Neovim/RPC/SocketReader.hs b/library/Neovim/RPC/SocketReader.hs --- a/library/Neovim/RPC/SocketReader.hs +++ b/library/Neovim/RPC/SocketReader.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE RecordWildCards #-} {- | Module : Neovim.RPC.SocketReader Description : The component which reads RPC messages from the neovim instance @@ -9,141 +6,135 @@ Maintainer : woozletoff@gmail.com Stability : experimental - -} module Neovim.RPC.SocketReader ( runSocketReader, parseParams, - ) where +) where -import Neovim.Classes -import Neovim.Context -import qualified Neovim.Context.Internal as Internal -import Neovim.Plugin.Classes (CommandArguments (..), - CommandOption (..), - FunctionName (..), - NvimMethod (..), - FunctionalityDescription (..), - getCommandOptions) -import Neovim.Plugin.IPC.Classes -import qualified Neovim.RPC.Classes as MsgpackRPC -import Neovim.RPC.Common -import Neovim.RPC.FunctionCall +import Neovim.Classes +import Neovim.Context +import qualified Neovim.Context.Internal as Internal +import Neovim.Plugin.Classes ( + CommandArguments (..), + CommandOption (..), + FunctionName (..), + FunctionalityDescription (..), + NeovimEventId (..), + NvimMethod (..), + Subscription (..), + getCommandOptions, + ) +import Neovim.Plugin.IPC.Classes +import qualified Neovim.RPC.Classes as MsgpackRPC +import Neovim.RPC.Common +import Neovim.RPC.FunctionCall -import Control.Applicative -import Control.Concurrent.STM -import Control.Monad (void) -import Conduit as C -import Data.Conduit.Cereal (conduitGet2) -import Data.Default (def) -import Data.Foldable (foldl', forM_) -import qualified Data.Map as Map -import Data.MessagePack -import Data.Monoid -import qualified Data.Serialize (get) -import System.IO (Handle) -import System.Log.Logger -import UnliftIO.Async (async, race) -import UnliftIO.Concurrent (threadDelay) +import Conduit as C +import Control.Applicative +import Control.Concurrent.STM +import Control.Monad (void) +import Data.Conduit.Cereal (conduitGet2) +import Data.Default (def) +import Data.Foldable (foldl', forM_) +import qualified Data.Map as Map +import Data.Maybe (fromMaybe) +import Data.MessagePack +import Data.Monoid +import qualified Data.Serialize (get) +import System.IO (Handle) +import System.Log.Logger +import UnliftIO.Async (async, race) +import UnliftIO.Concurrent (threadDelay) -import Prelude +import Prelude logger :: String logger = "Socket Reader" - type SocketHandler = Neovim RPCConfig - --- | This function will establish a connection to the given socket and read --- msgpack-rpc events from it. -runSocketReader :: Handle - -> Internal.Config RPCConfig - -> IO () +{- | This function will establish a connection to the given socket and read + msgpack-rpc events from it. +-} +runSocketReader :: + Handle -> + Internal.Config RPCConfig -> + IO () runSocketReader readableHandle cfg = void . runNeovim (Internal.retypeConfig (Internal.customConfig cfg) cfg) . runConduit $ do sourceHandle readableHandle .| conduitGet2 Data.Serialize.get .| messageHandlerSink - --- | Sink that delegates the messages depending on their type. --- +{- | Sink that delegates the messages depending on their type. + +-} messageHandlerSink :: ConduitT Object Void SocketHandler () messageHandlerSink = awaitForever $ \rpc -> do liftIO . debugM logger $ "Received: " <> show rpc case fromObject rpc of Right (MsgpackRPC.Request (Request fn i ps)) -> - handleRequestOrNotification (Just i) fn ps - + handleRequest i fn ps Right (MsgpackRPC.Response i r) -> handleResponse i r - - Right (MsgpackRPC.Notification (Notification fn ps)) -> - handleRequestOrNotification Nothing fn ps - - Left e -> liftIO . errorM logger $ - "Unhandled rpc message: " <> show e - + Right (MsgpackRPC.Notification (Notification eventId args)) -> + handleNotification eventId args + Left e -> + liftIO . errorM logger $ "Unhandled rpc message: " <> show e -handleResponse :: Int64 -> Either Object Object - -> ConduitT a Void SocketHandler () +handleResponse :: Int64 -> Either Object Object -> ConduitT a Void SocketHandler () handleResponse i result = do answerMap <- asks recipients mReply <- Map.lookup i <$> liftIO (readTVarIO answerMap) case mReply of - Nothing -> liftIO $ warningM logger - "Received response but could not find a matching recipient." - Just (_,reply) -> do + Nothing -> + liftIO $ warningM logger "Received response but could not find a matching recipient." + Just (_, reply) -> do atomically' . modifyTVar' answerMap $ Map.delete i atomically' $ putTMVar reply result - --- | 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] - -> ConduitT a Void SocketHandler () -handleRequestOrNotification requestId functionToCall@(F functionName) params = do +handleRequest :: Int64 -> FunctionName -> [Object] -> ConduitT a Void SocketHandler () +handleRequest requestId functionToCall@(F functionName) params = do cfg <- lift Internal.ask' void . liftIO . async $ race logTimeout (handle cfg) return () - where - lookupFunction - :: TMVar Internal.FunctionMap - -> STM (Maybe (FunctionalityDescription, Internal.FunctionType)) + lookupFunction :: + TMVar Internal.FunctionMap -> + STM (Maybe (FunctionalityDescription, Internal.FunctionType)) lookupFunction funMap = Map.lookup (NvimMethod functionName) <$> readTMVar funMap logTimeout :: IO () logTimeout = do let seconds = 1000 * 1000 threadDelay (10 * seconds) - debugM logger $ "Cancelled another action before it was finished" + 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 functionToCall - debugM logger errM - forM_ requestId $ \i -> writeMessage (Internal.eventQueue rpc) $ - MsgpackRPC.Response i (Left (toObject errM)) - - Just (copts, Internal.Stateful c) -> do - now <- liftIO getCurrentTime - reply <- liftIO newEmptyTMVarIO - let q = (recipients . Internal.customConfig) rpc - liftIO . debugM logger $ "Executing stateful function with ID: " <> show requestId - case requestId of - Just i -> do - atomically' . modifyTVar q $ Map.insert i (now, reply) - writeMessage c $ Request functionToCall i (parseParams copts params) - - Nothing -> - writeMessage c $ Notification functionToCall (parseParams copts params) + handle rpc = + atomically (lookupFunction (Internal.globalFunctionMap rpc)) >>= \case + Nothing -> do + let errM = "No provider for: " <> show functionToCall + debugM logger errM + writeMessage (Internal.eventQueue rpc) $ + MsgpackRPC.Response requestId (Left (toObject errM)) + Just (copts, Internal.Stateful c) -> do + now <- liftIO getCurrentTime + reply <- liftIO newEmptyTMVarIO + let q = (recipients . Internal.customConfig) rpc + liftIO . debugM logger $ "Executing stateful function with ID: " <> show requestId + atomically' . modifyTVar q $ Map.insert requestId (now, reply) + writeMessage c $ Request functionToCall requestId (parseParams copts params) +handleNotification :: NeovimEventId -> [Object] -> ConduitT a Void SocketHandler () +handleNotification eventId args = do + subscriptions' <- lift $ Internal.asks' Internal.subscriptions + subscribers <- liftIO $ + atomically $ do + s <- readTMVar subscriptions' + pure $ fromMaybe [] $ Map.lookup eventId (Internal.byEventId s) + forM_ subscribers $ \subscription -> liftIO $ subAction subscription args parseParams :: FunctionalityDescription -> [Object] -> [Object] parseParams (Function _ _) args = case args of @@ -154,67 +145,54 @@ -- The function generating the function on neovim side is called: -- @remote#define#FunctionOnHost@ [ObjectArray fArgs] -> fArgs - _ -> args - + _ -> args parseParams cmd@(Command _ opts) args = case args of (ObjectArray _ : _) -> let cmdArgs = filter isPassedViaRPC (getCommandOptions opts) - (c,args') = - foldl' createCommandArguments (def, []) $ - zip cmdArgs args - in toObject c : args' - - _ -> parseParams cmd $ [ObjectArray args] + (c, args') = foldl' createCommandArguments (def, []) $ zip cmdArgs args + in toObject c : args' + _ -> parseParams cmd [ObjectArray args] where isPassedViaRPC :: CommandOption -> Bool isPassedViaRPC = \case - CmdSync{} -> False - _ -> True + CmdSync{} -> False + _ -> True -- Neovim passes arguments in a special form, depending on the -- CommandOption values used to export the (command) function (e.g. via -- 'command' or 'command''). - createCommandArguments :: (CommandArguments, [Object]) - -> (CommandOption, Object) - -> (CommandArguments, [Object]) + createCommandArguments :: + (CommandArguments, [Object]) -> + (CommandOption, Object) -> + (CommandArguments, [Object]) createCommandArguments old@(c, args') = \case (CmdRange _, o) -> - either (const old) (\r -> (c { range = Just r }, args')) $ fromObject o - + either (const old) (\r -> (c{range = Just r}, args')) $ fromObject o (CmdCount _, o) -> - either (const old) (\n -> (c { count = Just n }, args')) $ fromObject o - + either (const old) (\n -> (c{count = Just n}, args')) $ fromObject o (CmdBang, o) -> - either (const old) (\b -> (c { bang = Just b }, args')) $ fromObject o - + either (const old) (\b -> (c{bang = Just b}, args')) $ fromObject o (CmdNargs "*", ObjectArray os) -> -- CommandArguments -> [String] -> Neovim r st a (c, os) - (CmdNargs "+", ObjectArray (o:os)) -> + (CmdNargs "+", ObjectArray (o : os)) -> -- CommandArguments -> String -> [String] -> Neovim r st a (c, o : [ObjectArray os]) (CmdNargs "?", ObjectArray [o]) -> -- CommandArguments -> Maybe String -> Neovim r st a (c, [toObject (Just o)]) - (CmdNargs "?", ObjectArray []) -> -- CommandArguments -> Maybe String -> Neovim r st a (c, [toObject (Nothing :: Maybe Object)]) - (CmdNargs "0", ObjectArray []) -> -- CommandArguments -> Neovim r st a (c, []) - (CmdNargs "1", ObjectArray [o]) -> -- CommandArguments -> String -> Neovim r st a (c, [o]) - (CmdRegister, o) -> - either (const old) (\r -> (c { register = Just r }, args')) $ fromObject o - + either (const old) (\r -> (c{register = Just r}, args')) $ fromObject o _ -> old - -parseParams (Autocmd _ _ _ _) args = case args of +parseParams Autocmd{} args = case args of [ObjectArray fArgs] -> fArgs _ -> args - diff --git a/library/Neovim/Test.hs b/library/Neovim/Test.hs --- a/library/Neovim/Test.hs +++ b/library/Neovim/Test.hs @@ -7,61 +7,64 @@ Maintainer : woozletoff@gmail.com Stability : experimental Portability : GHC - -} module Neovim.Test ( testWithEmbeddedNeovim, - Seconds(..), - ) where + Seconds (..), +) where -import Neovim -import Neovim.API.Text +import Neovim +import Neovim.API.Text import qualified Neovim.Context.Internal as Internal -import Neovim.RPC.Common (RPCConfig, newRPCConfig) -import Neovim.RPC.EventHandler (runEventHandler) -import Neovim.RPC.SocketReader (runSocketReader) +import Neovim.RPC.Common (RPCConfig, newRPCConfig) +import Neovim.RPC.EventHandler (runEventHandler) +import Neovim.RPC.SocketReader (runSocketReader) -import Control.Monad.Reader (runReaderT) -import Control.Monad.Trans.Resource (runResourceT) -import Data.Text.Prettyprint.Doc (annotate, vsep) -import Data.Text.Prettyprint.Doc.Render.Terminal (Color (..), color) -import GHC.IO.Exception (ioe_filename) +import Control.Monad.Reader (runReaderT) +import Control.Monad.Trans.Resource (runResourceT) +import GHC.IO.Exception (ioe_filename) import Path import Path.IO -import System.Exit (ExitCode (..)) -import System.IO (Handle) +import Prettyprinter (annotate, vsep) +import Prettyprinter.Render.Terminal (Color (..), color) import System.Process.Typed -import UnliftIO.Async (async, cancel) -import UnliftIO.Concurrent (threadDelay) -import UnliftIO.Exception -import UnliftIO.STM (atomically, putTMVar) +import UnliftIO +import UnliftIO.Concurrent (threadDelay) -- | Type synonym for 'Word'. newtype Seconds = Seconds Word +microSeconds :: Integral i => Seconds -> i +microSeconds (Seconds s) = fromIntegral s * 1000 * 1000 --- | Run the given 'Neovim' action according to the given parameters. --- The embedded neovim instance is started without a config (i.e. it is passed --- @-u NONE@). --- --- If you want to run your tests purely from haskell, you have to setup --- the desired state of neovim with the help of the functions in --- "Neovim.API.String". -testWithEmbeddedNeovim - :: Maybe (Path b File) -- ^ Optional path to a file that should be opened - -> Seconds -- ^ Maximum time (in seconds) that a test is allowed to run - -> env -- ^ Read-only configuration - -> Neovim env a -- ^ Test case - -> IO () -testWithEmbeddedNeovim file timeout r (Internal.Neovim a) = +{- | Run the given 'Neovim' action according to the given parameters. + The embedded neovim instance is started without a config (i.e. it is passed + @-u NONE@). + + If you want to run your tests purely from haskell, you have to setup + the desired state of neovim with the help of the functions in + "Neovim.API.String". +-} +testWithEmbeddedNeovim :: + -- | Optional path to a file that should be opened + Maybe (Path b File) -> + -- | Maximum time (in seconds) that a test is allowed to run + Seconds -> + -- | Read-only configuration + env -> + -- | Test case + Neovim env a -> + IO () +testWithEmbeddedNeovim file timeoutAfter r (Internal.Neovim a) = runTest `catch` catchIfNvimIsNotOnPath where runTest = do - (nvimProcess, cfg, cleanUp) <- startEmbeddedNvim file timeout + (nvimProcess, cfg, cleanUp) <- startEmbeddedNvim file timeoutAfter let testCfg = Internal.retypeConfig r cfg - void $ runReaderT (runResourceT a) testCfg + result <- timeout (microSeconds timeoutAfter) $ do + 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 @@ -72,62 +75,64 @@ waitExitCode nvimProcess >>= \case ExitFailure i -> fail $ "Neovim returned with an exit status of: " ++ show i - - ExitSuccess -> - return () + ExitSuccess -> case result of + Nothing -> fail "Test timed out" + Just _ -> pure () cancel testRunner cleanUp - catchIfNvimIsNotOnPath :: IOException -> IO () catchIfNvimIsNotOnPath e = case ioe_filename e of Just "nvim" -> - putDoc . annotate (color Red) $ vsep - [ "The neovim executable 'nvim' is not on the PATH." - , "You may not be testing fully!" - ] - - _ -> + putDoc . annotate (color Red) $ + vsep + [ "The neovim executable 'nvim' is not on the PATH." + , "You may not be testing fully!" + ] + _ -> throwIO e -startEmbeddedNvim - :: Maybe (Path b File) - -> Seconds - -> IO (Process Handle Handle (), Internal.Config RPCConfig, IO ()) -startEmbeddedNvim file (Seconds timeout) = do +startEmbeddedNvim :: + Maybe (Path b File) -> + Seconds -> + IO (Process Handle Handle (), Internal.Config RPCConfig, IO ()) +startEmbeddedNvim file timeoutAfter = do args <- case file of - Nothing -> - return [] - - Just f -> do - -- 'fail' should work with most testing frameworks - unlessM (doesFileExist f) . fail $ "File not found: " ++ show f - return [toFilePath f] + Nothing -> + pure [] + Just f -> do + unlessM (doesFileExist f) . fail $ "File not found: " ++ show f + pure [toFilePath f] - nvimProcess <- startProcess - $ setStdin createPipe - $ setStdout createPipe - $ proc "nvim" (["-n","--clean","--embed"] ++ args) + nvimProcess <- + startProcess $ + setStdin createPipe $ + setStdout createPipe $ + proc "nvim" (["-n", "--clean", "--embed"] ++ args) cfg <- Internal.newConfig (pure Nothing) newRPCConfig - socketReader <- async . void $ runSocketReader - (getStdout nvimProcess) - (cfg { Internal.pluginSettings = Nothing }) + socketReader <- + async . void $ + runSocketReader + (getStdout nvimProcess) + (cfg{Internal.pluginSettings = Nothing}) - eventHandler <- async . void $ runEventHandler - (getStdin nvimProcess) - (cfg { Internal.pluginSettings = Nothing }) + eventHandler <- + async . void $ + runEventHandler + (getStdin nvimProcess) + (cfg{Internal.pluginSettings = Nothing}) - atomically $ putTMVar - (Internal.globalFunctionMap cfg) - (Internal.mkFunctionMap []) + atomically $ + putTMVar + (Internal.globalFunctionMap cfg) + (Internal.mkFunctionMap []) timeoutAsync <- async . void $ do - threadDelay $ (fromIntegral timeout) * 1000 * 1000 - getExitCode nvimProcess >>= maybe (stopProcess nvimProcess) (\_ -> return ()) + threadDelay $ microSeconds timeoutAfter + getExitCode nvimProcess >>= maybe (stopProcess nvimProcess) (\_ -> pure ()) let cleanUp = mapM_ cancel [socketReader, eventHandler, timeoutAsync] - return (nvimProcess, cfg, cleanUp) - + pure (nvimProcess, cfg, cleanUp) diff --git a/library/Neovim/Util.hs b/library/Neovim/Util.hs --- a/library/Neovim/Util.hs +++ b/library/Neovim/Util.hs @@ -7,30 +7,26 @@ Maintainer : woozletoff@gmail.com Stability : experimental Portability : GHC - -} module Neovim.Util ( whenM, unlessM, oneLineErrorMessage, - ) where +) where -import Control.Monad (when, unless) -import Neovim.Context +import Control.Monad (unless, when) import qualified Data.Text as T - +import Neovim.Context -- | 'when' with a monadic predicate. whenM :: (Monad m) => m Bool -> m () -> m () whenM mp a = mp >>= \p -> when p a - -- | 'unless' with a monadic predicate. unlessM :: (Monad m) => m Bool -> m () -> m () unlessM mp a = mp >>= \p -> unless p a - oneLineErrorMessage :: Doc AnsiStyle -> T.Text oneLineErrorMessage d = case T.lines $ docToText d of - (x:_) -> x - [] -> mempty + (x : _) -> x + [] -> mempty diff --git a/nvim-hs.cabal b/nvim-hs.cabal --- a/nvim-hs.cabal +++ b/nvim-hs.cabal @@ -1,5 +1,5 @@ name: nvim-hs -version: 2.3.0.0 +version: 2.3.1.0 synopsis: Haskell plugin backend for neovim description: This package provides a plugin provider for neovim. It allows you to write @@ -121,7 +121,7 @@ , optparse-applicative , time-locale-compat , megaparsec < 10 - , prettyprinter >= 1.2 && < 2 + , prettyprinter >= 1.7 && < 2 , prettyprinter-ansi-terminal , resourcet >= 1.1.11 , stm @@ -197,6 +197,7 @@ other-modules: Neovim.API.THSpec , Neovim.API.THSpecFunctions , Neovim.EmbeddedRPCSpec + , Neovim.EventSubscriptionSpec , Neovim.Plugin.ClassesSpec , Neovim.RPC.SocketReaderSpec , Neovim.RPC.CommonSpec diff --git a/test-suite/Neovim/API/THSpec.hs b/test-suite/Neovim/API/THSpec.hs --- a/test-suite/Neovim/API/THSpec.hs +++ b/test-suite/Neovim/API/THSpec.hs @@ -1,25 +1,27 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -module Neovim.API.THSpec - where +{-# LANGUAGE TemplateHaskell #-} -import Neovim.API.THSpecFunctions +module Neovim.API.THSpec where -import Neovim.API.TH hiding (function) -import qualified Neovim.API.TH as TH -import Neovim.Context -import qualified Neovim.Context.Internal as Internal -import Neovim.Plugin.Classes -import Neovim.Plugin.Internal +import Neovim.API.THSpecFunctions -import Data.Default -import qualified Data.Map as Map +import Neovim.API.TH hiding (function) +import qualified Neovim.API.TH as TH +import Neovim.Context +import qualified Neovim.Context.Internal as Internal +import Neovim.Plugin.Classes +import Neovim.Plugin.Internal -import Test.Hspec -import Test.QuickCheck +import Data.Default +import qualified Data.Map as Map -call :: ([Object] -> Neovim () Object) -> [Object] - -> IO Object +import Test.Hspec +import Test.QuickCheck + +call :: + ([Object] -> Neovim () Object) -> + [Object] -> + IO Object call f args = do cfg <- Internal.newConfig (pure Nothing) (pure ()) res <- runNeovim cfg (f args) @@ -27,91 +29,89 @@ Right x -> return x Left e -> (throwIO . ErrorMessage) e - isNeovimException :: NeovimException -> Bool isNeovimException _ = True - spec :: Spec spec = do - describe "calling function without an argument" $ do - let EF (Function fname _, testFun) = $(TH.function "TestFunction0" 'testFunction0) Sync - it "should have a capitalized prefix" $ - fname `shouldBe` F "TestFunction0" - - it "should return the consant value" $ - call testFun [] `shouldReturn` ObjectInt 42 - - it "should fail if supplied an argument" $ - call testFun [ObjectNil] `shouldThrow` isNeovimException - + describe "calling function without an argument" $ do + let EF (Function fname _, testFun) = $(TH.function "TestFunction0" 'testFunction0) Sync + it "should have a capitalized prefix" $ + fname `shouldBe` F "TestFunction0" - describe "calling testFunction with two arguments" $ do - let EF (Function fname _, testFun) = $(function' 'testFunction2) Sync - it "should have a capitalized prefix" $ - fname `shouldBe` F "TestFunction2" + it "should return the consant value" $ + call testFun [] `shouldReturn` ObjectInt 42 - it "should return 2 for proper arguments" $ - call testFun [ ObjectNil - , ObjectString "ignored" - , ObjectArray [ObjectString "42"] - ] - `shouldReturn` ObjectDouble 2 + it "should fail if supplied an argument" $ + call testFun [ObjectNil] `shouldThrow` isNeovimException - it "should throw an exception for the wrong number of arguments" $ - call testFun [ObjectNil] `shouldThrow` isNeovimException + describe "calling testFunction with two arguments" $ do + let EF (Function fname _, testFun) = $(function' 'testFunction2) Sync + it "should have a capitalized prefix" $ + fname `shouldBe` F "TestFunction2" - it "should throw an exception for incompatible types" $ - call testFun [ObjectNil, ObjectBinary "ignored", ObjectString "42"] - `shouldThrow` isNeovimException + it "should return 2 for proper arguments" $ + call + testFun + [ ObjectNil + , ObjectString "ignored" + , ObjectArray [ObjectString "42"] + ] + `shouldReturn` ObjectDouble 2 - it "should cast arguments to similar types" $ - call testFun [ObjectNil, ObjectString "ignored", ObjectArray []] - `shouldReturn` ObjectDouble 2 + it "should throw an exception for the wrong number of arguments" $ + call testFun [ObjectNil] `shouldThrow` isNeovimException + it "should throw an exception for incompatible types" $ + call testFun [ObjectNil, ObjectBinary "ignored", ObjectString "42"] + `shouldThrow` isNeovimException - describe "generating a command from the two argument test function" $ do - let EF (Command fname _, _) = $(command' 'testFunction2) [] - it "should capitalize the first character" $ - fname `shouldBe` F "TestFunction2" + it "should cast arguments to similar types" $ + call testFun [ObjectNil, ObjectString "ignored", ObjectArray []] + `shouldReturn` ObjectDouble 2 - describe "generating the test successor functions" $ do - let EF (Function fname _, testFun) = $(function' 'testSucc) Sync - it "should be named TestSucc" $ - fname `shouldBe` F "TestSucc" + describe "generating a command from the two argument test function" $ do + let EF (Command fname _, _) = $(command' 'testFunction2) [] + it "should capitalize the first character" $ + fname `shouldBe` F "TestFunction2" - it "should return the old value + 1" . property $ - \x -> call testFun [ObjectInt x] `shouldReturn` ObjectInt (x+1) + describe "generating the test successor functions" $ do + let EF (Function fname _, testFun) = $(function' 'testSucc) Sync + it "should be named TestSucc" $ + fname `shouldBe` F "TestSucc" - describe "calling test function with a map argument" $ do - let EF (Function fname _, testFun) = $(TH.function "TestFunctionMap" 'testFunctionMap) Sync - it "should capitalize the first letter" $ - fname `shouldBe` F "TestFunctionMap" + it "should return the old value + 1" . property $ + \x -> call testFun [ObjectInt x] `shouldReturn` ObjectInt (x + 1) - it "should fail for the wrong number of arguments" $ - call testFun [] `shouldThrow` isNeovimException + describe "calling test function with a map argument" $ do + let EF (Function fname _, testFun) = $(TH.function "TestFunctionMap" 'testFunctionMap) Sync + it "should capitalize the first letter" $ + fname `shouldBe` F "TestFunctionMap" - it "should fail for the wrong type of arguments" $ - call testFun [ObjectInt 7, ObjectString "FOO"] `shouldThrow` isNeovimException + it "should fail for the wrong number of arguments" $ + call testFun [] `shouldThrow` isNeovimException - it "should return Nothing for an empty map" $ - call testFun [toObject (Map.empty :: Map.Map String Int), ObjectString "FOO"] - `shouldReturn` ObjectNil + it "should fail for the wrong type of arguments" $ + call testFun [ObjectInt 7, ObjectString "FOO"] `shouldThrow` isNeovimException - it "should return just the value for the singletion entry" $ - call testFun [toObject (Map.singleton "FOO" 7 :: Map.Map String Int), ObjectString "FOO"] - `shouldReturn` ObjectInt 7 + it "should return Nothing for an empty map" $ + call testFun [toObject (Map.empty :: Map.Map String Int), ObjectString "FOO"] + `shouldReturn` ObjectNil + it "should return just the value for the singletion entry" $ + call testFun [toObject (Map.singleton "FOO" 7 :: Map.Map String Int), ObjectString "FOO"] + `shouldReturn` ObjectInt 7 - describe "Calling function with an optional argument" $ do - let EF (Command cname _, testFun) = $(command' 'testCommandOptArgument) [] - defCmdArgs = toObject (def :: CommandArguments) - it "should capitalize the first letter" $ - cname `shouldBe` F "TestCommandOptArgument" + describe "Calling function with an optional argument" $ do + let EF (Command cname _, testFun) = $(command' 'testCommandOptArgument) [] + defCmdArgs = toObject (def :: CommandArguments) + it "should capitalize the first letter" $ + cname `shouldBe` F "TestCommandOptArgument" - it "should return \"default\" when passed no argument" $ do - call testFun [defCmdArgs] `shouldReturn` toObject ("default" :: String) + it "should return \"default\" when passed no argument" $ do + call testFun [defCmdArgs] `shouldReturn` toObject ("default" :: String) - it "should return what is passed otherwise" . property $ do - \str -> call testFun [defCmdArgs, toObject str] - `shouldReturn` toObject (str :: String) + it "should return what is passed otherwise" . property $ do + \str -> + call testFun [defCmdArgs, toObject str] + `shouldReturn` toObject (str :: String) diff --git a/test-suite/Neovim/API/THSpecFunctions.hs b/test-suite/Neovim/API/THSpecFunctions.hs --- a/test-suite/Neovim/API/THSpecFunctions.hs +++ b/test-suite/Neovim/API/THSpecFunctions.hs @@ -1,8 +1,7 @@ -module Neovim.API.THSpecFunctions - where +module Neovim.API.THSpecFunctions where import qualified Data.Map as Map -import Neovim +import Neovim testFunction0 :: Neovim env Int testFunction0 = return 42 @@ -18,5 +17,5 @@ testCommandOptArgument :: CommandArguments -> Maybe String -> Neovim env String testCommandOptArgument _ ms = case ms of - Just x -> return x + Just x -> return x Nothing -> return "default" diff --git a/test-suite/Neovim/EmbeddedRPCSpec.hs b/test-suite/Neovim/EmbeddedRPCSpec.hs --- a/test-suite/Neovim/EmbeddedRPCSpec.hs +++ b/test-suite/Neovim/EmbeddedRPCSpec.hs @@ -1,86 +1,91 @@ -{-# LANGUAGE LambdaCase #-} -module Neovim.EmbeddedRPCSpec - where +{-# LANGUAGE LambdaCase #-} -import Test.Hspec +module Neovim.EmbeddedRPCSpec where + import Test.HUnit +import Test.Hspec -import Neovim -import Neovim.API.Text -import Neovim.Context (docToText) +import Neovim +import Neovim.API.Text +import Neovim.Context (docToText) import qualified Neovim.Context.Internal as Internal -import Neovim.Quickfix -import Neovim.RPC.Common -import Neovim.RPC.EventHandler -import Neovim.RPC.FunctionCall (atomically') -import Neovim.RPC.SocketReader -import Neovim.Test - -import Control.Concurrent -import Control.Concurrent.STM -import Control.Monad.Reader (runReaderT) -import Control.Monad.State (runStateT) -import qualified Data.Map as Map -import Path -import Path.IO -import System.Exit (ExitCode (..)) -import System.Process.Typed +import Neovim.Quickfix +import Neovim.RPC.Common +import Neovim.RPC.EventHandler +import Neovim.RPC.FunctionCall (atomically') +import Neovim.RPC.SocketReader +import Neovim.Test +import Control.Concurrent +import Control.Concurrent.STM +import Control.Monad.Reader (runReaderT) +import Control.Monad.State (runStateT) +import qualified Data.Map as Map +import Path +import Path.IO +import System.Exit (ExitCode (..)) +import System.Process.Typed --- | Tests in here should always be wrapped in 'withNeovimEmbedded' because they --- don't fail if neovim isn't installed. This is particularly helpful to run --- tests on stackage and be notified if non-neovim-dependent tests fail. --- Basically everybody else who runs these tests has neovim installed and would --- see the test failing. +{- | Tests in here should always be wrapped in 'withNeovimEmbedded' because they + don't fail if neovim isn't installed. This is particularly helpful to run + tests on stackage and be notified if non-neovim-dependent tests fail. + Basically everybody else who runs these tests has neovim installed and would + see the test failing. +-} spec :: Spec spec = parallel $ do - let withNeovimEmbedded f a = testWithEmbeddedNeovim f (Seconds 3) () a - describe "Read hello test file" . - it "should match 'Hello, World!'" . withNeovimEmbedded Nothing $ do - nvim_command "edit test-files/hello" - bs <- vim_get_buffers - l <- vim_get_current_line - liftIO $ l `shouldBe` "Hello, World!" - liftIO $ length bs `shouldBe` 1 + let withNeovimEmbedded :: Maybe (Path.Path b File) -> Neovim () a -> IO () + withNeovimEmbedded f = testWithEmbeddedNeovim f (Seconds 3) () + describe "Read hello test file" + . it "should match 'Hello, World!'" + . withNeovimEmbedded Nothing + $ do + nvim_command "edit test-files/hello" + bs <- vim_get_buffers + l <- vim_get_current_line + liftIO $ l `shouldBe` "Hello, World!" + liftIO $ length bs `shouldBe` 1 - describe "New empty buffer test" $ do - it "should contain the test text" . withNeovimEmbedded Nothing $ do - cl0 <- vim_get_current_line - liftIO $ cl0 `shouldBe` "" - bs <- vim_get_buffers - liftIO $ length bs `shouldBe` 1 + describe "New empty buffer test" $ do + it "should contain the test text" . withNeovimEmbedded Nothing $ do + cl0 <- vim_get_current_line + liftIO $ cl0 `shouldBe` "" + bs <- vim_get_buffers + liftIO $ length bs `shouldBe` 1 - let testContent = "Test on empty buffer" - vim_set_current_line testContent - cl1 <- vim_get_current_line - liftIO $ cl1 `shouldBe` testContent + let testContent = "Test on empty buffer" + vim_set_current_line testContent + cl1 <- vim_get_current_line + liftIO $ cl1 `shouldBe` testContent - it "should create a new buffer" . withNeovimEmbedded Nothing $ do - bs0 <- vim_get_buffers - liftIO $ length bs0 `shouldBe` 1 - vim_command "new" - bs1 <- vim_get_buffers - liftIO $ length bs1 `shouldBe` 2 - vim_command "new" - bs2 <- vim_get_buffers - liftIO $ length bs2 `shouldBe` 3 + it "should create a new buffer" . withNeovimEmbedded Nothing $ do + bs0 <- vim_get_buffers + liftIO $ length bs0 `shouldBe` 1 + vim_command "new" + bs1 <- vim_get_buffers + liftIO $ length bs1 `shouldBe` 2 + vim_command "new" + bs2 <- vim_get_buffers + liftIO $ length bs2 `shouldBe` 3 - it "should set the quickfix list" . withNeovimEmbedded Nothing $ do - let q = quickfixListItem (Left 1) (Left 0) :: QuickfixListItem String - setqflist [q] Replace - q' <- vim_eval "getqflist()" - liftIO $ fromObjectUnsafe q' `shouldBe` [q] + it "should set the quickfix list" . withNeovimEmbedded Nothing $ do + let q = quickfixListItem (Left 1) (Left 0) :: QuickfixListItem String + setqflist [q] Replace + q' <- vim_eval "getqflist()" + liftIO $ fromObjectUnsafe q' `shouldBe` [q] - it "throws NeovimException with function that failed as Doc" . withNeovimEmbedded Nothing $ do - let getVariableValue = False <$ vim_get_var "notDefined" - hasTrhownNeovimExceptionWithFunctionName <- getVariableValue `catchNeovimException` \case - ErrorResult f _ -> pure $ docToText f == "vim_get_var" - _ -> pure False - liftIO $ hasTrhownNeovimExceptionWithFunctionName `shouldBe` True + it "throws NeovimException with function that failed as Doc" . withNeovimEmbedded Nothing $ do + let getVariableValue = False <$ vim_get_var "notDefined" + hasTrhownNeovimExceptionWithFunctionName <- + getVariableValue `catchNeovimException` \case + ErrorResult f _ -> pure $ docToText f == "vim_get_var" + _ -> pure False + liftIO $ hasTrhownNeovimExceptionWithFunctionName `shouldBe` True - it "catches" . withNeovimEmbedded Nothing $ do - let getUndefinedVariable = vim_get_var "notDefined" - functionThatFailed <- getUndefinedVariable `catchNeovimException` \case - ErrorResult f _ -> pure . toObject $ docToText f - _ -> pure ObjectNil - liftIO $ functionThatFailed `shouldBe` toObject ("vim_get_var" :: String) + it "catches" . withNeovimEmbedded Nothing $ do + let getUndefinedVariable = vim_get_var "notDefined" + functionThatFailed <- + getUndefinedVariable `catchNeovimException` \case + ErrorResult f _ -> pure . toObject $ docToText f + _ -> pure ObjectNil + liftIO $ functionThatFailed `shouldBe` toObject ("vim_get_var" :: String) diff --git a/test-suite/Neovim/EventSubscriptionSpec.hs b/test-suite/Neovim/EventSubscriptionSpec.hs new file mode 100644 --- /dev/null +++ b/test-suite/Neovim/EventSubscriptionSpec.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Neovim.EventSubscriptionSpec where + +import Neovim +import Neovim.API.String +import Neovim.Test + +import Test.Hspec + +import UnliftIO (newEmptyMVar, putMVar, readMVar) + +data BufLinesEvent = BufLinesEvent + { bleBuffer :: Buffer + , bleFirstLine :: Int + , bleLastLine :: Int + , bleLines :: [String] + , bleMore :: Bool + } + deriving (Eq, Show) + +parseBufLinesEvent :: [Object] -> Either (Doc AnsiStyle) BufLinesEvent +parseBufLinesEvent event = case event of + [buf, _changedTick, firstline, lastline, linedata, more] -> do + bleBuffer <- fromObject buf + bleFirstLine <- fromObject firstline + bleLastLine <- fromObject lastline + bleLines <- fromObject linedata + bleMore <- fromObject more + pure BufLinesEvent{..} + _ -> Left . pretty $ "Unexpected nvim_buf_lines_event: " ++ show event + +spec :: Spec +spec = parallel $ do + let withNeovimEmbedded = testWithEmbeddedNeovim Nothing (Seconds 2) () + describe "Attaching to a buffer" $ do + it "receives nvim_buf_lines_event" . withNeovimEmbedded $ do + received <- newEmptyMVar + subscribe "nvim_buf_lines_event" $ putMVar received . parseBufLinesEvent + buf <- nvim_create_buf True False + isOk <- nvim_buf_attach buf True [] + + liftIO $ do + isOk `shouldBe` True + Right BufLinesEvent{..} <- readMVar received + bleBuffer `shouldBe` buf + bleFirstLine `shouldBe` 0 + bleLastLine `shouldBe` -1 + bleLines `shouldBe` [""] + bleMore `shouldBe` False + + it "receives nvim_buf_detach_event" . withNeovimEmbedded $ do + received <- newEmptyMVar + subscribe "nvim_buf_detach_event" $ putMVar received + buf <- nvim_create_buf True False + isOk <- nvim_buf_attach buf False [] + nvim_buf_detach buf + + liftIO $ do + isOk `shouldBe` True + [buf'] <- readMVar received + fromObjectUnsafe buf' `shouldBe` buf diff --git a/test-suite/Neovim/Plugin/ClassesSpec.hs b/test-suite/Neovim/Plugin/ClassesSpec.hs --- a/test-suite/Neovim/Plugin/ClassesSpec.hs +++ b/test-suite/Neovim/Plugin/ClassesSpec.hs @@ -1,20 +1,18 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE RecordWildCards #-} -module Neovim.Plugin.ClassesSpec - where -import Neovim -import Neovim.Plugin.Classes +module Neovim.Plugin.ClassesSpec where -import Test.Hspec -import Test.QuickCheck +import Neovim +import Neovim.Plugin.Classes +import Test.Hspec +import Test.QuickCheck -newtype RandomCommandArguments = RCA { getRandomCommandArguments :: CommandArguments } +newtype RandomCommandArguments = RCA {getRandomCommandArguments :: CommandArguments} deriving (Eq, Ord, Show, Read) - instance Arbitrary RandomCommandArguments where arbitrary = do bang <- arbitrary @@ -23,14 +21,12 @@ register <- fmap (fmap getNonEmpty) arbitrary return . RCA $ CommandArguments{..} - -newtype RandomCommandOption = RCO { getRandomCommandOption :: CommandOption } +newtype RandomCommandOption = RCO {getRandomCommandOption :: CommandOption} deriving (Eq, Ord, Show, Read) - instance Arbitrary RandomCommandOption where arbitrary = do - a <- choose (0,5) :: Gen Int + a <- choose (0, 5) :: Gen Int o <- case a of -- XXX Most constructor arguments are not tested anyway, so they are -- hardcoded for now. @@ -42,30 +38,28 @@ _ -> return CmdBang return $ RCO o - -newtype RandomCommandOptions = RCOs { getRandomCommandOptions :: CommandOptions } +newtype RandomCommandOptions = RCOs {getRandomCommandOptions :: CommandOptions} deriving (Eq, Ord, Show, Read) - instance Arbitrary RandomCommandOptions where arbitrary = do - l <- choose (0,20) + l <- choose (0, 20) (RCOs . mkCommandOptions . map getRandomCommandOption) <$> vectorOf l arbitrary - spec :: Spec spec = do - describe "Deserializing and serializing" $ do - it "should be id for CommandArguments" . property $ do - \args -> (fromObjectUnsafe . toObject . getRandomCommandArguments) args - `shouldBe` getRandomCommandArguments args - - describe "If a sync option is set for commands" $ do - let isSyncOption = \case - CmdSync _ -> True - _ -> False - it "must be at the head of the list" . property $ do - \(RCOs opts) -> any isSyncOption (getCommandOptions opts) ==> do - length (filter isSyncOption (getCommandOptions opts)) `shouldBe` 1 - head (getCommandOptions opts) `shouldSatisfy` isSyncOption + describe "Deserializing and serializing" $ do + it "should be id for CommandArguments" . property $ do + \args -> + (fromObjectUnsafe . toObject . getRandomCommandArguments) args + `shouldBe` getRandomCommandArguments args + describe "If a sync option is set for commands" $ do + let isSyncOption = \case + CmdSync _ -> True + _ -> False + it "must be at the head of the list" . property $ do + \(RCOs opts) -> + any isSyncOption (getCommandOptions opts) ==> do + length (filter isSyncOption (getCommandOptions opts)) `shouldBe` 1 + head (getCommandOptions opts) `shouldSatisfy` isSyncOption diff --git a/test-suite/Neovim/RPC/CommonSpec.hs b/test-suite/Neovim/RPC/CommonSpec.hs --- a/test-suite/Neovim/RPC/CommonSpec.hs +++ b/test-suite/Neovim/RPC/CommonSpec.hs @@ -6,15 +6,15 @@ spec :: Spec spec = do - describe "Parsing of $NVIM environment variable" $ do - it "is a UnixSocket if it doesn't contain a colon" $ do - UnixSocket actual <- parseNvimEnvironmentVariable "/some/file" - actual `shouldBe` "/some/file" - it "is a tcp connection if it contains a colon" $ do - TCP actualPort actualHostname <- parseNvimEnvironmentVariable "localhost:12345" - actualPort `shouldBe` 12345 - actualHostname `shouldBe` "localhost" - it "the last number after many colons is the port" $ do - TCP actualPort actualHostname <- parseNvimEnvironmentVariable "the:cake:is:a:lie:777" - actualPort `shouldBe` 777 - actualHostname `shouldBe` "the:cake:is:a:lie" + describe "Parsing of $NVIM environment variable" $ do + it "is a UnixSocket if it doesn't contain a colon" $ do + UnixSocket actual <- parseNvimEnvironmentVariable "/some/file" + actual `shouldBe` "/some/file" + it "is a tcp connection if it contains a colon" $ do + TCP actualPort actualHostname <- parseNvimEnvironmentVariable "localhost:12345" + actualPort `shouldBe` 12345 + actualHostname `shouldBe` "localhost" + it "the last number after many colons is the port" $ do + TCP actualPort actualHostname <- parseNvimEnvironmentVariable "the:cake:is:a:lie:777" + actualPort `shouldBe` 777 + actualHostname `shouldBe` "the:cake:is:a:lie" diff --git a/test-suite/Neovim/RPC/SocketReaderSpec.hs b/test-suite/Neovim/RPC/SocketReaderSpec.hs --- a/test-suite/Neovim/RPC/SocketReaderSpec.hs +++ b/test-suite/Neovim/RPC/SocketReaderSpec.hs @@ -1,67 +1,77 @@ {-# LANGUAGE OverloadedStrings #-} -module Neovim.RPC.SocketReaderSpec - where -import Neovim -import Neovim.Plugin.Classes -import Neovim.RPC.SocketReader (parseParams) +module Neovim.RPC.SocketReaderSpec where -import Test.Hspec +import Neovim +import Neovim.Plugin.Classes +import Neovim.RPC.SocketReader (parseParams) +import Test.Hspec + spec :: Spec spec = do - describe "parseParams" $ do - - it "should pass the inner argument list as is for functions" $ do - parseParams (Function (F "") Sync) [ObjectArray [ObjectNil, ObjectBinary "ABC"]] - `shouldBe` [ObjectNil, ObjectBinary "ABC"] - parseParams (Function (F "") Sync) [ObjectNil, ObjectBinary "ABC"] - `shouldBe` [ObjectNil, ObjectBinary "ABC"] - parseParams (Function (F "") Sync) [] - `shouldBe` [] - - let defCmdArgs = def :: CommandArguments - it "should filter out implicit arguments" $ do - parseParams (Command (F "") (mkCommandOptions [CmdSync Sync, CmdNargs "*"])) - [ObjectArray []] - `shouldBe` [toObject defCmdArgs] - parseParams (Command (F "") (mkCommandOptions [CmdSync Sync, CmdNargs "*"])) - [ObjectArray [ObjectBinary "7", ObjectInt 7]] - `shouldBe` [toObject defCmdArgs, ObjectBinary "7", ObjectInt 7] + describe "parseParams" $ do + it "should pass the inner argument list as is for functions" $ do + parseParams (Function (F "") Sync) [ObjectArray [ObjectNil, ObjectBinary "ABC"]] + `shouldBe` [ObjectNil, ObjectBinary "ABC"] + parseParams (Function (F "") Sync) [ObjectNil, ObjectBinary "ABC"] + `shouldBe` [ObjectNil, ObjectBinary "ABC"] + parseParams (Function (F "") Sync) [] + `shouldBe` [] - it "should set the CommandOptions argument as expected" $ do - parseParams (Command (F "") (mkCommandOptions - [ CmdRange WholeFile, CmdBang, CmdNargs "*"])) - [ ObjectArray [ObjectBinary "7", ObjectBinary "8", ObjectNil] - , ObjectArray [ObjectInt 1, ObjectInt 12] - , ObjectInt 1 - ] - `shouldBe` [ toObject (defCmdArgs { bang = Just True, range = Just (1,12) }) - , ObjectBinary "7" - , ObjectBinary "8" - , ObjectNil] + let defCmdArgs = def :: CommandArguments + it "should filter out implicit arguments" $ do + parseParams + (Command (F "") (mkCommandOptions [CmdSync Sync, CmdNargs "*"])) + [ObjectArray []] + `shouldBe` [toObject defCmdArgs] + parseParams + (Command (F "") (mkCommandOptions [CmdSync Sync, CmdNargs "*"])) + [ObjectArray [ObjectBinary "7", ObjectInt 7]] + `shouldBe` [toObject defCmdArgs, ObjectBinary "7", ObjectInt 7] - it "should pass this test" $ do - parseParams (Command (F "") (mkCommandOptions [CmdNargs "+", CmdRange WholeFile, CmdBang])) - [ ObjectArray [ ObjectBinary "me" - , ObjectBinary "up" - , ObjectBinary "before" - , ObjectBinary "you" - , ObjectBinary "go" - , ObjectBinary "go" - ] - , ObjectArray [ ObjectInt 1 - , ObjectInt 27 - ] - , ObjectInt 0 - ] - `shouldBe` [ toObject (defCmdArgs { bang = Just False, range = Just (1,27) }) - , ObjectBinary "me" - , ObjectArray [ ObjectBinary "up" - , ObjectBinary "before" - , ObjectBinary "you" - , ObjectBinary "go" - , ObjectBinary "go" - ] - ] + it "should set the CommandOptions argument as expected" $ do + parseParams + ( Command + (F "") + ( mkCommandOptions + [CmdRange WholeFile, CmdBang, CmdNargs "*"] + ) + ) + [ ObjectArray [ObjectBinary "7", ObjectBinary "8", ObjectNil] + , ObjectArray [ObjectInt 1, ObjectInt 12] + , ObjectInt 1 + ] + `shouldBe` [ toObject (defCmdArgs{bang = Just True, range = Just (1, 12)}) + , ObjectBinary "7" + , ObjectBinary "8" + , ObjectNil + ] + it "should pass this test" $ do + parseParams + (Command (F "") (mkCommandOptions [CmdNargs "+", CmdRange WholeFile, CmdBang])) + [ ObjectArray + [ ObjectBinary "me" + , ObjectBinary "up" + , ObjectBinary "before" + , ObjectBinary "you" + , ObjectBinary "go" + , ObjectBinary "go" + ] + , ObjectArray + [ ObjectInt 1 + , ObjectInt 27 + ] + , ObjectInt 0 + ] + `shouldBe` [ toObject (defCmdArgs{bang = Just False, range = Just (1, 27)}) + , ObjectBinary "me" + , ObjectArray + [ ObjectBinary "up" + , ObjectBinary "before" + , ObjectBinary "you" + , ObjectBinary "go" + , ObjectBinary "go" + ] + ]