haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Make changes

Browse Source
This commit is contained in:
Ari Fordsham 2023-06-25 16:30:17 +03:00
parent 197ecb409f
commit 97b07380e5
1 changed files with 31 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

44
yesod-core/src/Yesod/Core/Internal/TH.hs
View File

@ -167,18 +167,10 @@ mkYesodGeneral appCxt' namestr mtys isSub f resS = do
] ]
return (dataDec, dispatchDec) return (dataDec, dispatchDec)
mkMDS :: (Exp -> Q Exp) -> Q Exp -> MkDispatchSettings a site b mkMDS :: (Exp -> Q Exp) -> Q Exp -> Q Exp -> MkDispatchSettings a site b
mkMDS f rh = MkDispatchSettings mkMDS f rh sd = MkDispatchSettings
{ mdsRunHandler = rh { mdsRunHandler = rh
, mdsSubDispatcher = , mdsSubDispatcher = sd
[|\parentRunner getSub toParent env -> yesodSubDispatch
YesodSubRunnerEnv
{ ysreParentRunner = parentRunner
, ysreGetSub = getSub
, ysreToParentRoute = toParent
, ysreParentEnv = env
}
|]
, mdsGetPathInfo = [|W.pathInfo|] , mdsGetPathInfo = [|W.pathInfo|]
, mdsSetPathInfo = [|\p r -> r { W.pathInfo = p }|] , mdsSetPathInfo = [|\p r -> r { W.pathInfo = p }|]
, mdsMethod = [|W.requestMethod|] , mdsMethod = [|W.requestMethod|]
@ -199,7 +191,20 @@ mkDispatchInstance :: Type -- ^ The master site type
-> [ResourceTree c] -- ^ The resource -> [ResourceTree c] -- ^ The resource
-> DecsQ -> DecsQ
mkDispatchInstance master cxt f res = do 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'] let thisDispatch = FunD 'yesodDispatch [clause']
return [instanceD cxt yDispatch [thisDispatch]] return [instanceD cxt yDispatch [thisDispatch]]
where where
@ -207,7 +212,20 @@ mkDispatchInstance master cxt f res = do
mkYesodSubDispatch :: [ResourceTree a] -> Q Exp mkYesodSubDispatch :: [ResourceTree a] -> Q Exp
mkYesodSubDispatch res = do 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" inner <- newName "inner"
let innerFun = FunD inner [clause'] let innerFun = FunD inner [clause']
helper <- newName "helper" helper <- newName "helper"