module Ribosome.Host.TH.Api.GenerateData where

import Data.MessagePack (Object (ObjectExt))
import Language.Haskell.TH (
  Bang (Bang),
  DecQ,
  DecsQ,
  DerivClause (DerivClause),
  DerivStrategy (StockStrategy),
  Name,
  Q,
  SourceStrictness (SourceStrict),
  SourceUnpackedness (NoSourceUnpackedness),
  Specificity (SpecifiedSpec),
  TyVarBndr (KindedTV),
  Type (AppT, ArrowT, ConT, ForallT, StarT, VarT),
  clause,
  conE,
  conP,
  conT,
  dataD,
  funD,
  integerL,
  listE,
  litP,
  mkName,
  normalB,
  normalC,
  sigD,
  varE,
  varP,
  )
import Prelude hiding (Type)

import Ribosome.Host.Class.Msgpack.Decode (MsgpackDecode (fromMsgpack))
import Ribosome.Host.Class.Msgpack.Encode (MsgpackEncode (toMsgpack))
import Ribosome.Host.Class.Msgpack.Error (decodeIncompatible)
import Ribosome.Host.Data.ApiInfo (ExtTypeMeta (ExtTypeMeta))
import Ribosome.Host.Data.ApiType (ApiType, pattern PolyType)
import Ribosome.Host.Data.Request (Request (Request), RpcMethod (RpcMethod))
import Ribosome.Host.Data.RpcCall (RpcCall (RpcCallRequest))
import Ribosome.Host.TH.Api.Generate (MethodSpec (MethodSpec), generateFromApi, reifyApiType)
import Ribosome.Host.TH.Api.GenerateEffect (analyzeReturnType, msgpackEncodeConstraint)
import Ribosome.Host.TH.Api.Param (Param (Param), paramName)

effectiveType :: ApiType -> Q Type
effectiveType :: ApiType -> Q Type
effectiveType = \case
  ApiType
PolyType ->
    Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> Type
VarT (String -> Name
mkName String
"a"))
  ApiType
a ->
    ApiType -> Q Type
reifyApiType ApiType
a

dataSig :: [Param] -> Name -> ApiType -> DecQ
dataSig :: [Param] -> Name -> ApiType -> Q Dec
dataSig [Param]
params Name
name ApiType
returnType = do
  (Maybe Name
retTv, Type
retType, Maybe Type
decodeConstraint) <- ApiType -> Q (Maybe Name, Type, Maybe Type)
analyzeReturnType ApiType
returnType
  [Maybe Type]
encodeConstraints <- (Param -> Q (Maybe Type)) -> [Param] -> Q [Maybe Type]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Param -> Q (Maybe Type)
msgpackEncodeConstraint [Param]
params
  Type
rc <- [t|RpcCall|]
  let
    paramType :: Param -> Type
paramType = \case
      Param Name
_ Type
_ (Just Name
n) ->
        Name -> Type
VarT Name
n
      Param Name
_ Type
t Maybe Name
Nothing ->
        Type
t
    paramsType :: Type
paramsType =
      (Param -> Type -> Type) -> Type -> [Param] -> Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Type -> Type -> Type
AppT (Type -> Type -> Type) -> (Param -> Type) -> Param -> Type -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type -> Type
AppT Type
ArrowT (Type -> Type) -> (Param -> Type) -> Param -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Param -> Type
paramType) (Type -> Type -> Type
AppT Type
rc Type
retType) [Param]
params
    constraints :: Cxt
constraints =
      Maybe Type -> Cxt
forall a. Maybe a -> [a]
maybeToList Maybe Type
decodeConstraint Cxt -> Cxt -> Cxt
forall a. Semigroup a => a -> a -> a
<> [Maybe Type] -> Cxt
forall a. [Maybe a] -> [a]
catMaybes [Maybe Type]
encodeConstraints
    paramTv :: Param -> Maybe Name
paramTv = \case
      Param Name
_ Type
_ (Just Name
n) ->
        Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
      Param Name
_ Type
_ Maybe Name
Nothing ->
        Maybe Name
forall a. Maybe a
Nothing
    paramTvs :: [Name]
paramTvs =
      (Param -> Maybe Name) -> [Param] -> [Name]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Param -> Maybe Name
paramTv [Param]
params
    tv :: Name -> TyVarBndr Specificity
tv Name
n =
      Name -> Specificity -> Type -> TyVarBndr Specificity
forall flag. Name -> flag -> Type -> TyVarBndr flag
KindedTV Name
n Specificity
SpecifiedSpec Type
StarT
  Name -> Q Type -> Q Dec
forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD Name
name (Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TyVarBndr Specificity] -> Cxt -> Type -> Type
ForallT ((Name -> TyVarBndr Specificity
tv (Name -> TyVarBndr Specificity)
-> [Name] -> [TyVarBndr Specificity]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
paramTvs) [TyVarBndr Specificity]
-> [TyVarBndr Specificity] -> [TyVarBndr Specificity]
forall a. Semigroup a => a -> a -> a
<> Maybe (TyVarBndr Specificity) -> [TyVarBndr Specificity]
forall a. Maybe a -> [a]
maybeToList (Name -> TyVarBndr Specificity
tv (Name -> TyVarBndr Specificity)
-> Maybe Name -> Maybe (TyVarBndr Specificity)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Name
retTv)) Cxt
constraints Type
paramsType))

