From 97b07380e530820dd404cc19abe8b52b6b56a573 Mon Sep 17 00:00:00 2001
From: Ari Fordsham <arifordsham@gmail.com>
Date: Sun, 25 Jun 2023 16:30:17 +0300
Subject: [PATCH] Make changes

---
 yesod-core/src/Yesod/Core/Internal/TH.hs | 44 +++++++++++++++++-------
 1 file changed, 31 insertions(+), 13 deletions(-)

diff --git a/yesod-core/src/Yesod/Core/Internal/TH.hs b/yesod-core/src/Yesod/Core/Internal/TH.hs
index 11bbf90b..1bbcbbb1 100644
--- a/yesod-core/src/Yesod/Core/Internal/TH.hs
+++ b/yesod-core/src/Yesod/Core/Internal/TH.hs
@@ -167,18 +167,10 @@ mkYesodGeneral appCxt' namestr mtys isSub f resS = do
             ]
     return (dataDec, dispatchDec)
 
-mkMDS :: (Exp -> Q Exp) -> Q Exp -> MkDispatchSettings a site b
-mkMDS f rh = MkDispatchSettings
+mkMDS :: (Exp -> Q Exp) -> Q Exp -> Q Exp -> MkDispatchSettings a site b
+mkMDS f rh sd = MkDispatchSettings
     { mdsRunHandler = rh
-    , mdsSubDispatcher =
-        [|\parentRunner getSub toParent env -> yesodSubDispatch
-                                 YesodSubRunnerEnv
-                                    { ysreParentRunner = parentRunner
-                                    , ysreGetSub = getSub
-                                    , ysreToParentRoute = toParent
-                                    , ysreParentEnv = env
-                                    }
-                              |]
+    , mdsSubDispatcher = sd
     , mdsGetPathInfo = [|W.pathInfo|]
     , mdsSetPathInfo = [|\p r -> r { W.pathInfo = p }|]
     , mdsMethod = [|W.requestMethod|]
@@ -199,7 +191,20 @@ mkDispatchInstance :: Type                      -- ^ The master site type
                    -> [ResourceTree c]          -- ^ The resource
                    -> DecsQ
 mkDispatchInstance master cxt f res = do
-    clause' <- mkDispatchClause (mkMDS f [|yesodRunner|]) res
+    clause' <- 
+        mkDispatchClause 
+            (mkMDS 
+                f 
+                [|yesodRunner|] 
+                [|\parentRunner getSub toParent env -> yesodSubDispatch
+                    YesodSubRunnerEnv
+                    { ysreParentRunner = parentRunner
+                    , ysreGetSub = getSub
+                    , ysreToParentRoute = toParent
+                    , ysreParentEnv = env
+                    }
+                |])
+            res
     let thisDispatch = FunD 'yesodDispatch [clause']
     return [instanceD cxt yDispatch [thisDispatch]]
   where
@@ -207,7 +212,20 @@ mkDispatchInstance master cxt f res = do
 
 mkYesodSubDispatch :: [ResourceTree a] -> Q Exp
 mkYesodSubDispatch res = do
-    clause' <- mkDispatchClause (mkMDS return [|subHelper|]) res
+    clause' <- 
+        mkDispatchClause
+            (mkMDS 
+                return 
+                [|subHelper|] 
+                [|\_ getSub toParent env -> yesodSubDispatch
+                    YesodSubRunnerEnv
+                    { ysreParentRunner = ysreParentRunner env
+                    , ysreGetSub = getSub . ysreGetSub env
+                    , ysreToParentRoute = ysreToParentRoute env . toParent
+                    , ysreParentEnv = ysreParentEnv env
+                    }
+                |]) 
+        res
     inner <- newName "inner"
     let innerFun = FunD inner [clause']
     helper <- newName "helper"