nvim-hs 2.1.0.5 → 2.1.0.7
raw patch · 3 files changed
+500/−498 lines, 3 filesdep +template-haskell-compat-v0208
Dependencies added: template-haskell-compat-v0208
Files
- library/Neovim/API/Parser.hs +78/−94
- library/Neovim/API/TH.hs +419/−403
- nvim-hs.cabal +3/−1
library/Neovim/API/Parser.hs view
@@ -6,72 +6,66 @@ Maintainer : woozletoff@gmail.com Stability : experimental- -}-module Neovim.API.Parser- ( NeovimAPI(..)- , NeovimFunction(..)- , NeovimType(..)- , parseAPI- ) where--import Neovim.Classes--import Control.Applicative-import Control.Monad.Except-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as LB-import Data.Map (Map)-import qualified Data.Map as Map-import Data.MessagePack-import Data.Serialize-import Neovim.Compat.Megaparsec as P-import System.Process.Typed-import UnliftIO.Exception (SomeException,- catch)--import Prelude--data NeovimType = SimpleType String- | NestedType NeovimType (Maybe Int)- | Void- deriving (Show, Eq)-+module Neovim.API.Parser (+ NeovimAPI (..),+ NeovimFunction (..),+ NeovimType (..),+ parseAPI,+) where --- | This data type contains simple information about a function as received--- throudh the @nvim --api-info@ command.-data NeovimFunction- = NeovimFunction- { name :: String- -- ^ function name+import Neovim.Classes - , parameters :: [(NeovimType, String)]- -- ^ A list of type name and variable name.+import Control.Applicative+import Control.Monad.Except+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as LB+import Data.Map (Map)+import qualified Data.Map as Map+import Data.MessagePack+import Data.Serialize+import Neovim.Compat.Megaparsec as P+import System.Process.Typed+import UnliftIO.Exception (+ SomeException,+ catch,+ ) - , canFail :: Bool- -- ^ Indicator whether the function can fail/throws exceptions.+import Prelude - , async :: Bool- -- ^ Indicator whether the this function is asynchronous.+data NeovimType+ = SimpleType String+ | NestedType NeovimType (Maybe Int)+ | Void+ deriving (Show, Eq) - , returnType :: NeovimType- -- ^ Functions return type.+{- | This data type contains simple information about a function as received+ throudh the @nvim --api-info@ command.+-}+data NeovimFunction = NeovimFunction+ { -- | function name+ name :: String+ , -- | A list of type name and variable name.+ parameters :: [(NeovimType, String)]+ , -- | Indicator whether the function can fail/throws exceptions.+ canFail :: Bool+ , -- | Indicator whether the this function is asynchronous.+ async :: Bool+ , -- | Functions return type.+ returnType :: NeovimType } deriving (Show) ---- | This data type represents the top-level structure of the @nvim --api-info@--- output.-data NeovimAPI- = NeovimAPI- { errorTypes :: [(String, Int64)]- -- ^ The error types are defined by a name and an identifier.-- , customTypes :: [(String, Int64)]- -- ^ Extension types defined by neovim.-- , functions :: [NeovimFunction]- -- ^ The remotely executable functions provided by the neovim api.+{- | This data type represents the top-level structure of the @nvim --api-info@+ output.+-}+data NeovimAPI = NeovimAPI+ { -- | The error types are defined by a name and an identifier.+ errorTypes :: [(String, Int64)]+ , -- | Extension types defined by neovim.+ customTypes :: [(String, Int64)]+ , -- | The remotely executable functions provided by the neovim api.+ functions :: [NeovimFunction] } deriving (Show) @@ -80,90 +74,80 @@ parseAPI = either (Left . pretty) extractAPI <$> (decodeAPI `catch` readFromAPIFile) extractAPI :: Object -> Either (Doc AnsiStyle) NeovimAPI-extractAPI apiObj = fromObject apiObj >>= \apiMap -> NeovimAPI- <$> extractErrorTypes apiMap- <*> extractCustomTypes apiMap- <*> extractFunctions apiMap+extractAPI apiObj =+ fromObject apiObj >>= \apiMap ->+ NeovimAPI+ <$> extractErrorTypes apiMap+ <*> extractCustomTypes apiMap+ <*> extractFunctions apiMap readFromAPIFile :: SomeException -> IO (Either String Object) readFromAPIFile _ = (decode <$> B.readFile "api") `catch` returnPreviousExceptionAsText where- returnPreviousExceptionAsText :: SomeException -> IO (Either String Object)- returnPreviousExceptionAsText _ = return . Left $- "The 'nvim' process could not be started and there is no file named\- \ 'api' in the working directory as a substitute."+ returnPreviousExceptionAsText :: SomeException -> IO (Either String Object)+ returnPreviousExceptionAsText _ =+ return . Left $+ "The 'nvim' process could not be started and there is no file named\+ \ 'api' in the working directory as a substitute." decodeAPI :: IO (Either String Object) decodeAPI =- decode . LB.toStrict <$> readProcessStdout_ (proc "nvim" ["--api-info"])-+ decode . LB.toStrict <$> readProcessStdout_ (proc "nvim" ["--api-info"]) oLookup :: (NvimObject o) => String -> Map String Object -> Either (Doc AnsiStyle) o oLookup qry = maybe throwErrorMessage fromObject . Map.lookup qry where- throwErrorMessage = throwError $ "No entry for:" <+> pretty qry-+ throwErrorMessage = throwError $ "No entry for:" <+> pretty qry oLookupDefault :: (NvimObject o) => o -> String -> Map String Object -> Either (Doc AnsiStyle) o oLookupDefault d qry m = maybe (return d) fromObject $ Map.lookup qry m - extractErrorTypes :: Map String Object -> Either (Doc AnsiStyle) [(String, Int64)] extractErrorTypes objAPI = extractTypeNameAndID =<< oLookup "error_types" objAPI - extractTypeNameAndID :: Object -> Either (Doc AnsiStyle) [(String, Int64)] extractTypeNameAndID m = do types <- Map.toList <$> fromObject m forM types $ \(errName, idMap) -> do i <- oLookup "id" idMap- return (errName,i)-+ return (errName, i) extractCustomTypes :: Map String Object -> Either (Doc AnsiStyle) [(String, Int64)] extractCustomTypes objAPI = extractTypeNameAndID =<< oLookup "types" objAPI - extractFunctions :: Map String Object -> Either (Doc AnsiStyle) [NeovimFunction] extractFunctions objAPI = mapM extractFunction =<< oLookup "functions" objAPI - toParameterlist :: [(String, String)] -> Either (Doc AnsiStyle) [(NeovimType, String)]-toParameterlist ps = forM ps $ \(t,n) -> do+toParameterlist ps = forM ps $ \(t, n) -> do t' <- parseType t return (t', n) - extractFunction :: Map String Object -> Either (Doc AnsiStyle) NeovimFunction-extractFunction funDefMap = NeovimFunction- <$> (oLookup "name" funDefMap)- <*> (oLookup "parameters" funDefMap >>= toParameterlist)- <*> (oLookupDefault True "can_fail" funDefMap)- <*> (oLookupDefault False "async" funDefMap)- <*> (oLookup "return_type" funDefMap >>= parseType)-+extractFunction funDefMap =+ NeovimFunction+ <$> oLookup "name" funDefMap+ <*> (oLookup "parameters" funDefMap >>= toParameterlist)+ <*> oLookupDefault True "can_fail" funDefMap+ <*> oLookupDefault False "async" funDefMap+ <*> (oLookup "return_type" funDefMap >>= parseType) parseType :: String -> Either (Doc AnsiStyle) NeovimType parseType s = either (throwError . pretty . show) return $ parse (pType <* eof) s s - pType :: P.Parser NeovimType pType = pArray P.<|> pVoid P.<|> pSimple - pVoid :: P.Parser NeovimType-pVoid = const Void <$> (P.try (string "void") <* eof)-+pVoid = Void <$ (P.try (string "void") <* eof) pSimple :: P.Parser NeovimType pSimple = SimpleType <$> P.some (noneOf [',', ')']) - pArray :: P.Parser NeovimType-pArray = NestedType <$> (P.try (string "ArrayOf(") *> pType)- <*> optional pNum <* char ')'-+pArray =+ NestedType <$> (P.try (string "ArrayOf(") *> pType)+ <*> optional pNum <* char ')' pNum :: P.Parser Int-pNum = read <$> (P.try (char ',') *> space *> P.some (oneOf ['0'..'9']))-+pNum = read <$> (P.try (char ',') *> space *> P.some (oneOf ['0' .. '9']))
library/Neovim/API/TH.hs view
@@ -1,6 +1,6 @@-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE CPP #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE TemplateHaskell #-}+ {- | Module : Neovim.API.TH Description : Template Haskell API generation module@@ -9,152 +9,133 @@ Maintainer : woozletoff@gmail.com Stability : experimental- -}-module Neovim.API.TH- ( generateAPI- , function- , function'- , command- , command'- , autocmd- , stringListTypeMap- , textVectorTypeMap- , bytestringVectorTypeMap-- , module UnliftIO.Exception- , module Neovim.Classes- , module Data.Data- , module Data.MessagePack- ) where--import Neovim.API.Parser-import Neovim.Classes-import Neovim.Context-import Neovim.Plugin.Classes (CommandArguments (..),- CommandOption (..),- FunctionalityDescription (..),- FunctionName(..),- mkCommandOptions)-import Neovim.Plugin.Internal (ExportedFunctionality (..))-import Neovim.RPC.FunctionCall+module Neovim.API.TH (+ generateAPI,+ function,+ function',+ command,+ command',+ autocmd,+ stringListTypeMap,+ textVectorTypeMap,+ bytestringVectorTypeMap,+ module UnliftIO.Exception,+ module Neovim.Classes,+ module Data.Data,+ module Data.MessagePack,+) where -import Language.Haskell.TH+import Neovim.API.Parser+import Neovim.Classes+import Neovim.Context+import Neovim.Plugin.Classes (+ CommandArguments (..),+ CommandOption (..),+ FunctionName (..),+ FunctionalityDescription (..),+ mkCommandOptions,+ )+import Neovim.Plugin.Internal (ExportedFunctionality (..))+import Neovim.RPC.FunctionCall -import Control.Applicative-import Control.Arrow (first)-import Control.Concurrent.STM (STM)-import Control.Exception-import Control.Monad-import Data.ByteString (ByteString)-import Data.ByteString.UTF8 (fromString)-import Data.Char (isUpper, toUpper)-import Data.Data (Data, Typeable)-import Data.Map (Map)-import qualified Data.Map as Map-import Data.Maybe-import Data.MessagePack-import Data.Monoid-import qualified Data.Set as Set-import Data.Text (Text)-import Data.Text.Prettyprint.Doc (viaShow)-import Data.Vector (Vector)-import UnliftIO.Exception+import Language.Haskell.TH hiding (dataD, instanceD)+import TemplateHaskell.Compat.V0208 -import Prelude+import Control.Applicative+import Control.Arrow (first)+import Control.Concurrent.STM (STM)+import Control.Exception+import Control.Monad+import Data.ByteString (ByteString)+import Data.ByteString.UTF8 (fromString)+import Data.Char (isUpper, toUpper)+import Data.Data (Data, Typeable)+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe+import Data.MessagePack+import Data.Monoid+import qualified Data.Set as Set+import Data.Text (Text)+import Data.Text.Prettyprint.Doc (viaShow)+import Data.Vector (Vector)+import UnliftIO.Exception -#if MIN_VERSION_template_haskell(2,17,0)-dataD' :: CxtQ -> Name -> [TyVarBndr ()] -> [ConQ] -> [Name] -> DecQ-#else-dataD' :: CxtQ -> Name -> [TyVarBndr] -> [ConQ] -> [Name] -> DecQ-#endif--- XXX This should probably be tied to the proper template haskell version--- similar to the type signature.-#if __GLASGOW_HASKELL__ < 800-dataD' = dataD-#elif __GLASGOW_HASKELL__ < 802-dataD' cxtQ n tyvarbndrs conq ns =- dataD cxtQ n tyvarbndrs Nothing conq (mapM conT ns)-#else-dataD' cxtQ n tyvarbndrs conq ns =- dataD cxtQ n tyvarbndrs Nothing conq ((return . return . DerivClause Nothing . map ConT) ns)-#endif+import Prelude -#if MIN_VERSION_template_haskell(2,17,0)-plainTV' :: Name -> TyVarBndr Specificity-plainTV' env = PlainTV env SpecifiedSpec-#else-plainTV' :: Name -> TyVarBndr-plainTV' = PlainTV env-#endif+{- | Generate the API types and functions provided by @nvim --api-info@. --- | Generate the API types and functions provided by @nvim --api-info@.------ The provided map allows the use of different Haskell types for the types--- defined in the API. The types must be an instance of 'NvimObject' and they--- must form an isomorphism with the sent messages types. Currently, it--- provides a Convenient way to replace the /String/ type with 'Text',--- 'ByteString' or 'String'.+ The provided map allows the use of different Haskell types for the types+ defined in the API. The types must be an instance of 'NvimObject' and they+ must form an isomorphism with the sent messages types. Currently, it+ provides a Convenient way to replace the /String/ type with 'Text',+ 'ByteString' or 'String'.+-} generateAPI :: TypeMap -> Q [Dec] generateAPI typeMap = do api <- either (fail . show) return =<< runIO parseAPI let exceptionName = mkName "NeovimExceptionGen"- exceptions = (\(n,i) -> (mkName ("Neovim" <> n), i)) `map` errorTypes api+ exceptions = (\(n, i) -> (mkName ("Neovim" <> n), i)) `map` errorTypes api customTypesN = first mkName `map` customTypes api- join <$> sequence- [ fmap (join . return) $ createDataTypeWithByteStringComponent exceptionName (map fst exceptions)- , exceptionInstance exceptionName- , customTypeInstance exceptionName exceptions- , fmap join . mapM (\n -> createDataTypeWithByteStringComponent n [n]) $ (map fst customTypesN)- , join <$> mapM (\(n,i) -> customTypeInstance n [(n,i)]) customTypesN- , fmap join . mapM (createFunction typeMap) $ functions api- ]-+ join+ <$> sequence+ [ join . pure <$> createDataTypeWithByteStringComponent exceptionName (map fst exceptions)+ , exceptionInstance exceptionName+ , customTypeInstance exceptionName exceptions+ , fmap join (mapM ((\n -> createDataTypeWithByteStringComponent n [n]) . fst) customTypesN)+ , join <$> mapM (\(n, i) -> customTypeInstance n [(n, i)]) customTypesN+ , fmap join . mapM (createFunction typeMap) $ functions api+ ] -- | Maps type identifiers from the neovim API to Haskell types. data TypeMap = TypeMap- { typesOfAPI :: Map String (Q Type)- , list :: Q Type- }-+ { typesOfAPI :: Map String (Q Type)+ , list :: Q Type+ } stringListTypeMap :: TypeMap-stringListTypeMap = TypeMap- { typesOfAPI = Map.fromList- [ ("Boolean" , [t|Bool|])- , ("Integer" , [t|Int64|])- , ("Float" , [t|Double|])- , ("String" , [t|String|])- , ("Array" , [t|[Object]|])- , ("Dictionary", [t|Map String Object|])- , ("void" , [t|()|])- ]- , list = listT- }+stringListTypeMap =+ TypeMap+ { typesOfAPI =+ Map.fromList+ [ ("Boolean", [t|Bool|])+ , ("Integer", [t|Int64|])+ , ("LuaRef", [t|Int64|])+ , ("Float", [t|Double|])+ , ("String", [t|String|])+ , ("Array", [t|[Object]|])+ , ("Dictionary", [t|Map String Object|])+ , ("void", [t|()|])+ ]+ , list = listT+ } textVectorTypeMap :: TypeMap-textVectorTypeMap = stringListTypeMap- { typesOfAPI = adjustTypeMapForText $ typesOfAPI stringListTypeMap- , list = [t|Vector|]- }+textVectorTypeMap =+ stringListTypeMap+ { typesOfAPI = adjustTypeMapForText $ typesOfAPI stringListTypeMap+ , list = [t|Vector|]+ } where adjustTypeMapForText =- Map.insert "String" [t|Text|] .- Map.insert "Array" [t|Vector Object|] .- Map.insert "Dictionary" [t|Map Text Object|]+ Map.insert "String" [t|Text|]+ . Map.insert "Array" [t|Vector Object|]+ . Map.insert "Dictionary" [t|Map Text Object|] bytestringVectorTypeMap :: TypeMap-bytestringVectorTypeMap = textVectorTypeMap- { typesOfAPI = adjustTypeMapForByteString $ typesOfAPI textVectorTypeMap- }+bytestringVectorTypeMap =+ textVectorTypeMap+ { typesOfAPI = adjustTypeMapForByteString $ typesOfAPI textVectorTypeMap+ } where adjustTypeMapForByteString =- Map.insert "String" [t|ByteString|] .- Map.insert "Array" [t|Vector Object|] .- Map.insert "Dictionary" [t|Map ByteString Object|]+ Map.insert "String" [t|ByteString|]+ . Map.insert "Array" [t|Vector Object|]+ . Map.insert "Dictionary" [t|Map ByteString Object|] apiTypeToHaskellType :: TypeMap -> NeovimType -> Q Type-apiTypeToHaskellType typeMap@TypeMap{typesOfAPI,list} at = case at of+apiTypeToHaskellType typeMap@TypeMap{typesOfAPI, list} at = case at of Void -> [t|()|] NestedType t Nothing -> appT list $ apiTypeToHaskellType typeMap t@@ -163,349 +144,363 @@ SimpleType t -> fromMaybe ((conT . mkName) t) $ Map.lookup t typesOfAPI +{- | This function will create a wrapper function with neovim's function name+ as its name. --- | This function will create a wrapper function with neovim's function name--- as its name.------ Synchronous function:--- @--- buffer_get_number :: Buffer -> Neovim Int64--- buffer_get_number buffer = scall "buffer_get_number" [toObject buffer]--- @------ Asynchronous function:--- @--- vim_eval :: String -> Neovim (TMVar Object)--- vim_eval str = acall "vim_eval" [toObject str]--- @------ Asynchronous function without a return value:--- @--- vim_feed_keys :: String -> String -> Bool -> Neovim ()--- vim_feed_keys keys mode escape_csi =--- acallVoid "vim_feed_keys" [ toObject keys--- , toObject mode--- , toObject escape_csi--- ]--- @---+ Synchronous function:+ @+ buffer_get_number :: Buffer -> Neovim Int64+ buffer_get_number buffer = scall "buffer_get_number" [toObject buffer]+ @++ Asynchronous function:+ @+ vim_eval :: String -> Neovim (TMVar Object)+ vim_eval str = acall "vim_eval" [toObject str]+ @++ Asynchronous function without a return value:+ @+ vim_feed_keys :: String -> String -> Bool -> Neovim ()+ vim_feed_keys keys mode escape_csi =+ acallVoid "vim_feed_keys" [ toObject keys+ , toObject mode+ , toObject escape_csi+ ]+ @+-} createFunction :: TypeMap -> NeovimFunction -> Q [Dec] createFunction typeMap nf = do- let withDeferred | async nf = appT [t|STM|]- | otherwise = id+ let withDeferred+ | async nf = appT [t|STM|]+ | otherwise = id - callFn | async nf = [|acall'|]- | otherwise = [|scall'|]+ callFn+ | async nf = [|acall'|]+ | otherwise = [|scall'|] functionName = mkName $ name nf toObjVar v = [|toObject $(varE v)|] -- retType <- let env = (mkName "env")- in forallT [plainTV' env] (return [])- . appT ([t|Neovim $(varT env) |])- . withDeferred- . apiTypeToHaskellType typeMap $ returnType nf+ retType <-+ let env = mkName "env"+ in forallT [specifiedPlainTV env] (return [])+ . appT [t|Neovim $(varT env)|]+ . withDeferred+ . apiTypeToHaskellType typeMap+ $ returnType nf -- prefix with arg0_, arg1_ etc. to prevent generated code from crashing due -- to keywords being used. -- see https://github.com/neovimhaskell/nvim-hs/issues/65 let prefixWithNumber i n = "arg" ++ show i ++ "_" ++ n- applyPrefixWithNumber = zipWith (\i (t,n) -> (t, prefixWithNumber i n))- [0 :: Int ..] . parameters- vars <- mapM (\(t,n) -> (,) <$> apiTypeToHaskellType typeMap t- <*> newName n)+ applyPrefixWithNumber =+ zipWith+ (\i (t, n) -> (t, prefixWithNumber i n))+ [0 :: Int ..]+ . parameters+ vars <-+ mapM+ ( \(t, n) ->+ (,) <$> apiTypeToHaskellType typeMap t+ <*> newName n+ ) $ applyPrefixWithNumber nf sequence- [ sigD functionName . return- . foldr (AppT . AppT ArrowT) retType $ map fst vars- , funD functionName- [ clause- (map (varP . snd) vars)- (normalB (callFn- `appE` ([| (F . fromString) |] `appE` (litE . stringL . name) nf)- `appE` listE (map (toObjVar . snd) vars)))- []- ]+ [ (sigD functionName . return) (foldr ((AppT . AppT ArrowT) . fst) retType vars)+ , funD+ functionName+ [ clause+ (map (varP . snd) vars)+ ( normalB+ ( callFn+ `appE` ([|(F . fromString)|] `appE` (litE . stringL . name) nf)+ `appE` listE (map (toObjVar . snd) vars)+ )+ )+ [] ]-+ ] --- | @ createDataTypeWithObjectComponent SomeName [Foo,Bar]@--- will create this:--- @--- data SomeName = Foo !Object--- | Bar !Object--- deriving (Typeable, Eq, Show)--- @---+{- | @ createDataTypeWithObjectComponent SomeName [Foo,Bar]@+ will create this:+ @+ data SomeName = Foo !Object+ | Bar !Object+ deriving (Typeable, Eq, Show)+ @+-} createDataTypeWithByteStringComponent :: Name -> [Name] -> Q [Dec] createDataTypeWithByteStringComponent nme cs = do- tObject <- [t|ByteString|]-#if __GLASGOW_HASKELL__ < 800- let strictNess = (IsStrict, tObject)-#else- let strictNess = (Bang NoSourceUnpackedness SourceStrict, tObject)-#endif- sequence- [ dataD'- (return [])- nme- []- (map (\n-> normalC n [return strictNess]) cs)- (mkName <$> ["Typeable", "Eq", "Show", "Generic"])- , instanceD (return []) (appT (conT (mkName "NFData")) (conT nme)) []- ]+ tObject <- [t|ByteString|] + let strictNess = (Bang NoSourceUnpackedness SourceStrict, tObject) --- | If the first parameter is @mkName NeovimException@, this function will--- generate @instance Exception NeovimException@.-exceptionInstance :: Name -> Q [Dec]-exceptionInstance exceptionName = return <$>- instanceD- (return [])- ([t|Exception|] `appT` conT exceptionName)- []+ pure+ [ dataD+ []+ nme+ []+ (map (\n -> NormalC n [strictNess]) cs)+ (mkName <$> ["Typeable", "Eq", "Show", "Generic"])+ , instanceD [] (AppT (ConT (mkName "NFData")) (ConT nme)) []+ ] +{- | If the first parameter is @mkName NeovimException@, this function will+ generate @instance Exception NeovimException@.+-}+exceptionInstance :: Name -> Q [Dec]+exceptionInstance exceptionName = do+ tException <- [t|Exception|]+ pure [instanceD [] (tException `AppT` ConT exceptionName) []] --- | @customTypeInstance Foo [(Bar, 1), (Quz, 2)]@--- will create this:--- @--- instance Serializable Foo where--- toObject (Bar bs) = ObjectExt 1 bs--- toObject (Quz bs) = ObjectExt 2 bs--- fromObject (ObjectExt 1 bs) = return $ Bar bs--- fromObject (ObjectExt 2 bs) = return $ Quz bs--- fromObject o = Left $ "Object is not convertible to: Foo Received: " <> show o--- @+{- | @customTypeInstance Foo [(Bar, 1), (Quz, 2)]@+ will create this:+ @+ instance Serializable Foo where+ toObject (Bar bs) = ObjectExt 1 bs+ toObject (Quz bs) = ObjectExt 2 bs+ fromObject (ObjectExt 1 bs) = return $ Bar bs+ fromObject (ObjectExt 2 bs) = return $ Quz bs+ fromObject o = Left $ "Object is not convertible to: Foo Received: " <> show o+ @+-} customTypeInstance :: Name -> [(Name, Int64)] -> Q [Dec]-customTypeInstance typeName nis =+customTypeInstance typeName nis = do let fromObjectClause :: Name -> Int64 -> Q Clause- fromObjectClause n i = newName "bs" >>= \bs ->- clause- [ conP (mkName "ObjectExt")- [(litP . integerL . fromIntegral) i,varP bs]- ]- (normalB [|return $ $(conE n) $(varE bs)|])- []+ fromObjectClause n i =+ newName "bs" >>= \bs ->+ clause+ [ conP+ (mkName "ObjectExt")+ [(litP . integerL . fromIntegral) i, varP bs]+ ]+ (normalB [|return $ $(conE n) $(varE bs)|])+ [] fromObjectErrorClause :: Q Clause fromObjectErrorClause = do o <- newName "o" let n = nameBase typeName clause- [ varP o ]- (normalB [|throwError $+ [varP o]+ ( normalB+ [|+ throwError $ pretty "Object is not convertible to:"- <+> viaShow n- <+> pretty "Received:" <+> viaShow $(varE o)|])+ <+> viaShow n+ <+> pretty "Received:"+ <+> viaShow $(varE o)+ |]+ ) [] toObjectClause :: Name -> Int64 -> Q Clause- toObjectClause n i = newName "bs" >>= \bs ->- clause- [conP n [varP bs]]- (normalB [|ObjectExt $((litE . integerL . fromIntegral) i) $(varE bs)|])- []+ toObjectClause n i =+ newName "bs" >>= \bs ->+ clause+ [conP n [varP bs]]+ (normalB [|ObjectExt $((litE . integerL . fromIntegral) i) $(varE bs)|])+ [] - in return <$> instanceD- (return [])- ([t|NvimObject|] `appT` conT typeName)- [ funD (mkName "toObject") $ map (uncurry toObjectClause) nis- , funD (mkName "fromObject")- $ map (uncurry fromObjectClause) nis- <> [fromObjectErrorClause]- ]+ tNvimObject <- [t|NvimObject|]+ fToObject <- funD (mkName "toObject") $ map (uncurry toObjectClause) nis+ fFromObject <- funD (mkName "fromObject") $ map (uncurry fromObjectClause) nis <> [fromObjectErrorClause]+ pure [instanceD [] (tNvimObject `AppT` ConT typeName) [fToObject, fFromObject]] +{- | Define an exported function by providing a custom name and referencing the+ function you want to export. --- | Define an exported function by providing a custom name and referencing the--- function you want to export.------ Note that the name must start with an upper case letter.------ Example: @ $(function \"MyExportedFunction\" 'myDefinedFunction) 'Sync' @+ Note that the name must start with an upper case letter.++ Example: @ $(function \"MyExportedFunction\" 'myDefinedFunction) 'Sync' @+-} function :: String -> Name -> Q Exp function [] _ = error "Empty names are not allowed for exported functions."-function customName@(c:_) functionName+function customName@(c : _) functionName | (not . isUpper) c = error $ "Custom function name must start with a capiatl letter: " <> show customName | otherwise = do (_, fun) <- functionImplementation functionName- [|\funOpts -> EF (Function (F (fromString $(litE (StringL customName)))) funOpts, $(return fun)) |]-+ [|\funOpts -> EF (Function (F (fromString $(litE (StringL customName)))) funOpts, $(return fun))|] --- | Define an exported function. This function works exactly like 'function',--- but it generates the exported name automatically by converting the first--- letter to upper case.+{- | Define an exported function. This function works exactly like 'function',+ but it generates the exported name automatically by converting the first+ letter to upper case.+-} function' :: Name -> Q Exp function' functionName =- let (c:cs) = nameBase functionName- 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- | Optional ArgType- | CommandArgumentsType- | OtherType- deriving (Eq, Ord, Show, Read)+ let (c : cs) = nameBase functionName+ 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+ | Optional ArgType+ | CommandArgumentsType+ | OtherType+ deriving (Eq, Ord, Show, Read) --- | Given a value of type 'Type', test whether it can be classified according--- to the constructors of "ArgType".+{- | Given a value of type 'Type', test whether it can be classified according+ to the constructors of "ArgType".+-} classifyArgType :: Type -> Q ArgType classifyArgType t = do set <- genStringTypesSet maybeType <- [t|Maybe|] cmdArgsType <- [t|CommandArguments|] case t of- AppT ListT (ConT str) | str `Set.member` set- -> return ListOfStringyTypes+ AppT ListT (ConT str)+ | str `Set.member` set ->+ return ListOfStringyTypes+ AppT m mt@(ConT _)+ | m == maybeType ->+ Optional <$> classifyArgType mt+ ConT str+ | str `Set.member` set ->+ return StringyType+ cmd+ | cmd == cmdArgsType ->+ return CommandArgumentsType+ _ -> return OtherType+ where+ genStringTypesSet = do+ types <- sequence [[t|String|], [t|ByteString|], [t|Text|]]+ return $ Set.fromList [n | ConT n <- types] - AppT m mt@(ConT _) | m == maybeType- -> Optional <$> classifyArgType mt+{- | Similarly to 'function', this function is used to export a command with a+ custom name. - ConT str | str `Set.member` set- -> return StringyType- cmd | cmd == cmdArgsType- -> return CommandArgumentsType+ Note that commands must start with an upper case letter. - _ -> return OtherType+ Due to limitations on the side of (neo)vim, commands can only have one of the+ following five signatures, where you can replace 'String' with 'ByteString'+ or 'Text' if you wish: - where- genStringTypesSet = do- types <- sequence [[t|String|],[t|ByteString|],[t|Text|]]- return $ Set.fromList [ n | ConT n <- types ]+ * 'CommandArguments' -> 'Neovim' r st () + * 'CommandArguments' -> 'Maybe' 'String' -> 'Neovim' r st () --- | Similarly to 'function', this function is used to export a command with a--- custom name.------ Note that commands must start with an upper case letter.------ Due to limitations on the side of (neo)vim, commands can only have one of the--- following five signatures, where you can replace 'String' with 'ByteString'--- or 'Text' if you wish:------ * 'CommandArguments' -> 'Neovim' r st ()------ * 'CommandArguments' -> 'Maybe' 'String' -> 'Neovim' r st ()------ * 'CommandArguments' -> 'String' -> 'Neovim' r st ()------ * 'CommandArguments' -> ['String'] -> 'Neovim' r st ()------ * 'CommandArguments' -> 'String' -> ['String'] -> 'Neovim' r st ()------ Example: @ $(command \"RememberThePrime\" 'someFunction) ['CmdBang'] @------ Note that the list of command options (i.e. the last argument) removes--- duplicate options by means of some internally convenient sorting. You should--- simply not define the same option twice.+ * 'CommandArguments' -> 'String' -> 'Neovim' r st ()++ * 'CommandArguments' -> ['String'] -> 'Neovim' r st ()++ * 'CommandArguments' -> 'String' -> ['String'] -> 'Neovim' r st ()++ Example: @ $(command \"RememberThePrime\" 'someFunction) ['CmdBang'] @++ Note that the list of command options (i.e. the last argument) removes+ duplicate options by means of some internally convenient sorting. You should+ simply not define the same option twice.+-} command :: String -> Name -> Q Exp command [] _ = error "Empty names are not allowed for exported commands."-command customFunctionName@(c:_) functionName+command customFunctionName@(c : _) functionName | (not . isUpper) c = error $ "Custom command name must start with a capital letter: " <> show customFunctionName | otherwise = do (argTypes, fun) <- functionImplementation functionName -- See :help :command-nargs for what the result strings mean case argTypes of- (CommandArgumentsType:_) -> return ()+ (CommandArgumentsType : _) -> return () _ -> error "First argument for a function exported as a command must be CommandArguments!" let nargs = case tail argTypes of- [] -> [|CmdNargs "0"|]- [StringyType] -> [|CmdNargs "1"|]- [Optional StringyType] -> [|CmdNargs "?"|]- [ListOfStringyTypes] -> [|CmdNargs "*"|]+ [] -> [|CmdNargs "0"|]+ [StringyType] -> [|CmdNargs "1"|]+ [Optional StringyType] -> [|CmdNargs "?"|]+ [ListOfStringyTypes] -> [|CmdNargs "*"|] [StringyType, ListOfStringyTypes] -> [|CmdNargs "+"|]- _ -> error $ unlines- [ "Trying to generate a command without compatible types."- , "Due to a limitation burdened on us by vimL, we can only"- , "use a limited amount type signatures for commands. See"- , "the documentation for 'command' for a more thorough"- , "explanation."- ]- [|\copts -> EF (Command- (F (fromString $(litE (StringL customFunctionName))))- (mkCommandOptions ($(nargs) : copts))- , $(return fun))|]+ _ ->+ error $+ unlines+ [ "Trying to generate a command without compatible types."+ , "Due to a limitation burdened on us by vimL, we can only"+ , "use a limited amount type signatures for commands. See"+ , "the documentation for 'command' for a more thorough"+ , "explanation."+ ]+ [|+ \copts ->+ EF+ ( Command+ (F (fromString $(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.+{- | Define an exported command. This function works exactly like 'command', but+ it generates the command name by converting the first letter to upper case.+-} command' :: Name -> Q Exp command' functionName =- let (c:cs) = nameBase functionName- in command (toUpper c:cs) functionName+ let (c : cs) = nameBase functionName+ in command (toUpper c : cs) functionName +{- | This function generates an export for autocmd. Since this is a static+ registration, arguments are not allowed here. You can, of course, define a+ fully applied function and pass it as an argument. If you have to add+ autocmds dynamically, it can be done with 'addAutocmd'. --- | This function generates an export for autocmd. Since this is a static--- registration, arguments are not allowed here. You can, of course, define a--- fully applied function and pass it as an argument. If you have to add--- autocmds dynamically, it can be done with 'addAutocmd'.------ Example:------ @--- someFunction :: a -> b -> c -> d -> Neovim r st res--- someFunction = ...------ theFunction :: Neovim r st res--- theFunction = someFunction 1 2 3 4------ $(autocmd 'theFunction) def--- @------ @def@ is of type 'AutocmdOptions'.------ Note that you have to define @theFunction@ in a different module due to--- the use of Template Haskell.+ Example:++ @+ someFunction :: a -> b -> c -> d -> Neovim r st res+ someFunction = ...++ theFunction :: Neovim r st res+ theFunction = someFunction 1 2 3 4+-}++{- $(autocmd 'theFunction) def+ @++ @def@ is of type 'AutocmdOptions'.++ Note that you have to define @theFunction@ in a different module due to+ the use of Template Haskell.+-}+ autocmd :: Name -> Q Exp autocmd functionName =- let (c:cs) = nameBase functionName- in do- (as, fun) <- functionImplementation functionName- case as of- [] ->- [|\t sync acmdOpts -> EF (Autocmd t (F (fromString $(litE (StringL (toUpper c : cs))))) sync acmdOpts, $(return fun))|]-- _ ->- error "Autocmd functions have to be fully applied (i.e. they should not take any arguments)."+ let (c : cs) = nameBase functionName+ in do+ (as, fun) <- functionImplementation functionName+ case as of+ [] ->+ [|\t sync acmdOpts -> EF (Autocmd t (F (fromString $(litE (StringL (toUpper c : cs))))) sync acmdOpts, $(return fun))|]+ _ ->+ error "Autocmd functions have to be fully applied (i.e. they should not take any arguments)." +{- | Generate a function of type @[Object] -> Neovim' Object@ from the argument+ function. --- | Generate a function of type @[Object] -> Neovim' Object@ from the argument--- function.------ The function--- @--- add :: Int -> Int -> Int--- add = (+)--- @--- will be converted to--- @--- \args -> case args of--- [x,y] -> case pure add <*> fromObject x <*> fromObject y of--- Left e -> err $ "Wrong type of arguments for add: " ++ e--- Right action -> toObject <$> action--- _ -> err $ "Wrong number of arguments for add: " ++ show xs--- @---+ The function+ @+ add :: Int -> Int -> Int+ add = (+)+ @+ will be converted to+ @+ \args -> case args of+ [x,y] -> case pure add <*> fromObject x <*> fromObject y of+ Left e -> err $ "Wrong type of arguments for add: " ++ e+ Right action -> toObject <$> action+ _ -> err $ "Wrong number of arguments for add: " ++ show xs+ @+-} functionImplementation :: Name -> Q ([ArgType], Exp) functionImplementation functionName = do fInfo <- reify functionName nargs <- mapM classifyArgType $ case fInfo of-#if __GLASGOW_HASKELL__ < 800- VarI _ functionType _ _ ->-#else- VarI _ functionType _ ->-#endif- determineNumberOfArguments functionType-- x ->- error $ "Value given to function is (likely) not the name of a function.\n" <> show x+ VarI _ functionType _ ->+ determineNumberOfArguments functionType+ x ->+ error $ "Value given to function is (likely) not the name of a function.\n" <> show x e <- topLevelCase nargs return (nargs, e)- where determineNumberOfArguments :: Type -> [Type] determineNumberOfArguments ft = case ft of@@ -516,45 +511,66 @@ topLevelCase :: [ArgType] -> Q Exp topLevelCase ts = do let n = length ts- minLength = length [ () | Optional _ <- reverse ts ]+ minLength = length [() | Optional _ <- reverse ts] args <- newName "args"- lamE [varP args] (caseE (varE args)- (zipWith matchingCase [n,n-1..] [0..minLength] ++ [errorCase]))+ lamE+ [varP args]+ ( caseE+ (varE args)+ (zipWith matchingCase [n, n -1 ..] [0 .. minLength] ++ [errorCase])+ ) -- _ -> err "Wrong number of arguments" errorCase :: Q Match- errorCase = match wildP- (normalB [|throw . ErrorMessage . pretty $ "Wrong number of arguments for function: "- ++ $(litE (StringL (nameBase functionName))) |]) []+ errorCase =+ match+ wildP+ ( normalB+ [|+ throw . ErrorMessage . pretty $+ "Wrong number of arguments for function: "+ ++ $(litE (StringL (nameBase functionName)))+ |]+ )+ [] -- [x,y] -> case pure add <*> fromObject x <*> fromObject y of ... matchingCase :: Int -> Int -> Q Match matchingCase n x = do- vars <- mapM (\_ -> Just <$> newName "x") [1..n]+ vars <- mapM (\_ -> Just <$> newName "x") [1 .. n] let optVars = replicate x (Nothing :: Maybe Name)- match ((listP . map varP . catMaybes) vars)- (normalB- (caseE- (foldl genArgumentCast [|pure $(varE functionName)|]- (zip (vars ++ optVars) (repeat [|(<*>)|])))- [successfulEvaluation, failedEvaluation]))- []+ match+ ((listP . map varP . catMaybes) vars)+ ( normalB+ ( caseE+ ( foldl+ genArgumentCast+ [|pure $(varE functionName)|]+ (zip (vars ++ optVars) (repeat [|(<*>)|]))+ )+ [successfulEvaluation, failedEvaluation]+ )+ )+ [] genArgumentCast :: Q Exp -> (Maybe Name, Q Exp) -> Q Exp genArgumentCast e = \case- (Just v,op) ->+ (Just v, op) -> infixE (Just e) op (Just [|fromObject $(varE v)|]) (Nothing, op) -> infixE (Just e) op (Just [|pure Nothing|]) successfulEvaluation :: Q Match- successfulEvaluation = newName "action" >>= \action ->- match (conP (mkName "Right") [varP action])- (normalB [|toObject <$> $(varE action)|])- []+ successfulEvaluation =+ newName "action" >>= \action ->+ match+ (conP (mkName "Right") [varP action])+ (normalB [|toObject <$> $(varE action)|])+ [] failedEvaluation :: Q Match- failedEvaluation = newName "e" >>= \e ->- match (conP (mkName "Left") [varP e])- (normalB [|err ($(varE e) :: Doc AnsiStyle)|])- []-+ failedEvaluation =+ newName "e" >>= \e ->+ match+ (conP (mkName "Left") [varP e])+ (normalB [|err ($(varE e) :: Doc AnsiStyle)|])+ []
nvim-hs.cabal view
@@ -1,5 +1,5 @@ name: nvim-hs-version: 2.1.0.5+version: 2.1.0.7 synopsis: Haskell plugin backend for neovim description: This package provides a plugin provider for neovim. It allows you to write@@ -124,6 +124,7 @@ , stm , streaming-commons , template-haskell+ , template-haskell-compat-v0208 , text , time , transformers@@ -178,6 +179,7 @@ , streaming-commons , text , template-haskell+ , template-haskell-compat-v0208 , time , transformers , transformers-base