module Ribosome.Nvim.Api.Generate where import Data.Char (toUpper) import qualified Data.Map.Strict as Map (fromList, lookup) import Data.MessagePack (Object) import Language.Haskell.TH import Neovim.API.Parser ( NeovimAPI(functions), NeovimFunction(NeovimFunction), NeovimType(NestedType, SimpleType, Void), customTypes, parseAPI, ) camelcase :: String -> String camelcase :: String -> String camelcase = (Bool, String) -> String forall a b. (a, b) -> b snd ((Bool, String) -> String) -> (String -> (Bool, String)) -> String -> String forall b c a. (b -> c) -> (a -> b) -> a -> c . (Char -> (Bool, String) -> (Bool, String)) -> (Bool, String) -> String -> (Bool, String) forall (t :: * -> *) a b. Foldable t => (a -> b -> b) -> b -> t a -> b foldr Char -> (Bool, String) -> (Bool, String) folder (Bool False, String "") where folder :: Char -> (Bool, String) -> (Bool, String) folder Char '_' (Bool _, String z) = (Bool True, String z) folder Char a (Bool True, Char h : String t) = (Bool False, Char a Char -> String -> String forall a. a -> [a] -> [a] : Char -> Char toUpper Char h Char -> String -> String forall a. a -> [a] -> [a] : String t) folder Char a (Bool True, []) = (Bool False, [Char Item String a]) folder Char a (Bool False, String z) = (Bool False, Char a Char -> String -> String forall a. a -> [a] -> [a] : String z) haskellTypes :: Map String TypeQ haskellTypes :: Map String TypeQ haskellTypes = [(String, TypeQ)] -> Map String TypeQ forall k a. Ord k => [(k, a)] -> Map k a Map.fromList [ (String "Boolean", [t|Bool|]), (String "Integer", [t|Int|]), (String "Float", [t|Double|]), (String "String", [t|Text|]), (String "Array", [t|[Object]|]), (String "Dictionary", [t|Map Text Object|]), (String "void", [t|()|]) ] haskellType :: NeovimType -> Q Type haskellType :: NeovimType -> TypeQ haskellType NeovimType at = case NeovimType at of NeovimType Void -> [t|()|] NestedType NeovimType t Maybe Int Nothing -> TypeQ -> TypeQ -> TypeQ appT TypeQ listT (TypeQ -> TypeQ) -> TypeQ -> TypeQ forall a b. (a -> b) -> a -> b $ NeovimType -> TypeQ haskellType NeovimType t NestedType NeovimType t (Just Int n) -> (TypeQ -> TypeQ -> TypeQ) -> TypeQ -> [TypeQ] -> TypeQ forall (t :: * -> *) b a. Foldable t => (b -> a -> b) -> b -> t a -> b foldl TypeQ -> TypeQ -> TypeQ appT (Int -> TypeQ tupleT Int n) ([TypeQ] -> TypeQ) -> (TypeQ -> [TypeQ]) -> TypeQ -> TypeQ forall b c a. (b -> c) -> (a -> b) -> a -> c . Int -> TypeQ -> [TypeQ] forall a. Int -> a -> [a] replicate Int n (TypeQ -> TypeQ) -> TypeQ -> TypeQ forall a b. (a -> b) -> a -> b $ NeovimType -> TypeQ haskellType NeovimType t SimpleType String t -> TypeQ -> Maybe TypeQ -> TypeQ forall a. a -> Maybe a -> a fromMaybe (Name -> TypeQ conT (Name -> TypeQ) -> (String -> Name) -> String -> TypeQ forall b c a. (b -> c) -> (a -> b) -> a -> c . String -> Name mkName (String -> TypeQ) -> String -> TypeQ forall a b. (a -> b) -> a -> b $ String t) (Maybe TypeQ -> TypeQ) -> Maybe TypeQ -> TypeQ forall a b. (a -> b) -> a -> b $ String -> Map String TypeQ -> Maybe TypeQ forall k a. Ord k => k -> Map k a -> Maybe a Map.lookup String t Map String TypeQ haskellTypes data FunctionData = FunctionData { FunctionData -> String apiName :: String, FunctionData -> Name ccName :: Name, FunctionData -> Bool async :: Bool, FunctionData -> [Name] names :: [Name], FunctionData -> [Type] types :: [Type], FunctionData -> NeovimType returnType :: NeovimType } deriving (FunctionData -> FunctionData -> Bool (FunctionData -> FunctionData -> Bool) -> (FunctionData -> FunctionData -> Bool) -> Eq FunctionData forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: FunctionData -> FunctionData -> Bool $c/= :: FunctionData -> FunctionData -> Bool == :: FunctionData -> FunctionData -> Bool $c== :: FunctionData -> FunctionData -> Bool Eq, Int -> FunctionData -> String -> String [FunctionData] -> String -> String FunctionData -> String (Int -> FunctionData -> String -> String) -> (FunctionData -> String) -> ([FunctionData] -> String -> String) -> Show FunctionData forall a. (Int -> a -> String -> String) -> (a -> String) -> ([a] -> String -> String) -> Show a showList :: [FunctionData] -> String -> String $cshowList :: [FunctionData] -> String -> String show :: FunctionData -> String $cshow :: FunctionData -> String showsPrec :: Int -> FunctionData -> String -> String $cshowsPrec :: Int -> FunctionData -> String -> String Show) functionData :: NeovimFunction -> Q FunctionData functionData :: NeovimFunction -> Q FunctionData functionData (NeovimFunction String name [(NeovimType, String)] parameters Bool _ Bool async NeovimType returnType) = do [Name] names <- (String -> Q Name) -> [String] -> Q [Name] forall (t :: * -> *) (f :: * -> *) a b. (Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b) traverse String -> Q Name newName [String] prefixedNames [Type] types <- (NeovimType -> TypeQ) -> [NeovimType] -> Q [Type] forall (t :: * -> *) (f :: * -> *) a b. (Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b) traverse NeovimType -> TypeQ haskellType ((NeovimType, String) -> NeovimType forall a b. (a, b) -> a fst ((NeovimType, String) -> NeovimType) -> [(NeovimType, String)] -> [NeovimType] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> [(NeovimType, String)] parameters) return (String -> Name -> Bool -> [Name] -> [Type] -> NeovimType -> FunctionData FunctionData String name (String -> Name mkName (String -> Name) -> (String -> String) -> String -> Name forall b c a. (b -> c) -> (a -> b) -> a -> c . String -> String camelcase (String -> Name) -> String -> Name forall a b. (a -> b) -> a -> b $ String name) Bool async [Name] names [Type] types NeovimType returnType) where prefix :: a -> a -> a prefix a i a n = a "arg" a -> a -> a forall a. Semigroup a => a -> a -> a <> a -> a forall b a. (Show a, IsString b) => a -> b show a i a -> a -> a forall a. Semigroup a => a -> a -> a <> a "_" a -> a -> a forall a. Semigroup a => a -> a -> a <> a n prefixedNames :: [String] prefixedNames = (Int -> String -> String) -> [Int] -> [String] -> [String] forall a b c. (a -> b -> c) -> [a] -> [b] -> [c] zipWith Int -> String -> String forall a a. (Semigroup a, IsString a, Show a) => a -> a -> a prefix [Int 0 :: Int ..] ((NeovimType, String) -> String forall a b. (a, b) -> b snd ((NeovimType, String) -> String) -> [(NeovimType, String)] -> [String] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> [(NeovimType, String)] parameters) generateFromApi :: (FunctionData -> Q [Dec]) -> (Name -> Int64 -> DecsQ) -> Q [Dec] generateFromApi :: (FunctionData -> Q [Dec]) -> (Name -> Int64 -> Q [Dec]) -> Q [Dec] generateFromApi FunctionData -> Q [Dec] handleFunction Name -> Int64 -> Q [Dec] handleExtType = do NeovimAPI api <- (Doc AnsiStyle -> Q NeovimAPI) -> (NeovimAPI -> Q NeovimAPI) -> Either (Doc AnsiStyle) NeovimAPI -> Q NeovimAPI forall a c b. (a -> c) -> (b -> c) -> Either a b -> c either (String -> Q NeovimAPI forall (m :: * -> *) a. MonadFail m => String -> m a fail (String -> Q NeovimAPI) -> (Doc AnsiStyle -> String) -> Doc AnsiStyle -> Q NeovimAPI forall b c a. (b -> c) -> (a -> b) -> a -> c . Doc AnsiStyle -> String forall b a. (Show a, IsString b) => a -> b show) NeovimAPI -> Q NeovimAPI forall (m :: * -> *) a. Monad m => a -> m a return (Either (Doc AnsiStyle) NeovimAPI -> Q NeovimAPI) -> Q (Either (Doc AnsiStyle) NeovimAPI) -> Q NeovimAPI forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< IO (Either (Doc AnsiStyle) NeovimAPI) -> Q (Either (Doc AnsiStyle) NeovimAPI) forall a. IO a -> Q a runIO IO (Either (Doc AnsiStyle) NeovimAPI) parseAPI [FunctionData] funcs <- (NeovimFunction -> Q FunctionData) -> [NeovimFunction] -> Q [FunctionData] forall (t :: * -> *) (f :: * -> *) a b. (Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b) traverse NeovimFunction -> Q FunctionData functionData (NeovimAPI -> [NeovimFunction] functions NeovimAPI api) [[Dec]] funcDecs <- (FunctionData -> Q [Dec]) -> [FunctionData] -> Q [[Dec]] forall (t :: * -> *) (f :: * -> *) a b. (Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b) traverse FunctionData -> Q [Dec] handleFunction [FunctionData] funcs [[Dec]] tpeDecs <- ((Name, Int64) -> Q [Dec]) -> [(Name, Int64)] -> Q [[Dec]] forall (t :: * -> *) (f :: * -> *) a b. (Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b) traverse ((Name -> Int64 -> Q [Dec]) -> (Name, Int64) -> Q [Dec] forall a b c. (a -> b -> c) -> (a, b) -> c uncurry Name -> Int64 -> Q [Dec] handleExtType) ([(Name, Int64)] -> Q [[Dec]]) -> [(Name, Int64)] -> Q [[Dec]] forall a b. (a -> b) -> a -> b $ (String -> Name) -> (String, Int64) -> (Name, Int64) forall (p :: * -> * -> *) a b c. Bifunctor p => (a -> b) -> p a c -> p b c first String -> Name mkName ((String, Int64) -> (Name, Int64)) -> [(String, Int64)] -> [(Name, Int64)] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> NeovimAPI -> [(String, Int64)] customTypes NeovimAPI api return $ [[Dec]] -> [Dec] forall (m :: * -> *) a. Monad m => m (m a) -> m a join ([[Dec]] funcDecs [[Dec]] -> [[Dec]] -> [[Dec]] forall a. Semigroup a => a -> a -> a <> [[Dec]] tpeDecs)