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)