{-# 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