module Ribosome.Host.TH.Api.Generate where

import Data.Char (toUpper)
import qualified Data.Map.Strict as Map
import Data.MessagePack (Object)
import Exon (exon)
import Language.Haskell.TH (Dec, DecsQ, Name, Q, Type, appT, conT, listT, mkName, newName, runIO, tupleT)
import Prelude hiding (Type)

import qualified Ribosome.Host.Data.ApiInfo as ApiInfo
import Ribosome.Host.Data.ApiInfo (ApiInfo (ApiInfo), ExtType, ExtTypeMeta, RpcDecl (RpcDecl), apiInfo, unExtType)
import Ribosome.Host.Data.ApiType (ApiPrim (..), ApiType (..))
import Ribosome.Host.Data.LuaRef (LuaRef)
import Ribosome.Host.TH.Api.Param (Param (Param))

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)

reifyApiPrim :: ApiPrim -> Q Type
reifyApiPrim :: ApiPrim -> Q Type
reifyApiPrim = \case
  ApiPrim
Boolean -> [t|Bool|]
  ApiPrim
Integer -> [t|Int|]
  ApiPrim
Float -> [t|Double|]
  ApiPrim
String -> [t|Text|]
  ApiPrim
Dictionary -> [t|Map Text Object|]
  ApiPrim
Object -> [t|Object|]
  ApiPrim
Void -> [t|()|]
  ApiPrim
LuaRef -> [t|LuaRef|]

reifyApiType :: ApiType -> Q Type
reifyApiType :: ApiType -> Q Type
reifyApiType = \case
  Prim ApiPrim
t ->
    ApiPrim -> Q Type
reifyApiPrim ApiPrim
t
  Array ApiType
t (Just Int
count) ->
    (Q Type -> Q Type -> Q Type) -> Q Type -> [Q Type] -> Q Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Int -> Q Type
forall (m :: * -> *). Quote m => Int -> m Type
tupleT Int
count) (Int -> Q Type -> [Q Type]
forall a. Int -> a -> [a]
replicate Int
count (ApiType -> Q Type
reifyApiType ApiType
t))
  Array ApiType
t Maybe Int
Nothing ->
    Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT Q Type
forall (m :: * -> *). Quote m => m Type
listT (ApiType -> Q Type
reifyApiType ApiType
t)
  Ext String
t ->
    Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT (String -> Name
mkName String
t)

polyName :: Int -> ApiType -> Q (Maybe Name)
polyName :: Int -> ApiType -> Q (Maybe Name)
polyName Int
i = \case
  Prim ApiPrim
Object ->
    Name -> Maybe Name
