module Ribosome.Nvim.Api.GenerateData where

import Data.MessagePack (Object(ObjectExt))
import Language.Haskell.TH
import Neovim.Plugin.Classes (FunctionName(F))

import Ribosome.Msgpack.Decode (MsgpackDecode)
import Ribosome.Msgpack.Encode (MsgpackEncode)
import Ribosome.Msgpack.Util (illegalType)
import Ribosome.Nvim.Api.Generate (FunctionData(FunctionData), generateFromApi)
import Ribosome.Nvim.Api.RpcCall (AsyncRpcCall(..), RpcCall(..), SyncRpcCall(..))

dataSig :: [Type] -> Name -> Bool -> DecQ
dataSig :: [Type] -> Name -> Bool -> DecQ
dataSig [Type]
types Name
name Bool
async = do
  Type
returnType <- if Bool
async then [t|AsyncRpcCall|] else [t|SyncRpcCall|]
  Name -> TypeQ -> DecQ
sigD Name
name (TypeQ -> DecQ) -> ([Type] -> TypeQ) -> [Type] -> DecQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> TypeQ) -> ([Type] -> Type) -> [Type] -> TypeQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Type -> Type -> Type
AppT (Type -> Type -> Type) -> (Type -> Type) -> Type -> Type -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type -> Type
AppT Type
ArrowT) Type
returnType ([Type] -> DecQ) -> [Type] -> DecQ
forall a b. (a -> b) -> a -> b
$ [Type]
types

dataBody :: String -> Name -> Bool -> [Name] -> DecQ
dataBody :: String -> Name -> Bool -> [Name] -> DecQ
dataBody String
apiName Name
name Bool
async [Name]
params =
  Name -> [ClauseQ] -> DecQ
