diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,14 @@ +# 0.0.2 + +* Add handling for special command options + + This breaks code that used `command` or `command'` to export + functionality. You should replace the options with a list + of `CommandOptions`. + + An export like `$(command' foo) def { cmdSync = Async }` must be redefined + to `$(command' foo) [CmdSync Async]`. + +# 0.0.1 + +* Usable prototype implementation diff --git a/TestPlugins.hs b/TestPlugins.hs --- a/TestPlugins.hs +++ b/TestPlugins.hs @@ -23,6 +23,11 @@ { exports = [ EF (Function "Randoom" Sync, randoom) , EF (Function "Const42" Sync, const42) , EF (Function "PingNvimhs" Sync, pingNvimhs) + , EF (Command "ComplicatedSpecialArgsHandling" + (mkCommandOptions [ CmdSync Sync, CmdRange WholeFile + , CmdBang , CmdNargs "+" + ]) + , complicatedCommand) ] , statefulExports = [((), randomNumbers, @@ -31,6 +36,9 @@ ]) ] } + +complicatedCommand :: [Object] -> Neovim r st Object +complicatedCommand = undefined rf :: [Object] -> Neovim cfg [Int16] Object rf _ = do diff --git a/library/Neovim.hs b/library/Neovim.hs --- a/library/Neovim.hs +++ b/library/Neovim.hs @@ -52,7 +52,9 @@ command', autocmd, Synchronous(..), - CommandOptions(..), + CommandOption(..), + RangeSpecification(..), + CommandArguments(..), AutocmdOptions(..), -- TODO make Neovim a newtype wrapper with MonadReader and MonadState @@ -103,8 +105,10 @@ gets, modify, put) import Neovim.Main (neovim) import Neovim.Plugin.Classes (AutocmdOptions (..), - CommandOptions (..), + CommandArguments (..), + CommandOption (CmdSync, CmdRegister, CmdRange, CmdCount, CmdBang), NeovimPlugin (..), Plugin (..), + RangeSpecification (..), Synchronous (..), wrapPlugin) import Neovim.RPC.FunctionCall (wait, wait', waitErr, waitErr') 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 @@ -10,6 +10,10 @@ Maintainer : woozletoff@gmail.com Stability : experimental +Note that this module is completely generated. If you're reading this on +hackage, the actual functions of this module may be different from what is +available to you. All the functions in this module depend on the neovim version +that was used when this package was compiled. -} module Neovim.API.String where 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 @@ -27,9 +27,11 @@ import Neovim.API.Parser import Neovim.Classes import Neovim.Context -import Neovim.Plugin.Classes (CommandOptions (..), +import Neovim.Plugin.Classes (CommandArguments (..), + CommandOption (..), ExportedFunctionality (..), - FunctionalityDescription (..)) + FunctionalityDescription (..), + mkCommandOptions) import Neovim.RPC.FunctionCall import Language.Haskell.TH @@ -48,7 +50,8 @@ import Data.Maybe import Data.MessagePack import Data.Monoid -import Data.Text (pack) +import qualified Data.Set as Set +import Data.Text (Text, pack) import Prelude @@ -262,6 +265,43 @@ in function (toUpper c:cs) functionName +-- | Simply data type used to identify a string-ish type (e.g. 'String', 'Text', +-- 'ByteString' for a value of type. +data ArgType = StringyType + | ListOfStringyTypes + | OptionalStringyType + | CommandArgumentsType + | OtherType + deriving (Eq, Ord, Show, Read, Enum, Bounded) + + +-- | Given a value of type 'Type', test whether it can be classified according +-- to the constructors of 'ArgType'. +classifyArgType :: Type -> Q ArgType +classifyArgType t = do + set <- genStringTypesSet + maybeType <- [t|Maybe|] + cmdArgsType <- [t|CommandArguments|] + return $ case t of + AppT ListT (ConT str) | str `Set.member` set + -> ListOfStringyTypes + + AppT m (ConT str) | m == maybeType && str `Set.member` set + -> OptionalStringyType + + ConT str | str `Set.member` set + -> StringyType + cmd | cmd == cmdArgsType + -> CommandArgumentsType + + _ -> OtherType + + where + genStringTypesSet = do + types <- sequence [[t|String|],[t|ByteString|],[t|Text|]] + return $ Set.fromList [ n | ConT n <- types ] + + -- | Similarly to 'function', this function is used to export a command with a -- custom name. -- @@ -271,9 +311,29 @@ command customFunctionName@(c:_) functionName | (not . isUpper) c = error $ "Custom command name must start with a capiatl letter: " <> show customFunctionName | otherwise = do - (nargs, fun) <- functionImplementation functionName - [|\copts -> EF (Command (pack $(litE (StringL customFunctionName))) (copts { cmdNargs = nargs }), $(return fun))|] - + (argTypes, fun) <- functionImplementation functionName + -- See :help :command-nargs for what the result strings mean + cts <- mapM classifyArgType argTypes + case cts of + (CommandArgumentsType:_) -> return () + _ -> error "First argument for a function exported as a command must be CommandArguments!" + let nargs = case tail cts of + [] -> [|CmdNargs "0"|] + [StringyType] -> [|CmdNargs "1"|] + [OptionalStringyType] -> [|CmdNargs "?"|] + [ListOfStringyTypes] -> [|CmdNargs "*"|] + [StringyType, ListOfStringyTypes] -> [|CmdNargs "+"|] + _ -> error $ unlines + [ "Trying to generate a command without compatible types." + , "Due to a limitation burdened on us by vimL, we can only" + , "use a limited amount type signatures for commands. See" + , "the documentation for 'command' for am ore thorough" + , "explanation." + ] + [|\copts -> EF (Command + (pack $(litE (StringL customFunctionName))) + (mkCommandOptions ($(nargs) : copts)) + , $(return fun))|] -- | Define an exported command. This function works exactly like 'command', but -- it generates the command name by converting the first letter to upper case. @@ -311,7 +371,7 @@ -- _ -> err $ "Wrong number of arguments for add: " ++ show xs -- @ -- -functionImplementation :: Name -> Q (Int, Exp) +functionImplementation :: Name -> Q ([Type], Exp) functionImplementation functionName = do fInfo <- reify functionName -- We only need the number of arguments to generate the appropriate function @@ -319,15 +379,15 @@ VarI _ functionType _ _ -> determineNumberOfArguments functionType x -> error $ "Value given to function is (likely) not the name of a function.\n" <> show x - e <- topLevelCase nargs + e <- topLevelCase (length nargs) return (nargs, e) where - determineNumberOfArguments :: Type -> Int + determineNumberOfArguments :: Type -> [Type] determineNumberOfArguments ft = case ft of ForallT _ _ t -> determineNumberOfArguments t - AppT (AppT ArrowT _) r -> 1 + determineNumberOfArguments r - _ -> 0 + AppT (AppT ArrowT t) r -> t : determineNumberOfArguments r + _ -> [] -- \args -> case args of ... topLevelCase :: Int -> Q Exp topLevelCase n = newName "args" >>= \args -> diff --git a/library/Neovim/Classes.hs b/library/Neovim/Classes.hs --- a/library/Neovim/Classes.hs +++ b/library/Neovim/Classes.hs @@ -2,6 +2,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverlappingInstances #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {- | Module : Neovim.Classes @@ -51,6 +52,7 @@ -- to neovim's interpretation. class NvimObject o where toObject :: o -> Object + fromObjectUnsafe :: Object -> o fromObjectUnsafe o = case fromObject o of Left e -> error $ unwords @@ -58,92 +60,123 @@ , show o , "(", e, ")" ] Right obj -> obj + fromObject :: (NvimObject o) => Object -> Either String o fromObject = return . fromObjectUnsafe + -- Instances for NvimObject {{{1 instance NvimObject () where toObject _ = ObjectNil + fromObject ObjectNil = return () fromObject o = throwError $ "Expected ObjectNil, but got " <> show o + -- We may receive truthy values from neovim, so we should be more forgiving -- here. instance NvimObject Bool where - toObject = ObjectBool - fromObject (ObjectBool o) = return o - fromObject (ObjectInt 0) = return False - fromObject ObjectNil = return False - fromObject _ = return True + toObject = ObjectBool + fromObject (ObjectBool o) = return o + fromObject (ObjectInt 0) = return False + fromObject ObjectNil = return False + fromObject (ObjectBinary "0") = return False + fromObject (ObjectBinary "") = return False + fromObject (ObjectString "0") = return False + fromObject (ObjectString "") = return False + fromObject _ = return True + + instance NvimObject Double where toObject = ObjectDouble + fromObject (ObjectDouble o) = return o fromObject (ObjectFloat o) = return $ realToFrac o fromObject (ObjectInt o) = return $ fromIntegral o fromObject o = throwError $ "Expected ObjectDouble, but got " <> show o + instance NvimObject Integer where toObject = ObjectInt . fromIntegral + fromObject (ObjectInt o) = return $ toInteger o fromObject (ObjectDouble o) = return $ round o fromObject (ObjectFloat o) = return $ round o fromObject o = throwError $ "Expected ObjectInt, but got " <> show o + instance NvimObject Int64 where toObject = ObjectInt + fromObject (ObjectInt i) = return i fromObject (ObjectDouble o) = return $ round o fromObject (ObjectFloat o) = return $ round o fromObject o = throwError $ "Expected any Integer value, but got " <> show o + instance NvimObject Int32 where toObject = ObjectInt . fromIntegral + fromObject (ObjectInt i) = return $ fromIntegral i fromObject (ObjectDouble o) = return $ round o fromObject (ObjectFloat o) = return $ round o fromObject o = throwError $ "Expected any Integer value, but got " <> show o + instance NvimObject Int16 where toObject = ObjectInt . fromIntegral + fromObject (ObjectInt i) = return $ fromIntegral i fromObject (ObjectDouble o) = return $ round o fromObject (ObjectFloat o) = return $ round o fromObject o = throwError $ "Expected any Integer value, but got " <> show o + instance NvimObject Int where toObject = ObjectInt . fromIntegral + fromObject (ObjectInt i) = return $ fromIntegral i fromObject (ObjectDouble o) = return $ round o fromObject (ObjectFloat o) = return $ round o fromObject o = throwError $ "Expected any Integer value, but got " <> show o + instance NvimObject Char where toObject c = ObjectBinary . U.fromString $ [c] + fromObject str = case fromObject str of Right [c] -> return c _ -> throwError $ "Expected one element string but got: " <> show str + instance NvimObject [Char] where toObject = ObjectBinary . U.fromString + fromObject (ObjectBinary o) = return $ U.toString o fromObject (ObjectString o) = return $ U.toString o fromObject o = throwError $ "Expected ObjectBinary, but got " <> show o + instance NvimObject o => NvimObject [o] where toObject = ObjectArray . map toObject - fromObject (ObjectArray os) = return $ map fromObjectUnsafe os + + fromObject (ObjectArray os) = mapM fromObject os fromObject o = throwError $ "Expected ObjectArray, but got " <> show o + instance NvimObject o => NvimObject (Maybe o) where toObject = maybe ObjectNil toObject + fromObject ObjectNil = return Nothing fromObject o = either throwError (return . Just) $ fromObject o + instance (Ord key, NvimObject key, NvimObject val) => NvimObject (Map key val) where toObject = ObjectMap . Map.fromList . map (toObject *** toObject) . Map.toList + fromObject (ObjectMap om) = Map.fromList <$> (sequenceA . map (uncurry (liftA2 (,)) @@ -152,25 +185,33 @@ fromObject o = throwError $ "Expected ObjectMap, but got " <> show o + instance NvimObject Text where toObject = ObjectBinary . encodeUtf8 + fromObject (ObjectBinary o) = return $ decodeUtf8 o fromObject (ObjectString o) = return $ decodeUtf8 o fromObject o = throwError $ "Expected ObjectBinary, but got " <> show o + instance NvimObject ByteString where toObject = ObjectBinary + fromObject (ObjectBinary o) = return o fromObject o = throwError $ "Expected ObjectBinary, but got " <> show o + instance NvimObject Object where toObject = id + fromObject = return fromObjectUnsafe = id + -- By the magic of vim, i will create these. instance NvimObject o => NvimObject (o, o) where toObject (o1, o2) = ObjectArray $ map toObject [o1, o2] + fromObject (ObjectArray [o1, o2]) = (,) <$> fromObject o1 <*> fromObject o2 @@ -178,14 +219,17 @@ instance NvimObject o => NvimObject (o, o, o) where toObject (o1, o2, o3) = ObjectArray $ map toObject [o1, o2, o3] + fromObject (ObjectArray [o1, o2, o3]) = (,,) <$> fromObject o1 <*> fromObject o2 <*> fromObject o3 fromObject o = throwError $ "Expected ObjectArray, but got " <> show o + instance NvimObject o => NvimObject (o, o, o, o) where toObject (o1, o2, o3, o4) = ObjectArray $ map toObject [o1, o2, o3, o4] + fromObject (ObjectArray [o1, o2, o3, o4]) = (,,,) <$> fromObject o1 <*> fromObject o2 @@ -193,8 +237,10 @@ <*> fromObject o4 fromObject o = throwError $ "Expected ObjectArray, but got " <> show o + instance NvimObject o => NvimObject (o, o, o, o, o) where toObject (o1, o2, o3, o4, o5) = ObjectArray $ map toObject [o1, o2, o3, o4, o5] + fromObject (ObjectArray [o1, o2, o3, o4, o5]) = (,,,,) <$> fromObject o1 <*> fromObject o2 @@ -203,8 +249,10 @@ <*> fromObject o5 fromObject o = throwError $ "Expected ObjectArray, but got " <> show o + instance NvimObject o => NvimObject (o, o, o, o, o, o) where toObject (o1, o2, o3, o4, o5, o6) = ObjectArray $ map toObject [o1, o2, o3, o4, o5, o6] + fromObject (ObjectArray [o1, o2, o3, o4, o5, o6]) = (,,,,,) <$> fromObject o1 <*> fromObject o2 @@ -214,8 +262,10 @@ <*> fromObject o6 fromObject o = throwError $ "Expected ObjectArray, but got " <> show o + instance NvimObject o => NvimObject (o, o, o, o, o, o, o) where toObject (o1, o2, o3, o4, o5, o6, o7) = ObjectArray $ map toObject [o1, o2, o3, o4, o5, o6, o7] + fromObject (ObjectArray [o1, o2, o3, o4, o5, o6, o7]) = (,,,,,,) <$> fromObject o1 <*> fromObject o2 @@ -226,8 +276,10 @@ <*> fromObject o7 fromObject o = throwError $ "Expected ObjectArray, but got " <> show o + instance NvimObject o => NvimObject (o, o, o, o, o, o, o, o) where toObject (o1, o2, o3, o4, o5, o6, o7, o8) = ObjectArray $ map toObject [o1, o2, o3, o4, o5, o6, o7, o8] + fromObject (ObjectArray [o1, o2, o3, o4, o5, o6, o7, o8]) = (,,,,,,,) <$> fromObject o1 <*> fromObject o2 @@ -239,8 +291,10 @@ <*> fromObject o8 fromObject o = throwError $ "Expected ObjectArray, but got " <> show o + instance NvimObject o => NvimObject (o, o, o, o, o, o, o, o, o) where toObject (o1, o2, o3, o4, o5, o6, o7, o8, o9) = ObjectArray $ map toObject [o1, o2, o3, o4, o5, o6, o7, o8, o9] + fromObject (ObjectArray [o1, o2, o3, o4, o5, o6, o7, o8, o9]) = (,,,,,,,,) <$> fromObject o1 <*> fromObject o2 @@ -252,5 +306,6 @@ <*> fromObject o8 <*> fromObject o9 fromObject o = throwError $ "Expected ObjectArray, but got " <> show o + -- 1}}} diff --git a/library/Neovim/Plugin.hs b/library/Neovim/Plugin.hs --- a/library/Neovim/Plugin.hs +++ b/library/Neovim/Plugin.hs @@ -18,25 +18,24 @@ NeovimPlugin, Plugin(..), Synchronous(..), - CommandOptions(..), + CommandOption(..), ) where import Neovim.API.String import Neovim.Classes import Neovim.Context -import Neovim.Plugin.Classes +import Neovim.Plugin.Classes hiding (register) import Neovim.Plugin.IPC import Neovim.Plugin.IPC.Internal import Neovim.RPC.Common import Neovim.RPC.FunctionCall -import Control.Arrow (first, (&&&)) +import Control.Arrow ((&&&)) import Control.Concurrent (ThreadId) import Control.Concurrent.STM import Control.Exception.Lifted (SomeException, try) import Control.Monad (foldM, forM, void) import qualified Control.Monad.Reader as R -import Data.ByteString (ByteString) import Data.Foldable (forM_) import qualified Data.Map as Map import Data.MessagePack @@ -69,26 +68,34 @@ map (getDescription &&& Stateless . getFunction) $ exports p functionsToRegister = statefulFunctionsToRegister ++ statelessFunctionsToRegister mapM_ (registerWithNeovim . fst) functionsToRegister - return $ map (first name) functionsToRegister + return $ map (\(d,f) -> (name d, (d, f))) functionsToRegister liftIO . atomically . putTMVar sem . Map.fromList $ concat registeredFunctions + registerWithNeovim :: FunctionalityDescription -> Neovim customConfig () () registerWithNeovim = \case Function functionName s -> do pName <- R.asks _providerName ret <- wait $ vim_call_function "remote#define#FunctionOnHost" [ toObject pName, toObject functionName, toObject s - , toObject functionName, toObject (Map.empty :: Map.Map ByteString Object) + , toObject functionName, toObject (Map.empty :: Dictionary) ] case ret of Left e -> liftIO . errorM logger $ "Failed to register function: " ++ unpack functionName ++ show e Right _ -> liftIO . debugM logger $ "Registered function: " ++ unpack functionName + Command functionName copts -> do + let sync = case getCommandOptions copts of + -- This works because CommandOptions are sorted and CmdSync is + -- the smallest element in the sorting + (CmdSync s:_) -> s + _ -> Sync + pName <- R.asks _providerName ret <- wait $ vim_call_function "remote#define#CommandOnHost" - [ toObject pName, toObject functionName, toObject (cmdSync copts) + [ toObject pName, toObject functionName, toObject sync , toObject functionName, toObject copts ] case ret of @@ -96,6 +103,7 @@ "Failed to register command: " ++ unpack functionName ++ show e Right _ -> liftIO . debugM logger $ "Registered command: " ++ unpack functionName + Autocmd acmdType functionName opts -> do pName <- R.asks _providerName ret <- wait $ vim_call_function "remote#define#AutocmdOnHost" @@ -107,6 +115,7 @@ "Failed to register autocmd: " ++ unpack functionName ++ show e Right _ -> liftIO . debugM logger $ "Registered autocmd: " ++ unpack functionName + -- | Create a listening thread for events and add update the 'FunctionMap' with -- the corresponding 'TQueue's (i.e. communication channels). 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 @@ -23,18 +23,28 @@ Plugin(..), wrapPlugin, Synchronous(..), - CommandOptions(..), + CommandOption(..), + RangeSpecification(..), + CommandArguments(..), + getCommandOptions, + mkCommandOptions, AutocmdOptions(..), ) where import Neovim.Classes import Neovim.Context +import Control.Applicative ((<$>)) +import Data.Char (isDigit) import Data.Default -import qualified Data.Map as Map +import Data.List (groupBy, sort) +import qualified Data.Map as Map import Data.Maybe import Data.MessagePack -import Data.Text (Text) +import Data.String +import Data.Text (Text) +import Data.Traversable (sequence) +import Prelude hiding (sequence) -- | This data type is used in the plugin registration to properly register the -- functions. @@ -104,9 +114,13 @@ deriving (Show, Read, Eq, Ord, Enum) -instance Default Synchronous where - def = Sync +instance IsString Synchronous where + fromString = \case + "sync" -> Sync + "async" -> Async + _ -> error "Only \"sync\" and \"async\" are valid string representations" + instance NvimObject Synchronous where toObject = \case Async -> toObject False @@ -119,64 +133,180 @@ _ -> return Sync --- | Options that can be optionally set for commands. +-- | Options for commands. -- --- TODO Determine which of these make sense, how they are transmitted back and --- which options are still missing. --- (see remote#define#CommandOnHost in runtime\/autoload\/remote\/define.vim)) -data CommandOptions = CommandOptions - { cmdSync :: Synchronous - -- ^ Option to indicate whether vim shuould block until the command has - -- completed. (default: 'Sync') +-- 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 + -- ^ Should neovim wait for an answer ('Sync')? + -- + -- Stringliteral: \"sync\" or "\async\" - , cmdRange :: Maybe Text - -- ^ Vim expression for the range (or count). (default: \"\") + | CmdRegister + -- ^ Register passed to the command. + -- + -- Stringliteral: \"\"\" - , cmdCount :: Bool - -- ^ If true, + | 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. - , cmdNargs :: Int - -- ^ Number of arguments. Note that all arguments have to be a string type. - -- - -- TODO Check this in the Template Haskell functions. - -- - -- If you're using the template haskell functions for registering commands, - -- this field is overridden by it. + | CmdRange RangeSpecification + -- ^ Determines how neovim passes the range. + -- + -- Stringliterals: \"%\" for 'WholeFile', \",\" for line + -- and \",123\" for 123 lines. - , cmdBang :: Bool - -- ^ Behavior changes when using a bang. - } - deriving (Show, Read, Eq, Ord) + | CmdCount Int + -- ^ Command handles a count. The argument defines the + -- default count. + -- + -- Stringliteral: string of numbers (e.g. "132") + | CmdBang + -- ^ Command handles a bang + -- + -- Stringliteral: \"!\" -instance Default CommandOptions where - def = CommandOptions - { cmdSync = Sync - , cmdRange = Nothing - , cmdCount = False - , cmdNargs = 0 - , cmdBang = False - } + deriving (Eq, Ord, Show, Read) +instance IsString CommandOption where + fromString = \case + "%" -> CmdRange WholeFile + "\"" -> CmdRegister + "!" -> CmdBang + "sync" -> CmdSync Sync + "async" -> CmdSync Async + "," -> CmdRange CurrentLine + ',':ds | not (null ds) && all isDigit ds -> CmdRange (read ds) + ds | not (null ds) && all isDigit ds -> CmdCount (read ds) + _ -> error "Not a valid string for a CommandOptions. Check the docs!" + +-- | Newtype wrapper for a list of 'CommandOption'. Any properly constructed +-- object of this type is sorted and only contains zero or one object for each +-- possible option. +newtype CommandOptions = CommandOptions { getCommandOptions :: [CommandOption] } + deriving (Eq, Ord, Show, Read) + + +mkCommandOptions :: [CommandOption] -> CommandOptions +mkCommandOptions = CommandOptions . map head . groupBy constructor . sort + where + constructor a b = case (a,b) of + _ | a == b -> True + -- Only CmdSync and CmdNargs may fail for the equality check, + -- so we just have to check those. + (CmdSync _, CmdSync _) -> True + (CmdRange _, CmdRange _) -> True + -- Range and conut are mutually recursive. + -- XXX Actually '-range=N' and '-count=N' are, but the code in + -- remote#define#CommandOnChannel treats it exclusive as a whole. + -- (see :h :command-range) + (CmdRange _, CmdCount _) -> True + (CmdNargs _, CmdNargs _) -> True + _ -> False + + instance NvimObject CommandOptions where - toObject (CommandOptions{..}) = - (toObject :: Dictionary -> Object) . Map.fromList . catMaybes $ - [ cmdRange >>= \r -> Just ("range", toObject r) - , if cmdCount then Just ("count", toObject True) else Nothing - , if cmdNargs > 0 then Just ("nargs", toObject cmdNargs) else Nothing - , if cmdBang then Just ("bang", toObject True) else Nothing - ] + 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) + _ -> Nothing + fromObject o = throwError $ "Did not expect to receive a CommandOptions object: " ++ show o +data RangeSpecification = CurrentLine + | WholeFile + | RangeCount Int + deriving (Eq, Ord, Show, Read) + + +instance NvimObject RangeSpecification where + toObject = \case + CurrentLine -> ObjectBinary "" + WholeFile -> ObjectBinary "%" + RangeCount n -> toObject n + + +-- | 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. + -- + -- Examples: + -- * @Just (1,12)@ + + , count :: Maybe Int + -- ^ Count passed by neovim. Only set if 'CmdCount' was used in the export + -- declaration of the command. + + , register :: Maybe String + -- ^ Register that the command can/should/must use. + } + deriving (Eq, Ord, Show, Read) + + +instance Default CommandArguments where + def = CommandArguments + { bang = Nothing + , range = Nothing + , count = Nothing + , register = Nothing + } + + +-- XXX This instance is used as a bit of a hack, so that I don't have to write +-- special code handling in the code generator and "Neovim.RPC.SocketReader". +instance NvimObject CommandArguments where + toObject CommandArguments{..} = (toObject :: Dictionary -> Object) + . Map.fromList . catMaybes $ + [ bang >>= \b -> return ("bang", toObject b) + , range >>= \r -> return ("range", toObject r) + , count >>= \c -> return ("count", toObject c) + , register >>= \r -> return ("register", toObject r) + ] + + fromObject (ObjectMap m) = do + let l key = sequence (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: " ++ show o + + data AutocmdOptions = AutocmdOptions { acmdSync :: Synchronous -- ^ Option to indicate whether vim shuould block until the function has -- completed. (default: 'Sync') - , acmdPattern :: Text + , acmdPattern :: String -- ^ Pattern to match on. (default: \"*\") , acmdNested :: Bool diff --git a/library/Neovim/Plugin/ConfigHelper.hs b/library/Neovim/Plugin/ConfigHelper.hs --- a/library/Neovim/Plugin/ConfigHelper.hs +++ b/library/Neovim/Plugin/ConfigHelper.hs @@ -20,7 +20,6 @@ import Neovim.Config import Neovim.Plugin.Classes import Neovim.Plugin.ConfigHelper.Internal -import Data.Text (pack) -- | Note that you cannot really use this plugin by hand. It is automatically -- loaded for all Neovim instances. @@ -30,18 +29,18 @@ wrapPlugin Plugin { exports = [ $(function' 'pingNvimhs) Sync - , $(command' 'restartNvimhs) def { cmdSync = Async } ] , statefulExports = [ (params, [], [ $(autocmd 'recompileNvimhs) "BufWritePost" def { acmdSync = Async - , acmdPattern = pack cfgFile + , acmdPattern = cfgFile } , $(autocmd 'recompileNvimhs) "BufWritePost" def { acmdSync = Async - , acmdPattern = pack (libsDir++"/.*") + , acmdPattern = libsDir++"/*" } + , $(command' 'restartNvimhs) [CmdSync Async, CmdBang, CmdRegister] ]) ] } diff --git a/library/Neovim/Plugin/ConfigHelper/Internal.hs b/library/Neovim/Plugin/ConfigHelper/Internal.hs --- a/library/Neovim/Plugin/ConfigHelper/Internal.hs +++ b/library/Neovim/Plugin/ConfigHelper/Internal.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} {- | Module : Neovim.Plugin.ConfigHelper.Internal Description : Internals for a config helper plugin that helps recompiling nvim-hs @@ -16,6 +17,7 @@ import Neovim.API.String (vim_command) import Neovim.Config import Neovim.Context +import Neovim.Plugin.Classes import Neovim.Quickfix import Neovim.RPC.FunctionCall @@ -24,14 +26,16 @@ import Control.Applicative hiding (many, (<|>)) import Control.Monad (void) import Data.Char -import Text.Parsec +import Text.Parsec hiding (count) import Text.Parsec.String + -- | Simple function that will return @"Pong"@ if the plugin provider is -- running. pingNvimhs :: Neovim' String pingNvimhs = return "Pong" + -- | Recompile the plugin provider and put comile errors in the quickfix list. recompileNvimhs :: Neovim (Params NeovimConfig) [QuickfixListItem String] () recompileNvimhs = do @@ -42,13 +46,20 @@ setqflist qs Replace wait' $ vim_command "cwindow" + -- | Note that restarting the plugin provider implies compilation because Dyre -- does this automatically. However, if the recompilation fails, the previously -- compiled bynary is executed. This essentially means that restarting may take -- more time then you might expect. -restartNvimhs :: Neovim r st () -restartNvimhs = restart +restartNvimhs :: CommandArguments + -> Neovim (Params NeovimConfig) [QuickfixListItem String] () +restartNvimhs CommandArguments{..} = do + case bang of + Just True -> recompileNvimhs + _ -> return () + restart +-- Parsing {{{1 -- See the tests in @test-suite\/Neovim\/Plugin\/ConfigHelperSpec.hs@ on how the -- error messages look like. parseQuickfixItems :: String -> [QuickfixListItem String] @@ -57,6 +68,7 @@ Right qs -> qs Left _ -> [] + pQuickfixListItem :: Parser (QuickfixListItem String) pQuickfixListItem = do _ <- many blankLine @@ -68,22 +80,27 @@ , errorType = "E" -- TODO determine actual type } + pShortDesrciption :: Parser String pShortDesrciption = (:) <$> (many spaceChar *> notFollowedBy blankLine *> anyChar) <*> anyChar `manyTill` (void (many1 blankLine) <|> eof) + pLongDescription :: Parser String pLongDescription = anyChar `manyTill` (blank <|> eof) where blank = try (try newline *> try blankLine) + spaceChar :: Parser Char spaceChar = satisfy $ \c -> c == ' ' || c == '\t' + blankLine :: Parser () blankLine = void . try $ many spaceChar >> newline + -- | Skip anything until the next location information appears. -- -- The result will be a triple of filename, line number and column @@ -97,5 +114,7 @@ <*> pInt <* char ':' <*> pInt <* char ':' <* many spaceChar + pInt :: Parser Int pInt = read <$> many1 (satisfy isDigit) +-- 1}}} diff --git a/library/Neovim/RPC/Common.hs b/library/Neovim/RPC/Common.hs --- a/library/Neovim/RPC/Common.hs +++ b/library/Neovim/RPC/Common.hs @@ -15,6 +15,8 @@ where import Neovim.Context +import Neovim.Plugin.IPC +import Neovim.Plugin.Classes (FunctionalityDescription) import Control.Applicative import Control.Concurrent.STM @@ -27,7 +29,6 @@ import Data.String import Data.Text (Text) import Data.Time -import Neovim.Plugin.IPC import Network.Socket as N hiding (SocketType) import System.Environment (getEnv) import System.IO (BufferMode (..), Handle, IOMode, @@ -48,11 +49,19 @@ -- state is stored for as long as the plugin provider is running and not -- restarted.) type FunctionMap = - Map Text FunctionType + Map Text (FunctionalityDescription, FunctionType) + +-- | This data type is used to dispatch a remote function call to the appopriate +-- recipient. data FunctionType = Stateless ([Object] -> Neovim' Object) + -- ^ 'Stateless' functions are simply executed with the sent arguments. + | Stateful (TQueue SomeMessage) + -- ^ 'Stateful' functions are handled within a special thread, the 'TQueue' + -- is the communication endpoint for the arguments we have to pass. + -- | Things shared between the socket reader and the event handler. data RPCConfig = RPCConfig 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 @@ -33,9 +33,11 @@ import Data.MessagePack import Data.Serialize (encode) import System.IO (IOMode (WriteMode)) +import System.Log.Logger import Prelude + -- | This function will establish a connection to the given socket and write -- msgpack-rpc requests to it. runEventHandler :: SocketType @@ -48,25 +50,36 @@ $= eventHandler $$ addCleanup (cleanUpHandle h) (sinkHandle h) + -- | Convenient monad transformer stack for the event handler newtype EventHandler a = EventHandler (ResourceT (ReaderT (ConfigWrapper RPCConfig) (StateT Int64 IO)) a) deriving ( Functor, Applicative, Monad, MonadState Int64, MonadIO , MonadReader (ConfigWrapper RPCConfig)) + runEventHandlerContext :: ConfigWrapper RPCConfig -> EventHandler a -> IO a runEventHandlerContext env (EventHandler a) = evalStateT (runReaderT (runResourceT a) env) 1 + eventHandlerSource :: Source EventHandler SomeMessage eventHandlerSource = asks _eventQueue >>= \q -> forever $ yield =<< atomically' (readTQueue q) + eventHandler :: ConduitM SomeMessage ByteString EventHandler () eventHandler = await >>= \case Nothing -> return () -- i.e. close the conduit -- TODO signal shutdown globally Just message -> handleMessage (fromMessage message) >> eventHandler + +yield' :: (MonadIO io) => Object -> ConduitM i ByteString io () +yield' o = do + liftIO . debugM "EventHandler" $ "Sending: " ++ show o + yield $ encode o + + handleMessage :: Maybe RPCMessage -> ConduitM i ByteString EventHandler () handleMessage = \case Just (FunctionCall fn params reply time) -> do @@ -74,21 +87,21 @@ modify succ rs <- asks (recipients . customConfig) atomically' . modifyTVar rs $ Map.insert i (time, reply) - yield . encode $ ObjectArray + yield' $ ObjectArray [ toObject (0 :: Int64) , ObjectInt i , toObject fn , toObject params ] Just (Response i e res) -> - yield . encode $ ObjectArray + yield' $ ObjectArray [ toObject (1 :: Int64) , ObjectInt i , toObject e , toObject res ] Just (NotificationCall fn params) -> - yield . encode $ ObjectArray + yield' $ ObjectArray [ ObjectInt 2 , toObject fn , toObject params 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,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} {- | Module : Neovim.RPC.SocketReader Description : The component which reads RPC messages from the neovim instance @@ -13,10 +14,15 @@ -} module Neovim.RPC.SocketReader ( runSocketReader, + parseParams, ) where import Neovim.Classes import Neovim.Context hiding (ask, asks) +import Neovim.Plugin.Classes (CommandArguments (..), + CommandOption (..), + FunctionalityDescription (..), + getCommandOptions) import Neovim.Plugin.IPC import Neovim.Plugin.IPC.Internal import Neovim.RPC.Common @@ -27,11 +33,12 @@ import Control.Concurrent.STM import Control.Monad (void) import Control.Monad.Reader (MonadReader, ask, asks) -import Control.Monad.Trans.Resource +import Control.Monad.Trans.Resource hiding (register) import Data.Conduit as C import Data.Conduit.Binary import Data.Conduit.Cereal -import Data.Foldable (forM_) +import Data.Default (def) +import Data.Foldable (foldl', forM_) import qualified Data.Map as Map import Data.MessagePack import Data.Monoid @@ -122,7 +129,7 @@ Right m -> void . liftIO . forkIO . handle m =<< ask where - lookupFunction :: Text -> RPCConfig -> STM (Maybe FunctionType) + lookupFunction :: Text -> RPCConfig -> STM (Maybe (FunctionalityDescription, FunctionType)) lookupFunction m rpc = Map.lookup m <$> readTMVar (functions rpc) handle m rpc = atomically (lookupFunction m (customConfig rpc)) >>= \case @@ -131,16 +138,16 @@ debugM logger errM forM_ mi $ \i -> atomically' . writeTQueue (_eventQueue rpc) . SomeMessage $ Response i (toObject errM) ObjectNil - Just (Stateless f) -> do + Just (copts, Stateless f) -> do liftIO . debugM logger $ "Executing stateless function with ID: " <> show mi -- Stateless function: Create a boring state object for the -- Neovim context. -- drop the state of the result with (fmap fst <$>) - res <- fmap fst <$> runNeovim (rpc { customConfig = () }) () (f $ parseParams params) + res <- fmap fst <$> runNeovim (rpc { customConfig = () }) () (f $ parseParams copts params) -- Send the result to the event handler forM_ mi $ \i -> atomically' . writeTQueue (_eventQueue rpc) . SomeMessage . uncurry (Response i) $ responseResult res - Just (Stateful c) -> do + Just (copts, Stateful c) -> do now <- liftIO getCurrentTime reply <- liftIO newEmptyTMVarIO let q = (recipients . customConfig) rpc @@ -148,9 +155,9 @@ case mi of Just i -> do atomically' . modifyTVar q $ Map.insert i (now, reply) - atomically' . writeTQueue c . SomeMessage $ Request m i (parseParams params) + atomically' . writeTQueue c . SomeMessage $ Request m i (parseParams copts params) Nothing -> - atomically' . writeTQueue c . SomeMessage $ Notification m (parseParams params) + atomically' . writeTQueue c . SomeMessage $ Notification m (parseParams copts params) responseResult (Left !e) = (toObject e, ObjectNil) responseResult (Right !res) = (ObjectNil, toObject res) @@ -158,8 +165,8 @@ "Parmaeters in request are not in an object array: " <> show params -- TODO implement proper handling for additional parameters -parseParams :: [Object] -> [Object] -parseParams = \case +parseParams :: FunctionalityDescription -> [Object] -> [Object] +parseParams (Function _ _) args = case args of -- Defining a function on the remote host creates a function that, that -- passes all arguments in a list. At the time of this writing, no other -- arguments are passed for such a function. @@ -167,7 +174,69 @@ -- The function generating the function on neovim side is called: -- @remote#define#FunctionOnHost@ [ObjectArray fArgs] -> fArgs - args -> 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] + where + isPassedViaRPC :: CommandOption -> Bool + isPassedViaRPC = \case + CmdSync{} -> False + _ -> True + + -- Neovim passes arguments in a special form, depending on the + -- CommandOption values used to export the (command) function (e.g. via + -- 'command' or 'command''). + createCommandArguments :: (CommandArguments, [Object]) + -> (CommandOption, Object) + -> (CommandArguments, [Object]) + createCommandArguments old@(c, args') = \case + (CmdRange _, o) -> + either (const old) (\r -> (c { range = Just r }, args')) $ fromObject o + + (CmdCount _, o) -> + either (const old) (\n -> (c { count = Just n }, args')) $ fromObject o + + (CmdBang, o) -> + either (const old) (\b -> (c { bang = Just b }, args')) $ fromObject o + + (CmdNargs "*", ObjectArray os) -> + -- CommadnArguments -> [String] -> Neovim r st a + (c, os) + (CmdNargs "+", ObjectArray (o:os)) -> + -- CommandArguments -> String -> [String] -> Neovim r st a + (c, o : [ObjectArray os]) + (CmdNargs "?", ObjectArray [o]) -> + -- CommandArguments -> Maybe String -> Neovim r st a + (c, [toObject (Just o)]) + + (CmdNargs "?", ObjectArray []) -> + -- CommandArguments -> Maybe String -> Neovim r st a + (c, [toObject (Nothing :: Maybe Object)]) + + (CmdNargs "0", ObjectArray []) -> + -- CommandArguments -> Neovim r st a + (c, []) + + (CmdNargs "1", ObjectArray [o]) -> + -- CommandArguments -> String -> Neovim r st a + (c, [o]) + + (CmdRegister, o) -> + either (const old) (\r -> (c { register = Just r }, args')) $ fromObject o + + _ -> old + +parseParams (Autocmd _ _ _) args = case args of + [ObjectArray fArgs] -> fArgs + _ -> args handleNotification :: Int64 -> Object -> Object -> Sink a SocketHandler () diff --git a/nvim-hs.cabal b/nvim-hs.cabal --- a/nvim-hs.cabal +++ b/nvim-hs.cabal @@ -1,5 +1,5 @@ name: nvim-hs -version: 0.0.1 +version: 0.0.2 synopsis: Haskell plugin backend for neovim description: This package provides a plugin provider for neovim. It allows you to write @@ -30,6 +30,7 @@ , test-files/compile-error-for-quickfix-test4 , test-files/compile-error-for-quickfix-test5 , test-files/hello + , CHANGELOG.md source-repository head type: git location: https://github.com/saep/nvim-hs @@ -106,7 +107,7 @@ test-suite hspec type: exitcode-stdio-1.0 - hs-source-dirs: test-suite, library + hs-source-dirs: test-suite,library main-is: Spec.hs default-language: Haskell2010 build-depends: base