dataBody :: String -> Name -> [Param] -> DecQ
dataBody :: String -> Name -> [Param] -> Q Dec
dataBody String
apiName Name
name [Param]
params =
  Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
name [[Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP (Name -> Q Pat) -> [Name] -> [Q Pat]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
names) (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
rpcCall) []]
  where
    rpcCall :: Q Exp
rpcCall =
      [|RpcCallRequest (Request (RpcMethod apiName) $(listE (toObjVar <$> names)))|]
    toObjVar :: Name -> m Exp
toObjVar Name
v =
      [|toMsgpack $(varE v)|]
    names :: [Name]
names =
      Param -> Name
paramName (Param -> Name) -> [Param] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Param]
params

genRequest :: MethodSpec -> DecsQ
genRequest :: MethodSpec -> DecsQ
genRequest (MethodSpec String
apiName Name
name [Param]
params ApiType
returnType) = do
  Dec
sig <- [Param] -> Name -> ApiType -> Q Dec
dataSig [Param]
params Name
name ApiType
returnType
  Dec
body <- String -> Name -> [Param] -> Q Dec
dataBody String
apiName Name
name [Param]
params
  pure [Dec
Item [Dec]
sig, Dec
Item [Dec]
body]

extData :: Name -> DecQ
extData :: Name -> Q Dec
extData Name
name =
  Q Cxt
-> Name
-> [TyVarBndr ()]
-> Maybe Type
-> [Q Con]
-> [Q DerivClause]
-> Q Dec
forall (m :: * -> *).
Quote m =>
m Cxt
-> Name
-> [TyVarBndr ()]
-> Maybe Type
-> [m Con]
-> [m DerivClause]
-> m Dec
dataD (Cxt -> Q Cxt
forall (f :: * -> *) a. Applicative f => a -> f a
pure []) Name
name [] Maybe Type
forall a. Maybe a
Nothing [Q Con
Item [Q Con]
con] ([String] -> [Q DerivClause]
forall {l} {f :: * -> *}.
(IsList l, Applicative f, Item l ~ f DerivClause) =>
[String] -> l
deriv [Item [String]
"Eq", Item [String]
"Show"])
  where
    con :: Q Con
con =
      Name -> [Q BangType] -> Q Con
forall (m :: * -> *). Quote m => Name -> [m BangType] -> m Con
normalC Name
name [(SourceUnpackedness -> SourceStrictness -> Bang
Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
SourceStrict,) (Type -> BangType) -> Q Type -> Q BangType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t|ByteString|]]
    deriv :: [String] -> l
deriv [String]
cls =
      [DerivClause -> f DerivClause
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe DerivStrategy -> Cxt -> DerivClause
DerivClause (DerivStrategy -> Maybe DerivStrategy
forall a. a -> Maybe a
Just DerivStrategy
StockStrategy) (Name -> Type
ConT (Name -> Type) -> (String -> Name) -> String -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName (String -> Type) -> [String] -> Cxt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
cls))]

decodeInstance :: Name -> Int64 -> DecsQ
decodeInstance :: Name -> Int64 -> DecsQ
decodeInstance Name
name Int64
number =
  [d|
  instance MsgpackDecode $(conT name) where
    fromMsgpack = \case
      ObjectExt $(litP (integerL (fromIntegral number))) bytes ->
        pure ($(conE name) bytes)
      o ->
        decodeIncompatible o
  |]

encodeInstance :: Name -> Int64 -> DecsQ
encodeInstance :: Name -> Int64 -> DecsQ
encodeInstance Name
name Int64
number =
  [d|
  instance MsgpackEncode $(conT name) where
    toMsgpack $(conP name [varP (mkName "bytes")]) =
      ObjectExt number bytes
  |]

extDataCodec :: Name -> Int64 -> DecsQ
extDataCodec :: Name -> Int64 -> DecsQ
extDataCodec Name
name Int64
number =
  [Dec] -> [Dec] -> [Dec]
forall a. Monoid a => a -> a -> a
mappend ([Dec] -> [Dec] -> [Dec]) -> DecsQ -> Q ([Dec] -> [Dec])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Int64 -> DecsQ
decodeInstance Name
name Int64
number Q ([Dec] -> [Dec]) -> DecsQ -> DecsQ
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Name -> Int64 -> DecsQ
encodeInstance Name
name Int64
number

genExtTypes :: Name -> ExtTypeMeta -> DecsQ
genExtTypes :: Name -> ExtTypeMeta -> DecsQ
genExtTypes Name
name (ExtTypeMeta Int64
number String
_) =
  (:) (Dec -> [Dec] -> [Dec]) -> Q Dec -> Q ([Dec] -> [Dec])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Q Dec
extData Name
name Q ([Dec] -> [Dec]) -> DecsQ -> DecsQ
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Name -> Int64 -> DecsQ
extDataCodec Name
name Int64
number

generateData :: DecsQ
generateData :: DecsQ
generateData =
  (MethodSpec -> DecsQ)
-> Maybe (Name -> ExtTypeMeta -> DecsQ) -> DecsQ
generateFromApi MethodSpec -> DecsQ
genRequest ((Name -> ExtTypeMeta -> DecsQ)
-> Maybe (Name -> ExtTypeMeta -> DecsQ)
forall a. a -> Maybe a
Just Name -> ExtTypeMeta -> DecsQ
genExtTypes)