{-# OPTIONS_GHC -fno-warn-orphans #-} module Ribosome.Plugin.TH.Command where import Control.Exception (throw) import Data.Aeson (FromJSON, eitherDecodeStrict) import qualified Data.ByteString as ByteString (intercalate) import Data.MessagePack (Object(ObjectArray)) import Data.Text.Prettyprint.Doc (Pretty(..)) import Language.Haskell.TH import Neovim.Exceptions (NeovimException(ErrorMessage)) import Neovim.Plugin.Classes (CommandArguments, CommandOption(..), Synchronous, mkCommandOptions) import Ribosome.Msgpack.Decode (fromMsgpack) import Ribosome.Msgpack.Encode (MsgpackEncode(toMsgpack)) import Ribosome.Msgpack.Util (Err) import Ribosome.Plugin.TH.Handler ( RpcDef(RpcDef), RpcDefDetail(RpcCommand), argsCase, decodedCallSequence, functionParamTypes, handlerCall, lambdaNames, listParamsPattern, ) data CmdParamType = PrimParam | DataParam | ListParam deriving (CmdParamType -> CmdParamType -> Bool (CmdParamType -> CmdParamType -> Bool) -> (CmdParamType -> CmdParamType -> Bool) -> Eq CmdParamType forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: CmdParamType -> CmdParamType -> Bool $c/= :: CmdParamType -> CmdParamType -> Bool == :: CmdParamType -> CmdParamType -> Bool $c== :: CmdParamType -> CmdParamType -> Bool Eq, Int -> CmdParamType -> ShowS [CmdParamType] -> ShowS CmdParamType -> String (Int -> CmdParamType -> ShowS) -> (CmdParamType -> String) -> ([CmdParamType] -> ShowS) -> Show CmdParamType forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [CmdParamType] -> ShowS $cshowList :: [CmdParamType] -> ShowS show :: CmdParamType -> String $cshow :: CmdParamType -> String showsPrec :: Int -> CmdParamType -> ShowS $cshowsPrec :: Int -> CmdParamType -> ShowS Show) data CmdParams = ZeroParams | OneParam Bool CmdParamType | OnlyPrims Int | DataPlus Int deriving (CmdParams -> CmdParams -> Bool (CmdParams -> CmdParams -> Bool) -> (CmdParams -> CmdParams -> Bool) -> Eq CmdParams forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: CmdParams -> CmdParams -> Bool $c/= :: CmdParams -> CmdParams -> Bool == :: CmdParams -> CmdParams -> Bool $c== :: CmdParams -> CmdParams -> Bool Eq, Int -> CmdParams -> ShowS [CmdParams] -> ShowS CmdParams -> String (Int -> CmdParams -> ShowS) -> (CmdParams -> String) -> ([CmdParams] -> ShowS) -> Show CmdParams forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [CmdParams] -> ShowS $cshowList :: [CmdParams] -> ShowS show :: CmdParams -> String $cshow :: CmdParams -> String showsPrec :: Int -> CmdParams -> ShowS $cshowsPrec :: Int -> CmdParams -> ShowS Show) data HandlerParams = HandlerParams { HandlerParams -> Bool handlerHasArgsParam :: Bool, HandlerParams -> CmdParams handlerCmdParams :: CmdParams } deriving (HandlerParams -> HandlerParams -> Bool (HandlerParams -> HandlerParams -> Bool) -> (HandlerParams -> HandlerParams -> Bool) -> Eq HandlerParams forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: HandlerParams -> HandlerParams -> Bool $c/= :: HandlerParams -> HandlerParams -> Bool == :: HandlerParams -> HandlerParams -> Bool $c== :: HandlerParams -> HandlerParams -> Bool Eq, Int -> HandlerParams -> ShowS [HandlerParams] -> ShowS HandlerParams -> String (Int -> HandlerParams -> ShowS) -> (HandlerParams -> String) -> ([HandlerParams] -> ShowS) -> Show HandlerParams forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [HandlerParams] -> ShowS $cshowList :: [HandlerParams] -> ShowS show :: HandlerParams -> String $cshow :: HandlerParams -> String showsPrec :: Int -> HandlerParams -> ShowS $cshowsPrec :: Int -> HandlerParams -> ShowS Show) colon :: Name colon :: Name colon = String -> Name mkName String ":" colonE :: ExpQ colonE :: ExpQ colonE = Name -> ExpQ varE Name colon colonP :: PatQ colonP :: PatQ colonP = Name -> PatQ varP Name colon cmdArgsCase :: Name -> [Name] -> Q Match cmdArgsCase :: Name -> [Name] -> Q Match cmdArgsCase Name handlerName [Name] paramNames = Name -> PatQ -> [Name] -> Q Match argsCase Name handlerName ([Name] -> PatQ listParamsPattern (String -> Name mkName String "_" Name -> [Name] -> [Name] forall a. a -> [a] -> [a] : [Name] paramNames)) [Name] paramNames decodeJson :: FromJSON a => [Object] -> Either Err a decodeJson :: [Object] -> Either Err a decodeJson = (String -> Err) -> Either String a -> Either Err a forall a c b. (a -> c) -> Either a b -> Either c b mapLeft String -> Err forall a ann. Pretty a => a -> Doc ann pretty (Either String a -> Either Err a) -> ([ByteString] -> Either String a) -> [ByteString] -> Either Err a forall b c a. (b -> c) -> (a -> b) -> a -> c . ByteString -> Either String a forall a. FromJSON a => ByteString -> Either String a eitherDecodeStrict (ByteString -> Either String a) -> ([ByteString] -> ByteString) -> [ByteString] -> Either String a forall b c a. (b -> c) -> (a -> b) -> a -> c . ByteString -> [ByteString] -> ByteString ByteString.intercalate ByteString " " ([ByteString] -> Either Err a) -> ([Object] -> Either Err [ByteString]) -> [Object] -> Either Err a forall (m :: * -> *) b c a. Monad m => (b -> m c) -> (a -> m b) -> a -> m c <=< (Object -> Either Err ByteString) -> [Object] -> Either Err [ByteString] forall (t :: * -> *) (f :: * -> *) a b. (Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b) traverse Object -> Either Err ByteString forall a. MsgpackDecode a => Object -> Either Err a fromMsgpack primDispatch :: [MatchQ] -> String -> Name -> Name -> Name -> [Name] -> Bool -> ExpQ primDispatch :: [Q Match] -> String -> Name -> Name -> Name -> [Name] -> Bool -> ExpQ primDispatch [Q Match] extraCases String rpcName Name argsName Name handlerName Name cmdArgsName [Name] paramNames Bool hasArgsParam = ExpQ -> [Q Match] -> ExpQ caseE (Name -> ExpQ varE Name argsName) ([Q Match] extraCases [Q Match] -> [Q Match] -> [Q Match] forall a. [a] -> [a] -> [a] ++ [Q Match Item [Q Match] matching, Q Match Item [Q Match] invalidArgs]) where matching :: Q Match matching = PatQ -> BodyQ -> [DecQ] -> Q Match match ([Name] -> PatQ primArgPattern [Name] paramNames) (ExpQ -> BodyQ normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ forall a b. (a -> b) -> a -> b $ Name -> [ExpQ] -> ExpQ decodedCallSequence Name handlerName [ExpQ] vars) [] invalidArgs :: Q Match invalidArgs = PatQ -> BodyQ -> [DecQ] -> Q Match match PatQ wildP (ExpQ -> BodyQ normalB [|invalidArgCount $ $(nameLit) <> "(" <> show $(varE argsName) <> ")"|]) [] vars :: [ExpQ] vars = Name -> ExpQ varE (Name -> ExpQ) -> [Name] -> [ExpQ] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> [Name] params params :: [Name] params = if Bool hasArgsParam then Name cmdArgsName Name -> [Name] -> [Name] forall a. a -> [a] -> [a] : [Name] paramNames else [Name] paramNames nameLit :: ExpQ nameLit = Lit -> ExpQ litE (String -> Lit StringL String rpcName) primDispatchStrict :: String -> Name -> Name -> Name -> [Name] -> Bool -> ExpQ primDispatchStrict :: String -> Name -> Name -> Name -> [Name] -> Bool -> ExpQ primDispatchStrict = [Q Match] -> String -> Name -> Name -> Name -> [Name] -> Bool -> ExpQ primDispatch [] primDispatchMaybe :: String -> Name -> Name -> Name -> [Name] -> Bool -> ExpQ primDispatchMaybe :: String -> Name -> Name -> Name -> [Name] -> Bool -> ExpQ primDispatchMaybe String rpcName Name argsName Name handlerName = [Q Match] -> String -> Name -> Name -> Name -> [Name] -> Bool -> ExpQ primDispatch [Q Match Item [Q Match] nothingCase] String rpcName Name argsName Name handlerName where nothingCase :: Q Match nothingCase = PatQ -> BodyQ -> [DecQ] -> Q Match match ([PatQ] -> PatQ listP []) (ExpQ -> BodyQ normalB (ExpQ -> ExpQ -> ExpQ appE [|pure|] (ExpQ -> ExpQ -> ExpQ appE (Name -> ExpQ varE Name handlerName) [|Nothing|]))) [] primDispatchList :: String -> Name -> Name -> Name -> [Name] -> Bool -> ExpQ primDispatchList :: String -> Name -> Name -> Name -> [Name] -> Bool -> ExpQ primDispatchList String _ Name argsName Name handlerName Name cmdArgsName [Name] _ Bool hasArgsParam = do Name listArgName <- String -> Q Name newName String "as" ExpQ -> [Q Match] -> ExpQ caseE (Name -> ExpQ varE Name argsName) [Name -> Q Match listCase Name listArgName] where listCase :: Name -> Q Match listCase Name listArgName = PatQ -> BodyQ -> [DecQ] -> Q Match match (Name -> PatQ varP Name listArgName) (ExpQ -> BodyQ normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ forall a b. (a -> b) -> a -> b $ Name -> [ExpQ] -> ExpQ handlerCall Name handlerName (Name -> [ExpQ] params Name listArgName)) [] params :: Name -> [ExpQ] params Name listArgName = if Bool hasArgsParam then [[|fromMsgpack $(varE cmdArgsName)|], Name -> ExpQ decodedList Name listArgName] else [Name -> ExpQ decodedList Name listArgName] decodedList :: Name -> ExpQ decodedList Name listArgName = [|traverse fromMsgpack $(varE listArgName)|] jsonDispatch :: Name -> Name -> Name -> [Name] -> Bool -> ExpQ jsonDispatch :: Name -> Name -> Name -> [Name] -> Bool -> ExpQ jsonDispatch Name restName Name handlerName Name cmdArgsName [Name] paramNames Bool hasArgsParam = ExpQ -> ExpQ -> ExpQ -> ExpQ infixApp ExpQ prims [|(<*>)|] ExpQ decodedRest where prims :: ExpQ prims = Name -> [ExpQ] -> ExpQ decodedCallSequence Name handlerName [ExpQ] vars vars :: [ExpQ] vars = Name -> ExpQ varE (Name -> ExpQ) -> [Name] -> [ExpQ] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> [Name] params params :: [Name] params = if Bool hasArgsParam then Name cmdArgsName Name -> [Name] -> [Name] forall a. a -> [a] -> [a] : [Name] paramNames else [Name] paramNames decodedRest :: ExpQ decodedRest = [|decodeJson $(varE restName)|] primArgPattern :: [Name] -> PatQ primArgPattern :: [Name] -> PatQ primArgPattern [Name] paramNames = (PatQ -> PatQ -> PatQ) -> PatQ -> [PatQ] -> PatQ forall (t :: * -> *) a b. Foldable t => (a -> b -> b) -> b -> t a -> b foldr PatQ -> PatQ -> PatQ f ([PatQ] -> PatQ listP []) (Name -> PatQ varP (Name -> PatQ) -> [Name] -> [PatQ] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> [Name] paramNames) where f :: PatQ -> PatQ -> PatQ f PatQ a = PatQ -> Name -> PatQ -> PatQ infixP PatQ a (String -> Name mkName String ":") jsonArgPattern :: [Name] -> Name -> PatQ jsonArgPattern :: [Name] -> Name -> PatQ jsonArgPattern [Name] paramNames Name restName = (PatQ -> PatQ -> PatQ) -> PatQ -> [PatQ] -> PatQ forall (t :: * -> *) a b. Foldable t => (a -> b -> b) -> b -> t a -> b foldr PatQ -> PatQ -> PatQ f (Name -> PatQ varP Name restName) (Name -> PatQ varP (Name -> PatQ) -> [Name] -> [PatQ] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> [Name] paramNames) where f :: PatQ -> PatQ -> PatQ f PatQ a = PatQ -> Name -> PatQ -> PatQ infixP PatQ a (String -> Name mkName String ":") newtype ArgNormalizer m = ArgNormalizer (Text -> [Object] -> m (Object, [Object])) shapeError :: Text -> m a shapeError :: Text -> m a shapeError = NeovimException -> m a forall a e. Exception e => e -> a throw (NeovimException -> m a) -> (Text -> NeovimException) -> Text -> m a forall b c a. (b -> c) -> (a -> b) -> a -> c . Err -> NeovimException ErrorMessage (Err -> NeovimException) -> (Text -> Err) -> Text -> NeovimException forall b c a. (b -> c) -> (a -> b) -> a -> c . Text -> Err forall a ann. Pretty a => a -> Doc ann pretty (Text -> Err) -> (Text -> Text) -> Text -> Err forall b c a. (b -> c) -> (a -> b) -> a -> c . Text -> Text errorMessage where errorMessage :: Text -> Text errorMessage = (Text "Bad argument shape for rpc command: " Text -> Text -> Text forall a. Semigroup a => a -> a -> a <>) normalizeArgsFlat :: Monad m => ArgNormalizer m normalizeArgsFlat :: ArgNormalizer m normalizeArgsFlat = (Text -> [Object] -> m (Object, [Object])) -> ArgNormalizer m forall (m :: * -> *). (Text -> [Object] -> m (Object, [Object])) -> ArgNormalizer m ArgNormalizer Text -> [Object] -> m (Object, [Object]) forall (m :: * -> *) a. (Monad m, Show a) => Text -> [a] -> m (a, [a]) normalize where normalize :: Text -> [a] -> m (a, [a]) normalize Text _ (a cmdArgs : [a] rest) = (a, [a]) -> m (a, [a]) forall (m :: * -> *) a. Monad m => a -> m a return (a cmdArgs, [a] rest) normalize Text rpcName [a] args = Text -> m (a, [a]) forall k (m :: k -> *) (a :: k). Text -> m a shapeError (Text -> m (a, [a])) -> Text -> m (a, [a]) forall a b. (a -> b) -> a -> b $ Text rpcName Text -> Text -> Text forall a. Semigroup a => a -> a -> a <> Text " (" Text -> Text -> Text forall a. Semigroup a => a -> a -> a <> [a] -> Text forall b a. (Show a, IsString b) => a -> b show [a] args Text -> Text -> Text forall a. Semigroup a => a -> a -> a <> Text ")" normalizeArgsPlus :: Monad m => ArgNormalizer m normalizeArgsPlus :: ArgNormalizer m normalizeArgsPlus = (Text -> [Object] -> m (Object, [Object])) -> ArgNormalizer m forall (m :: * -> *). (Text -> [Object] -> m (Object, [Object])) -> ArgNormalizer m ArgNormalizer Text -> [Object] -> m (Object, [Object]) forall a (m :: * -> *). (IsList a, Monad m, Show a, Item a ~ Object) => Text -> a -> m (Object, [Object]) normalize where normalize :: Text -> a -> m (Object, [Object]) normalize Text _ [Item a cmdArgs, Item a first', ObjectArray rest] = (Object, [Object]) -> m (Object, [Object]) forall (m :: * -> *) a. Monad m => a -> m a return (Item a Object cmdArgs, Item a Object first' Object -> [Object] -> [Object] forall a. a -> [a] -> [a] : [Object] rest) normalize Text rpcName a args = Text -> m (Object, [Object]) forall k (m :: k -> *) (a :: k). Text -> m a shapeError (Text -> m (Object, [Object])) -> Text -> m (Object, [Object]) forall a b. (a -> b) -> a -> b $ Text rpcName Text -> Text -> Text forall a. Semigroup a => a -> a -> a <> Text " (" Text -> Text -> Text forall a. Semigroup a => a -> a -> a <> a -> Text forall b a. (Show a, IsString b) => a -> b show a args Text -> Text -> Text forall a. Semigroup a => a -> a -> a <> Text ")" normalizeArgs :: CmdParams -> ExpQ normalizeArgs :: CmdParams -> ExpQ normalizeArgs CmdParams ZeroParams = [|normalizeArgsFlat|] normalizeArgs (OnlyPrims Int 1) = [|normalizeArgsFlat|] normalizeArgs (OneParam Bool _ CmdParamType PrimParam) = [|normalizeArgsFlat|] normalizeArgs (OneParam Bool _ CmdParamType ListParam) = [|normalizeArgsFlat|] normalizeArgs CmdParams _ = [|normalizeArgsPlus|] rpc :: Monad m => MsgpackEncode a => Text -> ArgNormalizer m -> (Object -> [Object] -> Either Err (m a)) -> [Object] -> m Object rpc :: Text -> ArgNormalizer m -> (Object -> [Object] -> Either Err (m a)) -> [Object] -> m Object rpc Text rpcName (ArgNormalizer Text -> [Object] -> m (Object, [Object]) normalize) Object -> [Object] -> Either Err (m a) dispatch = a -> Object forall a. MsgpackEncode a => a -> Object toMsgpack (a -> Object) -> ((Object, [Object]) -> m a) -> (Object, [Object]) -> m Object forall (f0 :: * -> *) (f1 :: * -> *) a b. (Functor f0, Functor f1) => (a -> b) -> f1 (f0 a) -> f1 (f0 b) <$$> Either Err (m a) -> m a forall c. Either Err c -> c decodeResult (Either Err (m a) -> m a) -> ((Object, [Object]) -> Either Err (m a)) -> (Object, [Object]) -> m a forall b c a. (b -> c) -> (a -> b) -> a -> c . (Object -> [Object] -> Either Err (m a)) -> (Object, [Object]) -> Either Err (m a) forall a b c. (a -> b -> c) -> (a, b) -> c uncurry Object -> [Object] -> Either Err (m a) dispatch ((Object, [Object]) -> m Object) -> ([Object] -> m (Object, [Object])) -> [Object] -> m Object forall (m :: * -> *) b c a. Monad m => (b -> m c) -> (a -> m b) -> a -> m c <=< Text -> [Object] -> m (Object, [Object]) normalize Text rpcName where decodeResult :: Either Err c -> c decodeResult = (Err -> c) -> (c -> c) -> Either Err c -> c forall a c b. (a -> c) -> (b -> c) -> Either a b -> c either (NeovimException -> c forall a e. Exception e => e -> a throw (NeovimException -> c) -> (Err -> NeovimException) -> Err -> c forall b c a. (b -> c) -> (a -> b) -> a -> c . Err -> NeovimException ErrorMessage) c -> c forall a. a -> a id invalidArgCount :: String -> m a invalidArgCount :: String -> m a invalidArgCount = NeovimException -> m a forall a e. Exception e => e -> a throw (NeovimException -> m a) -> (String -> NeovimException) -> String -> m a forall b c a. (b -> c) -> (a -> b) -> a -> c . Err -> NeovimException ErrorMessage (Err -> NeovimException) -> (String -> Err) -> String -> NeovimException forall b c a. (b -> c) -> (a -> b) -> a -> c . String -> Err forall a ann. Pretty a => a -> Doc ann pretty (String -> Err) -> ShowS -> String -> Err forall b c a. (b -> c) -> (a -> b) -> a -> c . (String msg String -> ShowS forall a. Semigroup a => a -> a -> a <>) where msg :: String msg = String "Wrong number of arguments for rpc handler: " command :: String -> Name -> [Name] -> HandlerParams -> PatQ -> (Name -> Name -> [Name] -> Bool -> ExpQ) -> ExpQ command :: String -> Name -> [Name] -> HandlerParams -> PatQ -> (Name -> Name -> [Name] -> Bool -> ExpQ) -> ExpQ command String rpcName Name handlerName [Name] paramNames (HandlerParams Bool hasCmdArgs CmdParams cmdParams) PatQ argsPattern Name -> Name -> [Name] -> Bool -> ExpQ dispatch = do Name cmdArgsName <- String -> Q Name newName String "cmdArgs" [|rpc $(nameLit) $(normalizeArgs cmdParams) $(handler cmdArgsName)|] where handler :: Name -> ExpQ handler Name cmdArgsName = [PatQ] -> ExpQ -> ExpQ lamE [Name -> PatQ firstParam Name cmdArgsName, PatQ Item [PatQ] argsPattern] (Name -> Name -> [Name] -> Bool -> ExpQ dispatch Name handlerName Name cmdArgsName [Name] paramNames Bool hasCmdArgs) firstParam :: Name -> PatQ firstParam Name cmdArgsName = if Bool hasCmdArgs then Name -> PatQ varP Name cmdArgsName else PatQ wildP nameLit :: ExpQ nameLit = Lit -> ExpQ litE (String -> Lit StringL String rpcName) primCommand :: String -> Name -> [Name] -> HandlerParams -> Bool -> Bool -> ExpQ primCommand :: String -> Name -> [Name] -> HandlerParams -> Bool -> Bool -> ExpQ primCommand String rpcName Name handlerName [Name] paramNames HandlerParams handlerPar Bool isMaybe Bool isL = do Name argsName <- String -> Q Name newName String "args" String -> Name -> [Name] -> HandlerParams -> PatQ -> (Name -> Name -> [Name] -> Bool -> ExpQ) -> ExpQ command String rpcName Name handlerName [Name] paramNames HandlerParams handlerPar (Name -> PatQ varP Name argsName) (String -> Name -> Name -> Name -> [Name] -> Bool -> ExpQ dispatch String rpcName Name argsName) where dispatch :: String -> Name -> Name -> Name -> [Name] -> Bool -> ExpQ dispatch | Bool isMaybe = String -> Name -> Name -> Name -> [Name] -> Bool -> ExpQ primDispatchMaybe | Bool isL = String -> Name -> Name -> Name -> [Name] -> Bool -> ExpQ primDispatchList | Bool otherwise = String -> Name -> Name -> Name -> [Name] -> Bool -> ExpQ primDispatchStrict jsonCommand :: String -> Name -> [Name] -> HandlerParams -> Bool -> ExpQ jsonCommand :: String -> Name -> [Name] -> HandlerParams -> Bool -> ExpQ jsonCommand String rpcName Name handlerName [Name] paramNames HandlerParams handlerPar Bool _ = do Name restName <- String -> Q Name newName String "rest" String -> Name -> [Name] -> HandlerParams -> PatQ -> (Name -> Name -> [Name] -> Bool -> ExpQ) -> ExpQ command String rpcName Name handlerName [Name] paramNames HandlerParams handlerPar ([Name] -> Name -> PatQ jsonArgPattern [Name] paramNames Name restName) (Name -> Name -> Name -> [Name] -> Bool -> ExpQ jsonDispatch Name restName) commandImplementation :: String -> Name -> HandlerParams -> ExpQ commandImplementation :: String -> Name -> HandlerParams -> ExpQ commandImplementation String rpcName Name handlerName hps :: HandlerParams hps@(HandlerParams Bool _ CmdParams params) = CmdParams -> ExpQ forParams CmdParams params where forParams :: CmdParams -> ExpQ forParams CmdParams ZeroParams = String -> Name -> [Name] -> HandlerParams -> Bool -> Bool -> ExpQ primCommand String rpcName Name handlerName [] HandlerParams hps Bool False Bool False forParams (OnlyPrims Int paramCount) = do [Name] paramNames <- Int -> Q [Name] lambdaNames Int paramCount String -> Name -> [Name] -> HandlerParams -> Bool -> Bool -> ExpQ primCommand String rpcName Name handlerName [Name] paramNames HandlerParams hps Bool False Bool False forParams (DataPlus Int paramCount) = do [Name] paramNames <- Int -> Q [Name] lambdaNames Int paramCount String -> Name -> [Name] -> HandlerParams -> Bool -> ExpQ jsonCommand String rpcName Name handlerName [Name] paramNames HandlerParams hps Bool False forParams (OneParam Bool isMaybe CmdParamType DataParam) = String -> Name -> [Name] -> HandlerParams -> Bool -> ExpQ jsonCommand String rpcName Name handlerName [] HandlerParams hps Bool isMaybe forParams (OneParam Bool isMaybe CmdParamType PrimParam) = do [Name] paramNames <- Int -> Q [Name] lambdaNames Int 1 String -> Name -> [Name] -> HandlerParams -> Bool -> Bool -> ExpQ primCommand String rpcName Name handlerName [Name] paramNames HandlerParams hps Bool isMaybe Bool False forParams (OneParam Bool isMaybe CmdParamType ListParam) = do [Name] paramNames <- Int -> Q [Name] lambdaNames Int 1 String -> Name -> [Name] -> HandlerParams -> Bool -> Bool -> ExpQ primCommand String rpcName Name handlerName [Name] paramNames HandlerParams hps Bool isMaybe Bool True isRecord :: Info -> Bool isRecord :: Info -> Bool isRecord (TyConI (DataD Cxt _ Name _ [TyVarBndr] _ Maybe Kind _ [RecC _ _] [DerivClause] _)) = Bool True isRecord Info _ = Bool False isJsonDecodable :: Type -> Q Bool isJsonDecodable :: Kind -> Q Bool isJsonDecodable (ConT Name name) = Info -> Bool isRecord (Info -> Bool) -> Q Info -> Q Bool forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Name -> Q Info reify Name name isJsonDecodable Kind _ = Bool -> Q Bool forall (m :: * -> *) a. Monad m => a -> m a return Bool False isList :: Type -> Bool isList :: Kind -> Bool isList (AppT Kind ListT Kind _) = Bool True isList Kind _ = Bool False isMaybeType :: Name -> Q Bool isMaybeType :: Name -> Q Bool isMaybeType Name tpe = (Name -> Kind ConT Name tpe Kind -> Kind -> Bool forall a. Eq a => a -> a -> Bool ==) (Kind -> Bool) -> Q Kind -> Q Bool forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> [t|Maybe|] analyzeMaybeCmdParam :: Type -> Q (Bool, Type) analyzeMaybeCmdParam :: Kind -> Q (Bool, Kind) analyzeMaybeCmdParam (AppT (ConT Name tcon) Kind tpe) = (, Kind tpe) (Bool -> (Bool, Kind)) -> Q Bool -> Q (Bool, Kind) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Name -> Q Bool isMaybeType Name tcon analyzeMaybeCmdParam Kind a = (Bool, Kind) -> Q (Bool, Kind) forall (m :: * -> *) a. Monad m => a -> m a return (Bool False, Kind a) analyzeCmdParams :: [Type] -> Q CmdParams analyzeCmdParams :: Cxt -> Q CmdParams analyzeCmdParams = Cxt -> Q CmdParams check (Cxt -> Q CmdParams) -> (Cxt -> Cxt) -> Cxt -> Q CmdParams forall b c a. (b -> c) -> (a -> b) -> a -> c . Cxt -> Cxt forall a. [a] -> [a] reverse where check :: Cxt -> Q CmdParams check [Item Cxt a] = do (Bool isMaybe, Kind tpe) <- Kind -> Q (Bool, Kind) analyzeMaybeCmdParam Kind Item Cxt a Bool isD <- Kind -> Q Bool isJsonDecodable Kind tpe return $ Bool -> CmdParamType -> CmdParams OneParam Bool isMaybe (Bool -> Bool -> CmdParamType singleParam Bool isD (Kind -> Bool isList Kind tpe)) check (Kind a : Cxt rest) = do Bool isD <- Kind -> Q Bool isJsonDecodable Kind a return $ if Bool isD then Int -> CmdParams DataPlus (Cxt -> Int forall (t :: * -> *) a. Foldable t => t a -> Int length Cxt rest) else Int -> CmdParams OnlyPrims (Cxt -> Int forall (t :: * -> *) a. Foldable t => t a -> Int length Cxt rest Int -> Int -> Int forall a. Num a => a -> a -> a + Int 1) check [] = CmdParams -> Q CmdParams forall (m :: * -> *) a. Monad m => a -> m a return CmdParams ZeroParams singleParam :: Bool -> Bool -> CmdParamType singleParam Bool _ Bool True = CmdParamType ListParam singleParam Bool True Bool _ = CmdParamType DataParam singleParam Bool _ Bool _ = CmdParamType PrimParam cmdNargs :: CmdParams -> CommandOption cmdNargs :: CmdParams -> CommandOption cmdNargs CmdParams ZeroParams = String -> CommandOption CmdNargs String "0" cmdNargs (OnlyPrims Int 1) = String -> CommandOption CmdNargs String "1" cmdNargs (OneParam Bool False CmdParamType PrimParam) = String -> CommandOption CmdNargs String "1" cmdNargs (OneParam Bool True CmdParamType PrimParam) = String -> CommandOption CmdNargs String "?" cmdNargs (OneParam Bool _ CmdParamType ListParam) = String -> CommandOption CmdNargs String "*" cmdNargs CmdParams _ = String -> CommandOption CmdNargs String "+" amendSync :: Synchronous -> [CommandOption] -> [CommandOption] amendSync :: Synchronous -> [CommandOption] -> [CommandOption] amendSync Synchronous _ [CommandOption] options | (CommandOption -> Bool) -> [CommandOption] -> Bool forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool any CommandOption -> Bool isSync [CommandOption] options = [CommandOption] options where isSync :: CommandOption -> Bool isSync (CmdSync Synchronous _) = Bool True isSync CommandOption _ = Bool False amendSync Synchronous sync [CommandOption] options = Synchronous -> CommandOption CmdSync Synchronous sync CommandOption -> [CommandOption] -> [CommandOption] forall a. a -> [a] -> [a] : [CommandOption] options rpcCommand :: String -> Name -> HandlerParams -> Synchronous -> [CommandOption] -> ExpQ rpcCommand :: String -> Name -> HandlerParams -> Synchronous -> [CommandOption] -> ExpQ rpcCommand String rpcName Name funcName hps :: HandlerParams hps@(HandlerParams Bool _ CmdParams params) Synchronous sync [CommandOption] opts = do Exp fun <- String -> Name -> HandlerParams -> ExpQ commandImplementation String rpcName Name funcName HandlerParams hps [|RpcDef (RpcCommand $ mkCommandOptions (nargs : amendSync sync opts)) $((litE (StringL rpcName))) $(return fun)|] where nargs :: CommandOption nargs = CmdParams -> CommandOption cmdNargs CmdParams params removeArgsParam :: [Type] -> Q (Bool, [Type]) removeArgsParam :: Cxt -> Q (Bool, Cxt) removeArgsParam [] = (Bool, Cxt) -> Q (Bool, Cxt) forall (m :: * -> *) a. Monad m => a -> m a return (Bool False, []) removeArgsParam (Kind p1 : Cxt rest) = do Kind argsType <- [t|CommandArguments|] return $ if Kind p1 Kind -> Kind -> Bool forall a. Eq a => a -> a -> Bool == Kind argsType then (Bool True, Cxt rest) else (Bool False, Kind p1 Kind -> Cxt -> Cxt forall a. a -> [a] -> [a] : Cxt rest) handlerParams :: Name -> Q HandlerParams handlerParams :: Name -> Q HandlerParams handlerParams Name name = do Cxt types <- Name -> Q Cxt functionParamTypes Name name (Bool hasArgsParam, Cxt userTypes) <- Cxt -> Q (Bool, Cxt) removeArgsParam Cxt types CmdParams cp <- Cxt -> Q CmdParams analyzeCmdParams Cxt userTypes return $ Bool -> CmdParams -> HandlerParams HandlerParams Bool hasArgsParam CmdParams cp