funD Name
name [[PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause (Name -> PatQ
varP (Name -> PatQ) -> [Name] -> [PatQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
params) (ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ ExpQ -> ExpQ -> ExpQ
appE ExpQ
syncCtor ExpQ
rpcCall) []]
  where
    rpcCall :: ExpQ
rpcCall = [|RpcCall|] ExpQ -> ExpQ -> ExpQ
`appE` ExpQ
funcName ExpQ -> ExpQ -> ExpQ
`appE` [ExpQ] -> ExpQ
listE (Name -> ExpQ
toObjVar (Name -> ExpQ) -> [Name] -> [ExpQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
params)
    funcName :: ExpQ
funcName = [|F . fromString|] ExpQ -> ExpQ -> ExpQ
`appE` (Lit -> ExpQ
litE (Lit -> ExpQ) -> (String -> Lit) -> String -> ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Lit
stringL (String -> ExpQ) -> String -> ExpQ
forall a b. (a -> b) -> a -> b
$ String
apiName)
    toObjVar :: Name -> ExpQ
toObjVar Name
v = [|toMsgpack $(varE v)|]
    syncCtor :: ExpQ
syncCtor = if Bool
async then [|AsyncRpcCall|] else [|SyncRpcCall|]

genCallData :: FunctionData -> DecsQ
genCallData :: FunctionData -> DecsQ
genCallData (FunctionData String
apiName Name
name Bool
async [Name]
names [Type]
types NeovimType
_) = do
  Dec
sig <- [Type] -> Name -> Bool -> DecQ
dataSig [Type]
types Name
name Bool
async
  Dec
body <- String -> Name -> Bool -> [Name] -> DecQ
dataBody String
apiName Name
name Bool
async [Name]
names
  return [Dec
Item [Dec]
sig, Dec
Item [Dec]
body]

extData :: Name -> DecQ
extData :: Name -> DecQ
extData Name
name =
  CxtQ
-> Name
-> [TyVarBndr]
-> Maybe Type
-> [ConQ]
-> [DerivClauseQ]
-> DecQ
dataD ([Type] -> CxtQ
forall (m :: * -> *) a. Monad m => a -> m a
return []) Name
name [] Maybe Type
forall a. Maybe a
Nothing [ConQ
Item [ConQ]
ctor] ([String] -> [DerivClauseQ]
deriv [Item [String]
"Eq", Item [String]
"Show"])
  where
    ctor :: ConQ
ctor = Name -> [BangTypeQ] -> ConQ
normalC Name
name [(SourceUnpackedness -> SourceStrictness -> Bang
Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
SourceStrict,) (Type -> (Bang, Type)) -> TypeQ -> BangTypeQ
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t|ByteString|]]
    deriv :: [String] -> [DerivClauseQ]
deriv = DerivClauseQ -> [DerivClauseQ]
forall (m :: * -> *) a. Monad m => a -> m a
return (DerivClauseQ -> [DerivClauseQ])
-> ([String] -> DerivClauseQ) -> [String] -> [DerivClauseQ]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DerivClause -> DerivClauseQ
forall (m :: * -> *) a. Monad m => a -> m a
return (DerivClause -> DerivClauseQ)
-> ([String] -> DerivClause) -> [String] -> DerivClauseQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe DerivStrategy -> [Type] -> DerivClause
DerivClause Maybe DerivStrategy
forall a. Maybe a
Nothing ([Type] -> DerivClause)
-> ([String] -> [Type]) -> [String] -> DerivClause
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> Type
ConT (Name -> Type) -> (String -> Name) -> String -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName (String -> Type) -> [String] -> [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)

decClause :: Name -> Int64 -> ClauseQ
decClause :: Name -> Int64 -> ClauseQ
decClause Name
name Int64
number = do
  Name
bytesVar <- String -> Q Name
newName String
"bytes"
  [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause [Name -> PatQ
pat Name
bytesVar] (Name -> BodyQ
decBody Name
bytesVar) []
  where
    pat :: Name -> PatQ
pat Name
bytesVar = Name -> [PatQ] -> PatQ
conP (String -> Name
mkName String
"ObjectExt") [(Lit -> PatQ
litP (Lit -> PatQ) -> (Int64 -> Lit) -> Int64 -> PatQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Lit
integerL (Integer -> Lit) -> (Int64 -> Integer) -> Int64 -> Lit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral) Int64
number, Name -> PatQ
varP Name
bytesVar]
    decBody :: Name -> BodyQ
decBody Name
bytesVar = (ExpQ -> BodyQ
normalB [|return $ $(conE name) $(varE bytesVar)|])

decErrorClause :: Name -> ClauseQ
decErrorClause :: Name -> ClauseQ
decErrorClause Name
name = do
  Name
objectVar <- String -> Q Name
newName String
"object"
  [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause [Name -> PatQ
varP Name
objectVar] (Name -> BodyQ
decBody Name
objectVar) []
  where
    nameString :: String
nameString = Name -> String
nameBase Name
name
    decBody :: Name -> BodyQ
decBody Name
objectVar = ExpQ -> BodyQ
normalB [|illegalType nameString $(varE objectVar)|]

encClause :: Name -> Int64 -> ClauseQ
encClause :: Name -> Int64 -> ClauseQ
encClause Name
name Int64
number = do
  Name
bytesVar <- String -> Q Name
newName String
"bytes"
  [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause [Name -> [PatQ] -> PatQ
conP Name
name [Name -> PatQ
varP Name
bytesVar]] (Name -> BodyQ
encBody Name
bytesVar) []
  where
    encBody :: Name -> BodyQ
encBody Name
bytesVar = ExpQ -> BodyQ
normalB [|ObjectExt $((litE . integerL . fromIntegral) number) $(varE bytesVar)|]

extDataCodec :: Name -> Int64 -> DecsQ
extDataCodec :: Name -> Int64 -> DecsQ
extDataCodec Name
name Int64
number = do
  Dec
dec <- TypeQ -> [DecQ] -> DecQ
inst [t|MsgpackDecode|] [String -> [ClauseQ] -> DecQ
method String
"fromMsgpack" [Name -> Int64 -> ClauseQ
decClause Name
name Int64
number, Name -> ClauseQ
decErrorClause Name
name]]
  Dec
enc <- TypeQ -> [DecQ] -> DecQ
inst [t|MsgpackEncode|] [String -> [ClauseQ] -> DecQ
method String
"toMsgpack" [Name -> Int64 -> ClauseQ
encClause Name
name Int64
number]]
  return [Dec
Item [Dec]
dec, Dec
Item [Dec]
enc]
  where
    inst :: TypeQ -> [DecQ] -> DecQ
inst TypeQ
t = CxtQ -> TypeQ -> [DecQ] -> DecQ
instanceD ([Type] -> CxtQ
forall (m :: * -> *) a. Monad m => a -> m a
return []) (TypeQ -> TypeQ
tpe TypeQ
t)
    tpe :: TypeQ -> TypeQ
tpe = (TypeQ -> TypeQ -> TypeQ
`appT` Name -> TypeQ
conT Name
name)
    method :: String -> [ClauseQ] -> DecQ
method String
methodName [ClauseQ]
clauses = Name -> [ClauseQ] -> DecQ
funD (String -> Name
mkName String
methodName) [ClauseQ]
clauses

genExtTypes :: Name -> Int64 -> DecsQ
genExtTypes :: Name -> Int64 -> DecsQ
genExtTypes Name
name Int64
number = do
  Dec
dat <- Name -> DecQ
extData Name
name
  [Dec]
codec <- Name -> Int64 -> DecsQ
extDataCodec Name
name Int64
number
  return (Dec
dat Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: [Dec]
codec)

generateData :: DecsQ
generateData :: DecsQ
generateData =
  (FunctionData -> DecsQ) -> (Name -> Int64 -> DecsQ) -> DecsQ
generateFromApi FunctionData -> DecsQ
genCallData Name -> Int64 -> DecsQ
genExtTypes