module Ribosome.Nvim.Api.GenerateIO where

import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import Neovim.API.Parser (NeovimType(SimpleType))

import Ribosome.Control.Monad.Ribo (Nvim(call))
import Ribosome.Msgpack.Decode (MsgpackDecode)
import Ribosome.Nvim.Api.Generate (FunctionData(FunctionData), generateFromApi, haskellType)
import Ribosome.Nvim.Api.RpcCall (RpcError)

rpcModule :: Module
rpcModule :: Module
rpcModule =
  PkgName -> ModName -> Module
Module (String -> PkgName
mkPkgName String
"Ribosome.Nvim.Api") (String -> ModName
mkModName String
"Data")

msgpackDecodeConstraint :: NeovimType -> Q (Maybe Type)
msgpackDecodeConstraint :: NeovimType -> Q (Maybe Type)
msgpackDecodeConstraint (SimpleType String
"Object") =
  Type -> Maybe Type
forall a. a -> Maybe a
Just (Type -> Maybe Type) -> Q Type -> Q (Maybe Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t|MsgpackDecode $(varT $ mkName "a")|]
msgpackDecodeConstraint NeovimType
_ =
  Maybe Type -> Q (Maybe Type)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Type
forall a. Maybe a
Nothing

newT :: String -> TypeQ
newT :: String -> Q Type
newT =
  Name -> Q Type
varT (Name -> Q Type) -> (String -> Q Name) -> String -> Q Type
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< String -> Q Name
newName

ioReturnType :: NeovimType -> Q Type
ioReturnType :: NeovimType -> Q Type
ioReturnType (SimpleType String
"Object") =
  Type -> Q Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Type
VarT (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"a")
ioReturnType NeovimType
a =
  NeovimType -> Q Type
haskellType NeovimType
a

analyzeReturnType :: NeovimType -> Q (Type, Maybe Type)
analyzeReturnType :: NeovimType -> Q (Type, Maybe Type)
analyzeReturnType NeovimType
tpe = do
  Type
rt <- NeovimType -> Q Type
ioReturnType NeovimType
tpe
  Maybe Type
constraint <- NeovimType -> Q (Maybe Type)
msgpackDecodeConstraint NeovimType
tpe
  return (Type
rt, Maybe Type
constraint)

ioSig :: Name -> [Type] -> NeovimType -> DecQ
ioSig :: Name -> [Type] -> NeovimType -> DecQ
ioSig Name
name [Type]
types NeovimType
returnType = do
  Type
mType <- String -> Q Type
newT String
"m"
  Type
nvimConstraint <- [t|Nvim $(pure mType)|]
  (Type
retType, Maybe Type
decodeConstraint) <- NeovimType -> Q (Type, Maybe Type)
analyzeReturnType NeovimType
returnType
  Type
monadErrorConstraint <- [t|MonadDeepError $(newT "e") RpcError $(pure mType)|]
  let
    params :: Type
params = (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 -> Type -> Type
AppT Type
mType Type
retType) [Type]
types
    constraints :: [Type]
constraints = [Type
Item [Type]
nvimConstraint, Type
Item [Type]
monadErrorConstraint] [Type] -> [Type] -> [Type]
forall a. Semigroup a => a -> a -> a
<> Maybe Type -> [Type]
forall a. Maybe a -> [a]
maybeToList Maybe Type
decodeConstraint
  Name -> Q Type -> DecQ
sigD Name
name (Q Type -> DecQ) -> Q Type -> DecQ
forall a b. (a -> b) -> a -> b
$ Type -> Q Type
forall (m :: * -> *) a. Monad m => a -> m a
return ([TyVarBndr] -> [Type] -> Type -> Type
ForallT [] [Type]
constraints Type
params)

ioBody :: Name -> Bool -> [Name] -> DecQ
ioBody :: Name -> Bool -> [Name] -> DecQ
ioBody Name
name Bool
_ [Name]
names =
  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]
names) (ExpQ -> BodyQ
normalB ExpQ
body) []]
  where
    responseName :: Name
responseName = String -> Name
mkName String
"response"
    callPat :: PatQ
callPat = Name -> PatQ
varP Name
responseName
    callExp :: ExpQ
callExp = ExpQ -> ExpQ -> ExpQ
appE [|call|] ExpQ
args
    checkExp :: ExpQ
checkExp = ExpQ -> ExpQ -> ExpQ
appE [|hoistEither|] (Name -> ExpQ
varE Name
responseName)
    args :: ExpQ
args = (ExpQ -> ExpQ -> ExpQ) -> ExpQ -> [ExpQ] -> ExpQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE (Name -> ExpQ) -> Name -> ExpQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"RpcData." String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Name -> String
forall b a. (Show a, IsString b) => a -> b
show Name
name) (Name -> ExpQ
varE (Name -> ExpQ) -> [Name] -> [ExpQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
names)
    body :: ExpQ
body = [StmtQ] -> ExpQ
doE [PatQ -> ExpQ -> StmtQ
bindS PatQ
callPat ExpQ
callExp, ExpQ -> StmtQ
noBindS ExpQ
checkExp]

genIO :: FunctionData -> Q [Dec]
genIO :: FunctionData -> Q [Dec]
genIO (FunctionData String
_ Name
name Bool
async [Name]
names [Type]
types NeovimType
returnType) = do
  Dec
sig <- Name -> [Type] -> NeovimType -> DecQ
ioSig Name
name [Type]
types NeovimType
returnType
  Dec
body <- Name -> Bool -> [Name] -> DecQ
ioBody Name
name Bool
async [Name]
names
  return [Dec
Item [Dec]
sig, Dec
Item [Dec]
body]

generateIO :: Q [Dec]
generateIO :: Q [Dec]
generateIO =
  (FunctionData -> Q [Dec]) -> (Name -> Int64 -> Q [Dec]) -> Q [Dec]
generateFromApi FunctionData -> Q [Dec]
genIO ((Int64 -> Q [Dec]) -> Name -> Int64 -> Q [Dec]
forall a b. a -> b -> a
const ((Int64 -> Q [Dec]) -> Name -> Int64 -> Q [Dec])
-> ([Dec] -> Int64 -> Q [Dec]) -> [Dec] -> Name -> Int64 -> Q [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Q [Dec] -> Int64 -> Q [Dec]
forall a b. a -> b -> a
const (Q [Dec] -> Int64 -> Q [Dec])
-> ([Dec] -> Q [Dec]) -> [Dec] -> Int64 -> Q [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> Name -> Int64 -> Q [Dec])
-> [Dec] -> Name -> Int64 -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [])