From 68ae671af040c5bcd443309a17188118557ef38f Mon Sep 17 00:00:00 2001
From: Jens Nolte <git@queezle.net>
Date: Wed, 11 Aug 2021 16:23:57 +0200
Subject: [PATCH] Add signature to handler
---
src/Quasar/Network/TH.hs | 39 ++++++++++++++++++++++++++-------------
1 file changed, 26 insertions(+), 13 deletions(-)
diff --git a/src/Quasar/Network/TH.hs b/src/Quasar/Network/TH.hs
index 5ef8d5e..a57db0f 100644
--- a/src/Quasar/Network/TH.hs
+++ b/src/Quasar/Network/TH.hs
@@ -25,6 +25,7 @@ import GHC.Records.Compat (HasField)
import Language.Haskell.TH hiding (interruptible)
import Language.Haskell.TH.Syntax
import Quasar.Awaitable
+import Quasar.Core
import Quasar.Network.Multiplexer
import Quasar.Network.Runtime
import Quasar.Network.Runtime.Observable
@@ -160,7 +161,7 @@ clientRequestStub api req = do
stubName = clientRequestStubName api req
makeStubSig :: Q [Type] -> Q Type
makeStubSig arguments =
- [t|forall m. MonadIO m => $(buildFunctionType arguments [t|m $(buildTupleType (liftA2 (<>) optionalResultType (resourceTypes req)))|])|]
+ [t|forall m. MonadIO m => $(buildFunctionType arguments [t|m $(buildTupleType (liftA2 (<>) optionalResultType (stubResourceTypes req)))|])|]
optionalResultType :: Q [Type]
optionalResultType = case req.mResponse of
Nothing -> pure []
@@ -282,12 +283,22 @@ makeServer api@RpcApi{functions} code = sequence [protocolImplDec, logicInstance
clause
[requestConP, listP (varP <$> channelNames)]
(normalB (packResponse req.mResponse (applyResources resourceEs (varE handlerName))))
- [handlerDec handlerName resourceNames ctx]
+ [
+ handlerSig handlerName,
+ handlerDec handlerName resourceNames ctx
+ ]
+ handlerSig :: Name -> Q Dec
+ handlerSig handlerName = sigD handlerName (buildFunctionType (implResourceTypes req) [t|IO $(resultType)|])
handlerDec :: Name -> [Name] -> RequestHandlerContext -> Q Dec
handlerDec handlerName resourceNames ctx = funD handlerName [clause (varP <$> resourceNames) (normalB (req.handlerE ctx)) []]
applyResources :: [Q Exp] -> Q Exp -> Q Exp
applyResources resourceEs implE = applyM implE resourceEs
+ resultType :: Q Type
+ resultType =
+ case req.mResponse of
+ Nothing -> [t|()|]
+ Just resp -> [t|$(buildTupleType (sequence ((.ty) <$> resp.fields)))|]
invalidChannelCountClause :: Q Clause
invalidChannelCountClause = do
@@ -522,26 +533,28 @@ clientRequestStubSig api req = makeStubSig (sequence ((clientType api) : ((.ty)
where
makeStubSig :: Q [Type] -> Q Type
makeStubSig arguments =
- [t|forall m. MonadIO m => $(buildFunctionType arguments [t|m $(buildTupleType (liftA2 (<>) optionalResultType resourceTypes))|])|]
- resourceTypes :: Q [Type]
- resourceTypes = sequence $ resourceType <$> req.createdResources
+ [t|forall m. MonadIO m => $(buildFunctionType arguments [t|m $(buildTupleType (liftA2 (<>) optionalResultType (stubResourceTypes req)))|])|]
optionalResultType :: Q [Type]
optionalResultType = case req.mResponse of
Nothing -> pure []
Just resp -> sequence [[t|Awaitable $(buildTupleType (sequence ((.ty) <$> resp.fields)))|]]
- resourceType :: RequestCreateResource -> Q Type
- resourceType RequestCreateChannel = [t|Channel|]
- resourceType (RequestCreateStream up down) = [t|Stream $up $down|]
clientRequestStubSigDec :: RpcApi -> Request -> Q Dec
clientRequestStubSigDec api req = sigD (clientRequestStubName api req) (clientRequestStubSig api req)
-resourceTypes :: Request -> Q [Type]
-resourceTypes req = sequence $ resourceType <$> req.createdResources
+stubResourceTypes :: Request -> Q [Type]
+stubResourceTypes req = sequence $ stubResourceType <$> req.createdResources
-resourceType :: RequestCreateResource -> Q Type
-resourceType RequestCreateChannel = [t|Channel|]
-resourceType (RequestCreateStream up down) = [t|Stream $up $down|]
+implResourceTypes :: Request -> Q [Type]
+implResourceTypes req = sequence $ implResourceType <$> req.createdResources
+
+stubResourceType :: RequestCreateResource -> Q Type
+stubResourceType RequestCreateChannel = [t|Channel|]
+stubResourceType (RequestCreateStream up down) = [t|Stream $up $down|]
+
+implResourceType :: RequestCreateResource -> Q Type
+implResourceType RequestCreateChannel = [t|Channel|]
+implResourceType (RequestCreateStream up down) = [t|Stream $down $up|]
resourceNamePrefix :: RequestCreateResource -> String
resourceNamePrefix RequestCreateChannel = "channel"
--
GitLab