{-# OPTIONS_GHC -fno-warn-orphans #-} module Ribosome.Plugin.TH.Handler where import Control.Exception (throw) import Data.MessagePack (Object) import Data.Text.Prettyprint.Doc (Doc, Pretty(..)) import Data.Text.Prettyprint.Doc.Render.Terminal (AnsiStyle) import Language.Haskell.TH import Language.Haskell.TH.Syntax (Lift(..)) import Neovim.Exceptions (NeovimException(ErrorMessage)) import Neovim.Plugin.Classes ( AutocmdOptions(AutocmdOptions), CommandOption(..), CommandOptions, RangeSpecification(..), Synchronous(..), ) import qualified Text.Show as Show (Show(show)) import Ribosome.Msgpack.Decode (fromMsgpack) import Ribosome.Msgpack.Encode (toMsgpack) data RpcHandlerConfig = RpcHandlerConfig { RpcHandlerConfig -> Synchronous rhcSync :: Synchronous, RpcHandlerConfig -> Maybe Text rhcName :: Maybe Text, RpcHandlerConfig -> Maybe [CommandOption] rhcCmd :: Maybe [CommandOption], RpcHandlerConfig -> Maybe Text rhcAutocmd :: Maybe Text, RpcHandlerConfig -> Maybe AutocmdOptions rhcAutocmdOptions :: Maybe AutocmdOptions } deriving (RpcHandlerConfig -> RpcHandlerConfig -> Bool (RpcHandlerConfig -> RpcHandlerConfig -> Bool) -> (RpcHandlerConfig -> RpcHandlerConfig -> Bool) -> Eq RpcHandlerConfig forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: RpcHandlerConfig -> RpcHandlerConfig -> Bool $c/= :: RpcHandlerConfig -> RpcHandlerConfig -> Bool == :: RpcHandlerConfig -> RpcHandlerConfig -> Bool $c== :: RpcHandlerConfig -> RpcHandlerConfig -> Bool Eq, Int -> RpcHandlerConfig -> ShowS [RpcHandlerConfig] -> ShowS RpcHandlerConfig -> String (Int -> RpcHandlerConfig -> ShowS) -> (RpcHandlerConfig -> String) -> ([RpcHandlerConfig] -> ShowS) -> Show RpcHandlerConfig forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [RpcHandlerConfig] -> ShowS $cshowList :: [RpcHandlerConfig] -> ShowS show :: RpcHandlerConfig -> String $cshow :: RpcHandlerConfig -> String showsPrec :: Int -> RpcHandlerConfig -> ShowS $cshowsPrec :: Int -> RpcHandlerConfig -> ShowS Show) defaultRpcHandlerConfig :: RpcHandlerConfig defaultRpcHandlerConfig :: RpcHandlerConfig defaultRpcHandlerConfig = Synchronous -> Maybe Text -> Maybe [CommandOption] -> Maybe Text -> Maybe AutocmdOptions -> RpcHandlerConfig RpcHandlerConfig Synchronous Async Maybe Text forall a. Maybe a Nothing Maybe [CommandOption] forall a. Maybe a Nothing Maybe Text forall a. Maybe a Nothing Maybe AutocmdOptions forall a. Maybe a Nothing data RpcDefDetail = RpcFunction { RpcDefDetail -> Synchronous rfSync :: Synchronous } | RpcCommand { RpcDefDetail -> CommandOptions rcOptions :: CommandOptions } | RpcAutocmd { RpcDefDetail -> Text raEvent :: Text, RpcDefDetail -> Synchronous raSync :: Synchronous, RpcDefDetail -> AutocmdOptions raOptions :: AutocmdOptions } deriving Int -> RpcDefDetail -> ShowS [RpcDefDetail] -> ShowS RpcDefDetail -> String (Int -> RpcDefDetail -> ShowS) -> (RpcDefDetail -> String) -> ([RpcDefDetail] -> ShowS) -> Show RpcDefDetail forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [RpcDefDetail] -> ShowS $cshowList :: [RpcDefDetail] -> ShowS show :: RpcDefDetail -> String $cshow :: RpcDefDetail -> String showsPrec :: Int -> RpcDefDetail -> ShowS $cshowsPrec :: Int -> RpcDefDetail -> ShowS Show data RpcDef m = RpcDef { RpcDef m -> RpcDefDetail rdDetail :: RpcDefDetail, RpcDef m -> Text rdName :: Text, RpcDef m -> [Object] -> m Object rdHandler :: [Object] -> m Object } instance Show (RpcDef m) where show :: RpcDef m -> String show (RpcDef RpcDefDetail d Text n [Object] -> m Object _) = String "RpcDef" String -> ShowS forall a. Semigroup a => a -> a -> a <> (RpcDefDetail, Text) -> String forall b a. (Show a, IsString b) => a -> b show (RpcDefDetail d, Text n) deriving instance Lift Synchronous deriving instance Lift RangeSpecification deriving instance Lift CommandOption deriving instance Lift AutocmdOptions unfoldFunctionParams :: Type -> [Type] unfoldFunctionParams :: Type -> [Type] unfoldFunctionParams (ForallT [TyVarBndr] _ [Type] _ Type t) = Type -> [Type] unfoldFunctionParams Type t unfoldFunctionParams (AppT (AppT Type ArrowT Type t) Type r) = Type t Type -> [Type] -> [Type] forall a. a -> [a] -> [a] : Type -> [Type] unfoldFunctionParams Type r unfoldFunctionParams Type _ = [] functionParamTypes :: Name -> Q [Type] functionParamTypes :: Name -> Q [Type] functionParamTypes Name name = Name -> Q Info reify Name name Q Info -> (Info -> [Type]) -> Q [Type] forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b <&> \case (VarI Name _ Type functionType Maybe Dec _) -> Type -> [Type] unfoldFunctionParams Type functionType Info _ -> String -> [Type] forall (m :: * -> *) a. MonadFail m => String -> m a fail (String -> [Type]) -> String -> [Type] forall a b. (a -> b) -> a -> b $ String "rpc handler `" String -> ShowS forall a. Semigroup a => a -> a -> a <> Name -> String forall b a. (Show a, IsString b) => a -> b show Name name String -> ShowS forall a. Semigroup a => a -> a -> a <> String "` is not a function" errorBody :: Name -> BodyQ errorBody :: Name -> BodyQ errorBody Name rpcName = Q Exp -> BodyQ normalB [|throw . ErrorMessage . pretty $ ($(errLit) :: String)|] where errLit :: Q Exp errLit = Lit -> Q Exp litE (String -> Lit StringL String errMsg) errMsg :: String errMsg = String "Wrong number of arguments for rpc handler: " String -> ShowS forall a. Semigroup a => a -> a -> a <> Name -> String nameBase Name rpcName errorCase :: Name -> Q Match errorCase :: Name -> Q Match errorCase Name rpcName = PatQ -> BodyQ -> [DecQ] -> Q Match match PatQ wildP (Name -> BodyQ errorBody Name rpcName) [] failedEvaluation :: Q Match failedEvaluation :: Q Match failedEvaluation = do Name e <- String -> Q Name newName String "e" PatQ -> BodyQ -> [DecQ] -> Q Match match (Name -> [PatQ] -> PatQ conP (String -> Name mkName String "Left") [Name -> PatQ varP Name e]) (Q Exp -> BodyQ normalB [|throw . ErrorMessage $ ($(varE e) :: Doc AnsiStyle)|]) [] successfulEvaluation :: Q Match successfulEvaluation :: Q Match successfulEvaluation = do Name action <- String -> Q Name newName String "action" PatQ -> BodyQ -> [DecQ] -> Q Match match (Name -> [PatQ] -> PatQ conP (String -> Name mkName String "Right") [Name -> PatQ varP Name action]) (Q Exp -> BodyQ normalB [|toMsgpack <$> $(varE action)|]) [] dispatchCase :: PatQ -> ExpQ -> Q Match dispatchCase :: PatQ -> Q Exp -> Q Match dispatchCase PatQ params Q Exp dispatch = PatQ -> BodyQ -> [DecQ] -> Q Match match PatQ params (Q Exp -> BodyQ normalB (Q Exp -> [Q Match] -> Q Exp caseE Q Exp dispatch [Q Match] resultCases)) [] where resultCases :: [Q Match] resultCases = [Q Match Item [Q Match] successfulEvaluation, Q Match Item [Q Match] failedEvaluation] handlerCall :: Name -> [ExpQ] -> ExpQ handlerCall :: Name -> [Q Exp] -> Q Exp handlerCall Name handlerName = (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> [Q Exp] -> Q Exp forall (t :: * -> *) b a. Foldable t => (b -> a -> b) -> b -> t a -> b foldl Q Exp -> Q Exp -> Q Exp decodeSeq [|pure $(varE handlerName)|] where decodeSeq :: Q Exp -> Q Exp -> Q Exp decodeSeq Q Exp z = Q Exp -> Q Exp -> Q Exp -> Q Exp infixApp Q Exp z [|(<*>)|] decodedCallSequence :: Name -> [ExpQ] -> ExpQ decodedCallSequence :: Name -> [Q Exp] -> Q Exp decodedCallSequence Name handlerName [Q Exp] vars = Name -> [Q Exp] -> Q Exp handlerCall Name handlerName (Q Exp -> Q Exp decoded (Q Exp -> Q Exp) -> [Q Exp] -> [Q Exp] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> [Q Exp] vars) where decoded :: Q Exp -> Q Exp decoded Q Exp a = [|fromMsgpack $(a)|] argsCase :: Name -> PatQ -> [Name] -> Q Match argsCase :: Name -> PatQ -> [Name] -> Q Match argsCase Name handlerName PatQ params [Name] paramNames = PatQ -> Q Exp -> Q Match dispatchCase PatQ params Q Exp dispatch where dispatch :: Q Exp dispatch = Name -> [Q Exp] -> Q Exp decodedCallSequence Name handlerName [Q Exp] paramVars paramVars :: [Q Exp] paramVars = Name -> Q Exp varE (Name -> Q Exp) -> [Name] -> [Q Exp] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> [Name] paramNames rpcLambda :: Q Match -> Maybe (Q Match) -> ExpQ rpcLambda :: Q Match -> Maybe (Q Match) -> Q Exp rpcLambda Q Match matchingArgsCase Maybe (Q Match) errorCase' = do Name args <- String -> Q Name newName String "args" [PatQ] -> Q Exp -> Q Exp lamE [Name -> PatQ varP Name args] [|$(caseE (varE args) (matchingArgsCase : maybeToList errorCase'))|] rpcLambdaWithErrorCase :: Name -> Q Match -> ExpQ rpcLambdaWithErrorCase :: Name -> Q Match -> Q Exp rpcLambdaWithErrorCase Name funcName Q Match matchingArgsCase = Q Match -> Maybe (Q Match) -> Q Exp rpcLambda Q Match matchingArgsCase (Maybe (Q Match) -> Q Exp) -> Maybe (Q Match) -> Q Exp forall a b. (a -> b) -> a -> b $ Q Match -> Maybe (Q Match) forall a. a -> Maybe a Just (Name -> Q Match errorCase Name funcName) rpcLambdaWithoutErrorCase :: Q Match -> ExpQ rpcLambdaWithoutErrorCase :: Q Match -> Q Exp rpcLambdaWithoutErrorCase Q Match matchingArgsCase = Q Match -> Maybe (Q Match) -> Q Exp rpcLambda Q Match matchingArgsCase Maybe (Q Match) forall a. Maybe a Nothing listParamsPattern :: [Name] -> PatQ listParamsPattern :: [Name] -> PatQ listParamsPattern = [PatQ] -> PatQ listP ([PatQ] -> PatQ) -> ([Name] -> [PatQ]) -> [Name] -> PatQ forall b c a. (b -> c) -> (a -> b) -> a -> c . (Name -> PatQ varP (Name -> PatQ) -> [Name] -> [PatQ] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$>) lambdaNames :: Int -> Q [Name] lambdaNames :: Int -> Q [Name] lambdaNames Int count = Int -> Q Name -> Q [Name] forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a] replicateM Int count (String -> Q Name newName String "a")