forall a. a -> Maybe a
Just (Name -> Maybe Name) -> Q Name -> Q (Maybe Name)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName [exon|p_#{show i}|]
  ApiType
_ ->
    Maybe Name -> Q (Maybe Name)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Name
forall a. Maybe a
Nothing

reifyParam :: Int -> (ApiType, String) -> Q Param
reifyParam :: Int -> (ApiType, String) -> Q Param
reifyParam Int
i (ApiType
t, String
n) = do
  Name
name <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
prefixed
  Type
mono <- ApiType -> Q Type
reifyApiType ApiType
t
  Maybe Name
paramType <- Int -> ApiType -> Q (Maybe Name)
polyName Int
i ApiType
t
  pure (Name -> Type -> Maybe Name -> Param
Param Name
name Type
mono Maybe Name
paramType)
  where
    prefixed :: String
prefixed =
      [exon|arg#{show i}_#{n}|]

data MethodSpec =
  MethodSpec {
    MethodSpec -> String
apiName :: String,
    MethodSpec -> Name
camelcaseName :: Name,
    MethodSpec -> [Param]
params :: [Param],
    MethodSpec -> ApiType
returnType :: ApiType
  }
  deriving stock (MethodSpec -> MethodSpec -> Bool
(MethodSpec -> MethodSpec -> Bool)
-> (MethodSpec -> MethodSpec -> Bool) -> Eq MethodSpec
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MethodSpec -> MethodSpec -> Bool
$c/= :: MethodSpec -> MethodSpec -> Bool
== :: MethodSpec -> MethodSpec -> Bool
$c== :: MethodSpec -> MethodSpec -> Bool
Eq, Int -> MethodSpec -> String -> String
[MethodSpec] -> String -> String
MethodSpec -> String
(Int -> MethodSpec -> String -> String)
-> (MethodSpec -> String)
-> ([MethodSpec] -> String -> String)
-> Show MethodSpec
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [MethodSpec] -> String -> String
$cshowList :: [MethodSpec] -> String -> String
show :: MethodSpec -> String
$cshow :: MethodSpec -> String
showsPrec :: Int -> MethodSpec -> String -> String
$cshowsPrec :: Int -> MethodSpec -> String -> String
Show)

functionData :: RpcDecl -> Q MethodSpec
functionData :: RpcDecl -> Q MethodSpec
functionData (RpcDecl String
name [(ApiType, String)]
parameters Maybe Int64
_ Maybe Int64
_ Bool
_ ApiType
returnType) = do
  [Param]
params <- (Int -> (ApiType, String) -> Q Param)
-> [Int] -> [(ApiType, String)] -> Q [Param]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Int -> (ApiType, String) -> Q Param
reifyParam [Item [Int]
0..] [(ApiType, String)]
parameters
  pure (String -> Name -> [Param] -> ApiType -> MethodSpec
MethodSpec String
name (String -> Name
mkName (String -> String
camelcase String
name)) [Param]
params ApiType
returnType)

genExtTypes :: Map ExtType ExtTypeMeta -> (Name -> ExtTypeMeta -> DecsQ) -> Q [[Dec]]
genExtTypes :: Map ExtType ExtTypeMeta
-> (Name -> ExtTypeMeta -> DecsQ) -> Q [[Dec]]
genExtTypes Map ExtType ExtTypeMeta
types Name -> ExtTypeMeta -> DecsQ
gen =
  ((Name, ExtTypeMeta) -> DecsQ)
-> [(Name, ExtTypeMeta)] -> Q [[Dec]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Name -> ExtTypeMeta -> DecsQ) -> (Name, ExtTypeMeta) -> DecsQ
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Name -> ExtTypeMeta -> DecsQ
gen) ((ExtType -> Name) -> (ExtType, ExtTypeMeta) -> (Name, ExtTypeMeta)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (String -> Name
mkName (String -> Name) -> (ExtType -> String) -> ExtType -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExtType -> String
unExtType) ((ExtType, ExtTypeMeta) -> (Name, ExtTypeMeta))
-> [(ExtType, ExtTypeMeta)] -> [(Name, ExtTypeMeta)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map ExtType ExtTypeMeta -> [(ExtType, ExtTypeMeta)]
forall k a. Map k a -> [(k, a)]
Map.toList Map ExtType ExtTypeMeta
types)

generateFromApi :: (MethodSpec -> Q [Dec]) -> Maybe (Name -> ExtTypeMeta -> DecsQ) -> Q [Dec]
generateFromApi :: (MethodSpec -> DecsQ)
-> Maybe (Name -> ExtTypeMeta -> DecsQ) -> DecsQ
generateFromApi MethodSpec -> DecsQ
handleFunction Maybe (Name -> ExtTypeMeta -> DecsQ)
handleExtType = do
  ApiInfo {[RpcDecl]
$sel:functions:ApiInfo :: ApiInfo -> [RpcDecl]
functions :: [RpcDecl]
functions, Map ExtType ExtTypeMeta
$sel:types:ApiInfo :: ApiInfo -> Map ExtType ExtTypeMeta
types :: Map ExtType ExtTypeMeta
types} <- (DecodeError -> Q ApiInfo)
-> (ApiInfo -> Q ApiInfo)
-> Either DecodeError ApiInfo
-> Q ApiInfo
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Q ApiInfo
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q ApiInfo)
-> (DecodeError -> String) -> DecodeError -> Q ApiInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DecodeError -> String
forall b a. (Show a, IsString b) => a -> b
show) ApiInfo -> Q ApiInfo
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either DecodeError ApiInfo -> Q ApiInfo)
-> Q (Either DecodeError ApiInfo) -> Q ApiInfo
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Either DecodeError ApiInfo) -> Q (Either DecodeError ApiInfo)
forall a. IO a -> Q a
runIO IO (Either DecodeError ApiInfo)
apiInfo
  [MethodSpec]
funcs <- (RpcDecl -> Q MethodSpec) -> [RpcDecl] -> Q [MethodSpec]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse RpcDecl -> Q MethodSpec
functionData [RpcDecl]
functions
  [[Dec]]
funcDecs <- (MethodSpec -> DecsQ) -> [MethodSpec] -> Q [[Dec]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse MethodSpec -> DecsQ
handleFunction [MethodSpec]
funcs
  Maybe [[Dec]]
tpeDecs <- ((Name -> ExtTypeMeta -> DecsQ) -> Q [[Dec]])
-> Maybe (Name -> ExtTypeMeta -> DecsQ) -> Q (Maybe [[Dec]])
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Map ExtType ExtTypeMeta
-> (Name -> ExtTypeMeta -> DecsQ) -> Q [[Dec]]
genExtTypes Map ExtType ExtTypeMeta
types) Maybe (Name -> ExtTypeMeta -> DecsQ)
handleExtType
  pure ([[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
<> Maybe [[Dec]] -> [[Dec]]
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold Maybe [[Dec]]
tpeDecs))