{-# OPTIONS_GHC -fno-warn-orphans #-} module Ribosome.Plugin.TH where import qualified Data.Text as Text (unpack) import Language.Haskell.TH (ExpQ, Lit(StringL), Name, listE, litE, nameBase) import Neovim.Plugin.Classes ( AutocmdOptions, Synchronous(..), ) import Ribosome.Data.String (capitalize) import Ribosome.Plugin.TH.Command (handlerParams, rpcCommand) import Ribosome.Plugin.TH.Handler ( RpcDef(RpcDef), RpcDefDetail(RpcFunction, RpcAutocmd), RpcHandlerConfig(RpcHandlerConfig), argsCase, defaultRpcHandlerConfig, functionParamTypes, lambdaNames, listParamsPattern, rpcLambdaWithErrorCase, ) functionImplementation :: Name -> ExpQ functionImplementation :: Name -> ExpQ functionImplementation Name name = do [Type] paramTypes <- Name -> Q [Type] functionParamTypes Name name [Name] paramNames <- Int -> Q [Name] lambdaNames ([Type] -> Int forall (t :: * -> *) a. Foldable t => t a -> Int length [Type] paramTypes) Name -> Q Match -> ExpQ rpcLambdaWithErrorCase Name name (Name -> PatQ -> [Name] -> Q Match argsCase Name name ([Name] -> PatQ listParamsPattern [Name] paramNames) [Name] paramNames) rpcFunction :: String -> Synchronous -> Name -> ExpQ rpcFunction :: String -> Synchronous -> Name -> ExpQ rpcFunction String name Synchronous sync Name funcName = do Exp fun <- Name -> ExpQ functionImplementation Name funcName [|RpcDef (RpcFunction sync) $((litE (StringL name))) $(return fun)|] rpcAutocmd :: String -> Name -> Synchronous -> Maybe AutocmdOptions -> String -> ExpQ rpcAutocmd :: String -> Name -> Synchronous -> Maybe AutocmdOptions -> String -> ExpQ rpcAutocmd String name Name funcName Synchronous sync Maybe AutocmdOptions options String event = do Exp fun <- Name -> ExpQ functionImplementation Name funcName [|RpcDef (RpcAutocmd event sync (fromMaybe def options)) $((litE (StringL name))) $(return fun)|] vimName :: Name -> Maybe String -> String vimName :: Name -> Maybe String -> String vimName Name funcName = String -> String capitalize (String -> String) -> (Maybe String -> String) -> Maybe String -> String forall b c a. (b -> c) -> (a -> b) -> a -> c . String -> Maybe String -> String forall a. a -> Maybe a -> a fromMaybe (Name -> String nameBase Name funcName) rpcHandler :: (RpcHandlerConfig -> RpcHandlerConfig) -> Name -> ExpQ rpcHandler :: (RpcHandlerConfig -> RpcHandlerConfig) -> Name -> ExpQ rpcHandler RpcHandlerConfig -> RpcHandlerConfig confTrans = RpcHandlerConfig -> Name -> ExpQ handler (RpcHandlerConfig -> RpcHandlerConfig confTrans RpcHandlerConfig defaultRpcHandlerConfig) where handler :: RpcHandlerConfig -> Name -> ExpQ handler (RpcHandlerConfig Synchronous sync Maybe Text name Maybe [CommandOption] cmd Maybe Text autocmd Maybe AutocmdOptions auOptions) Name funcName = do HandlerParams params <- Name -> Q HandlerParams handlerParams Name funcName Exp rpcFun <- String -> Synchronous -> Name -> ExpQ rpcFunction String vimName' Synchronous sync Name funcName Maybe Exp rpcCmd <- ([CommandOption] -> ExpQ) -> Maybe [CommandOption] -> Q (Maybe Exp) forall (t :: * -> *) (f :: * -> *) a b. (Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b) traverse (String -> Name -> HandlerParams -> Synchronous -> [CommandOption] -> ExpQ rpcCommand String vimName' Name funcName HandlerParams params Synchronous sync) Maybe [CommandOption] cmd Maybe Exp rpcAu <- (String -> ExpQ) -> Maybe String -> Q (Maybe Exp) forall (t :: * -> *) (f :: * -> *) a b. (Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b) traverse (String -> Name -> Synchronous -> Maybe AutocmdOptions -> String -> ExpQ rpcAutocmd String vimName' Name funcName Synchronous sync Maybe AutocmdOptions auOptions) (Text -> String Text.unpack (Text -> String) -> Maybe Text -> Maybe String forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Maybe Text autocmd) [ExpQ] -> ExpQ listE ([ExpQ] -> ExpQ) -> [ExpQ] -> ExpQ forall a b. (a -> b) -> a -> b $ Exp -> ExpQ forall (m :: * -> *) a. Monad m => a -> m a return (Exp -> ExpQ) -> [Exp] -> [ExpQ] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Exp rpcFun Exp -> [Exp] -> [Exp] forall a. a -> [a] -> [a] : Maybe Exp -> [Exp] forall a. Maybe a -> [a] maybeToList Maybe Exp rpcCmd [Exp] -> [Exp] -> [Exp] forall a. Semigroup a => a -> a -> a <> Maybe Exp -> [Exp] forall a. Maybe a -> [a] maybeToList Maybe Exp rpcAu where vimName' :: String vimName' = Name -> Maybe String -> String vimName Name funcName (Text -> String Text.unpack (Text -> String) -> Maybe Text -> Maybe String forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Maybe Text name) rpcHandlerDef :: Name -> ExpQ rpcHandlerDef :: Name -> ExpQ rpcHandlerDef = (RpcHandlerConfig -> RpcHandlerConfig) -> Name -> ExpQ rpcHandler RpcHandlerConfig -> RpcHandlerConfig forall a. a -> a id