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 $ [])