module Ribosome.Host.TH.Api.GenerateEffect where

import qualified Data.Kind as Kind
import Exon (exon)
import Language.Haskell.TH (
  Dec,
  DecQ,
  Name,
  Q,
  Quote (newName),
  Specificity (SpecifiedSpec),
  TyVarBndr (KindedTV),
  Type (AppT, ArrowT, ForallT, StarT, VarT),
  appE,
  clause,
  funD,
  mkName,
  nameBase,
  normalB,
  sigD,
  varE,
  varP,
  varT,
  )
import Prelude hiding (Type)

import Ribosome.Host.Class.Msgpack.Decode (MsgpackDecode)
import Ribosome.Host.Class.Msgpack.Encode (MsgpackEncode (toMsgpack))
import Ribosome.Host.Data.ApiType (ApiType, pattern PolyType)
import qualified Ribosome.Host.Effect.Rpc as Rpc
import Ribosome.Host.Effect.Rpc (Rpc)
import Ribosome.Host.TH.Api.Generate (MethodSpec (MethodSpec), generateFromApi, reifyApiType)
import Ribosome.Host.TH.Api.Param (Param (Param, paramName))

msgpackDecodeConstraint :: ApiType -> Q (Maybe Type)
msgpackDecodeConstraint :: ApiType -> Q (Maybe Type)
msgpackDecodeConstraint = \case
  ApiType
PolyType ->
    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"))|]
  ApiType
_ ->
    Maybe Type -> Q (Maybe Type)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Type
forall a. Maybe a
Nothing

msgpackEncodeConstraint :: Param -> Q (Maybe Type)
msgpackEncodeConstraint :: Param -> Q (Maybe Type)
msgpackEncodeConstraint = \case
  Param Name
_ Type
_ (Just Name
p) ->
    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|MsgpackEncode $(varT p)|]
  Param Name
_ Type
_ Maybe Name
Nothing ->
    Maybe Type -> Q (Maybe Type)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Type
forall a. Maybe a
Nothing

effReturnType :: ApiType -> Q (Maybe Name, Type)
effReturnType :: ApiType -> Q (Maybe Name, Type)
effReturnType = \case
  ApiType
PolyType -> do
    let n :: Name
n = String -> Name
mkName String
"a"
    (Maybe Name, Type) -> Q (Maybe Name, Type)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n, Name -> Type
VarT (String -> Name
mkName String
"a"))
  ApiType
a -> do
    Type
t <- ApiType -> Q Type
reifyApiType ApiType
a
    pure (Maybe Name
forall a. Maybe a
Nothing, Type
t)

analyzeReturnType :: ApiType -> Q (Maybe Name, Type, Maybe Type)
analyzeReturnType :: ApiType -> Q (Maybe Name, Type, Maybe Type)
analyzeReturnType ApiType
tpe = do
  (Maybe Name
n, Type
rt) <- ApiType -> Q (Maybe Name, Type)
effReturnType ApiType
tpe
  Maybe Type
constraint <- ApiType -> Q (Maybe Type)
msgpackDecodeConstraint ApiType
tpe
  pure (Maybe Name
n, Type
rt, Maybe Type
constraint)

effSig :: Name -> [Param] -> ApiType -> DecQ
effSig :: Name -> [Param] -> ApiType -> Q Dec
effSig Name
name [Param]
params ApiType
returnType = do
  Name
stackName <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"r"
  Type
stack <- Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
stackName
  Type
rpcConstraint <- [t|Member Rpc $(pure stack)|]
  (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
semT <- [t|Sem|]
  Type
stackKind <- [t|[(Kind.Type -> Kind.Type) -> Kind.Type -> Kind.Type]|]
  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 -> Type -> Type
AppT Type
semT Type
stack) Type
retType) [Param]
params
    constraints :: [Type]
constraints =
      Type
rpcConstraint Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: Maybe Type -> [Type]
forall a. Maybe a -> [a]
maybeToList Maybe Type
decodeConstraint [Type] -> [Type] -> [Type]
forall a. Semigroup a => a -> a -> a
<> [Maybe Type] -> [Type]
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
    stackTv :: TyVarBndr Specificity
stackTv =
      Name -> Specificity -> Type -> TyVarBndr Specificity
forall flag. Name -> flag -> Type -> TyVarBndr flag
KindedTV Name
stackName Specificity
SpecifiedSpec Type
stackKind
  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] -> [Type] -> 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) [TyVarBndr Specificity]
-> [TyVarBndr Specificity] -> [TyVarBndr Specificity]
forall a. Semigroup a => a -> a -> a
<> [Item [TyVarBndr Specificity]
TyVarBndr Specificity
stackTv]) [Type]
constraints Type
paramsType))

effBody :: Name -> [Param] -> DecQ
effBody :: Name -> [Param] -> Q Dec
effBody 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
effectCons) []]
  where
    effectCons :: Q Exp
effectCons =
      Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE [|Rpc.sync|] Q Exp
args
    args :: Q Exp
args =
      (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> [Q Exp] -> Q Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (String -> Name
mkName [exon|RpcData.#{nameBase name}|])) (Param -> Q Exp
paramE (Param -> Q Exp) -> [Param] -> [Q Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Param]
params)
    names :: [Name]
names =
      Param -> Name
paramName (Param -> Name) -> [Param] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Param]
params
    paramE :: Param -> Q Exp
paramE = \case
      Param Name
n Type
_ Maybe Name
p ->
        (Q Exp -> Q Exp) -> Maybe (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a. a -> Maybe a -> a
fromMaybe Q Exp -> Q Exp
forall a. a -> a
id (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE [e|toMsgpack|] (Q Exp -> Q Exp) -> Maybe Name -> Maybe (Q Exp -> Q Exp)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Maybe Name
p) (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
n)

genMethod :: MethodSpec -> Q [Dec]
genMethod :: MethodSpec -> Q [Dec]
genMethod (MethodSpec String
_ Name
name [Param]
params ApiType
returnType) = do
  Dec
sig <- Name -> [Param] -> ApiType -> Q Dec
effSig Name
name [Param]
params ApiType
returnType
  Dec
body <- Name -> [Param] -> Q Dec
effBody Name
name [Param]
params
  pure [Dec
Item [Dec]
sig, Dec
Item [Dec]
body]

generateEffect :: Q [Dec]
generateEffect :: Q [Dec]
generateEffect =
  (MethodSpec -> Q [Dec])
-> Maybe (Name -> ExtTypeMeta -> Q [Dec]) -> Q [Dec]
generateFromApi MethodSpec -> Q [Dec]
genMethod Maybe (Name -> ExtTypeMeta -> Q [Dec])
forall a. Maybe a
Nothing