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