From 23004e65c33e71891777dc3dc7ab4d1dae96e54d Mon Sep 17 00:00:00 2001
From: Jens Nolte <git@queezle.net>
Date: Tue, 10 Aug 2021 16:51:28 +0200
Subject: [PATCH] Insert join only where necessary
---
src/Quasar/Network/TH.hs | 13 +++++++++----
1 file changed, 9 insertions(+), 4 deletions(-)
diff --git a/src/Quasar/Network/TH.hs b/src/Quasar/Network/TH.hs
index eb4035e..5ef8d5e 100644
--- a/src/Quasar/Network/TH.hs
+++ b/src/Quasar/Network/TH.hs
@@ -287,7 +287,7 @@ makeServer api@RpcApi{functions} code = sequence [protocolImplDec, logicInstance
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 = varE 'join `appE` applyM implE resourceEs
+ applyResources resourceEs implE = applyM implE resourceEs
invalidChannelCountClause :: Q Clause
invalidChannelCountClause = do
@@ -588,12 +588,17 @@ buildTupleM fields = buildTuple' =<< fields
buildTuple' :: [Exp] -> Q Exp
buildTuple' [] = [|pure ()|]
buildTuple' [single] = pure single
- buildTuple' fs = pure (TupE (const Nothing <$> fs)) `applyM` (pure <$> fs)
+ buildTuple' fs = pure (TupE (const Nothing <$> fs)) `applyA` (pure <$> fs)
-- | (a -> b -> c -> d) -> [m a, m b, m c] -> m d
+applyA :: Q Exp -> [Q Exp] -> Q Exp
+applyA con [] = [|pure $con|]
+applyA con (monadicE:monadicEs) = foldl (\x y -> [|$x <*> $y|]) [|$con <$> $monadicE|] monadicEs
+
+-- | (a -> b -> c -> m d) -> [m a, m b, m c] -> m d
applyM :: Q Exp -> [Q Exp] -> Q Exp
-applyM con [] = [|pure $con|]
-applyM con (monadicE:monadicEs) = foldl (\x y -> [|$x <*> $y|]) [|$con <$> $monadicE|] monadicEs
+applyM con [] = con
+applyM con args = [|join $(applyA con args)|]
buildFunctionType :: Q [Type] -> Q Type -> Q Type
buildFunctionType argTypes returnType = go =<< argTypes
--
GitLab