diff --git a/library/Neovim/API/Parser.hs b/library/Neovim/API/Parser.hs --- a/library/Neovim/API/Parser.hs +++ b/library/Neovim/API/Parser.hs @@ -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'])) diff --git a/library/Neovim/API/TH.hs b/library/Neovim/API/TH.hs --- a/library/Neovim/API/TH.hs +++ b/library/Neovim/API/TH.hs @@ -1,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)|]) + [] 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.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