Slight simplification to YesodDispatch typeclass

yesod-core/Yesod/Core/Class/Dispatch.hs

@@ -14,13 +14,11 @@ import Yesod.Core.Internal.Request (textQueryString)
 class YesodDispatch sub master where
     yesodDispatch
         :: Yesod master
-        => W.Application -- ^ 404 handler
+        => (Maybe (Route sub) -> YesodRunnerEnv sub master)
-        -> (Route sub -> W.Application) -- ^ 405 handler
-        -> (Route sub -> YesodRunnerEnv sub master)
         -> W.Application
 
 instance YesodDispatch WaiSubsite master where
-    yesodDispatch _404 _405 getEnv req =
+    yesodDispatch getEnv req =
         app req
       where
-        YesodRunnerEnv { yreSub = WaiSubsite app } = getEnv $ WaiSubsiteRoute (W.pathInfo req) (textQueryString req)
+        YesodRunnerEnv { yreSub = WaiSubsite app } = getEnv $ Just $ WaiSubsiteRoute (W.pathInfo req) (textQueryString req)

yesod-core/Yesod/Core/Dispatch.hs

@@ -150,6 +150,8 @@ mkDispatchInstance context sub master res = do
                 , mdsGetPathInfo = [|W.pathInfo|]
                 , mdsSetPathInfo = [|\p r -> r { W.pathInfo = p }|]
                 , mdsMethod = [|W.requestMethod|]
+                , mds404 = [|\getEnv -> yesodRunner (notFound >> return ()) $ getEnv Nothing|]
+                , mds405 = [|\getEnv route -> yesodRunner (badMethod >> return ()) (getEnv $ Just route)|]
                 } res
             return $ FunD 'yesodDispatch [clause']
    in sequence [instanceD context yDispatch [thisDispatch]]
@@ -181,7 +183,7 @@ toWaiApp' :: ( Yesod master
 toWaiApp' y logger sb req =
     case cleanPath y $ W.pathInfo req of
         Left pieces -> sendRedirect y pieces req
-        Right pieces -> yesodDispatch app404 handler405 (yre . Just) req
+        Right pieces -> yesodDispatch yre req
             { W.pathInfo = pieces
             }
   where
@@ -193,8 +195,6 @@ toWaiApp' y logger sb req =
         , yreSessionBackend = sb
         , yreRoute = route
         }
-    app404 = yesodRunner (notFound >> return ()) $ yre Nothing
-    handler405 = yesodRunner (badMethod >> return ()) . yre . Just
 
 sendRedirect :: Yesod master => master -> [Text] -> W.Application
 sendRedirect y segments' env =

yesod-core/Yesod/Core/Internal/Run.hs

@@ -275,15 +275,15 @@ resolveApproot master req =
 
 fixEnv :: (oldSub -> newSub)
        -> (Route newSub -> Route oldSub)
-       -> (Route oldSub -> YesodRunnerEnv oldSub master)
+       -> (Maybe (Route oldSub) -> YesodRunnerEnv oldSub master)
-       -> (Route newSub -> YesodRunnerEnv newSub master)
+       -> (Maybe (Route newSub) -> YesodRunnerEnv newSub master)
 fixEnv toNewSub toOldRoute getEnvOld newRoute =
-    go (getEnvOld $ toOldRoute newRoute)
+    go (getEnvOld $ fmap toOldRoute newRoute)
   where
     go env = env
         { yreSub = toNewSub $ yreSub env
         , yreToMaster = yreToMaster env . toOldRoute
-        , yreRoute = Just newRoute
+        , yreRoute = newRoute
         }
 
 stripHandlerT :: (HandlerReader m, HandlerState m, MonadBaseControl IO m)

yesod-core/test/YesodCoreTest/CleanPath.hs

@@ -30,7 +30,7 @@ instance RenderRoute Subsite where
     renderRoute (SubsiteRoute x) = (x, [])
 
 instance YesodDispatch Subsite master where
-    yesodDispatch _404 _405 _getEnv req = return $ responseLBS
+    yesodDispatch _getEnv req = return $ responseLBS
         status200
         [ ("Content-Type", "SUBSITE")
         ] $ L8.pack $ show (pathInfo req)

yesod-routes/Yesod/Routes/TH/Dispatch.hs

@@ -36,6 +36,8 @@ data MkDispatchSettings = MkDispatchSettings
     , mdsGetPathInfo :: Q Exp
     , mdsSetPathInfo :: Q Exp
     , mdsMethod :: Q Exp
+    , mds404 :: Q Exp
+    , mds405 :: Q Exp
     }
 
 -- |
@@ -112,8 +114,6 @@ mkDispatchClause mds ress' = do
     -- with -Wall). Additionally, we want to ensure that none of the code
     -- passed to toDispatch uses variables from the closure to prevent the
     -- dispatch data structure from being rebuilt on each run.
-    app4040 <- newName "app4040"
-    handler4050 <- newName "handler4050"
     getEnv0 <- newName "getEnv0"
     req0 <- newName "req0"
     pieces <- [|$(mdsGetPathInfo mds) $(return $ VarE req0)|]
@@ -137,17 +137,15 @@ mkDispatchClause mds ress' = do
             ]
 
     -- The input to the clause.
-    let pats = map VarP [app4040, handler4050, getEnv0, req0]
+    let pats = map VarP [getEnv0, req0]
 
     -- For each resource that dispatches based on methods, build up a map for handling the dispatching.
     methodMaps <- catMaybes <$> mapM (buildMethodMap mds) ress
 
     u <- [|case $(return dispatched) of
-            Just f -> f $(return $ VarE app4040)
+            Just f -> f $(return $ VarE getEnv0)
-                        $(return $ VarE handler4050)
-                        $(return $ VarE getEnv0)
                         $(return $ VarE req0)
-            Nothing -> $(return $ VarE app4040 `AppE` VarE req0)
+            Nothing -> $(mds404 mds) $(return $ VarE getEnv0) $(return $ VarE req0)
           |]
     return $ Clause pats (NormalB u) $ dispatchFun : methodMaps
   where
@@ -287,13 +285,11 @@ buildCaller :: MkDispatchSettings
             -> Q Exp
 buildCaller mds xrest parents name resDisp ys = do
     getEnv <- newName "getEnv"
-    app404 <- newName "_app404"
-    handler405 <- newName "_handler405"
     req <- newName "req"
 
     method <- [|$(mdsMethod mds) $(return $ VarE req)|]
 
-    let pat = map VarP [app404, handler405, getEnv, req]
+    let pat = map VarP [getEnv, req]
 
     -- Create the route
     let route = routeFromDynamics parents name ys
@@ -303,7 +299,7 @@ buildCaller mds xrest parents name resDisp ys = do
             Methods _ ms -> do
                 handler <- newName "handler"
 
-                let env = VarE getEnv `AppE` route
+                env <- [|$(return $ VarE getEnv) (Just $(return route))|]
 
                 -- Run the whole thing
                 runner <- [|$(return $ VarE handler)
@@ -325,10 +321,12 @@ buildCaller mds xrest parents name resDisp ys = do
                         mf <- [|Map.lookup $(return method) $(return $ VarE $ methodMapName name)|]
                         f <- newName "f"
                         let apply = foldl' (\a b -> a `AppE` VarE b) (VarE f) ys
-                        let body405 =
+                        body405 <-
-                                VarE handler405
+                            [|$(mds405 mds)
-                                `AppE` route
+                                $(return $ VarE getEnv)
-                                `AppE` VarE req
+                                $(return route)
+                                $(return $ VarE req)
+                             |]
                         return $ CaseE mf
                             [ Match (ConP 'Just [VarP f]) (NormalB $ myLet apply) []
                             , Match (ConP 'Nothing []) (NormalB body405) []
@@ -339,8 +337,6 @@ buildCaller mds xrest parents name resDisp ys = do
                 let sub2 = LamE [VarP sub]
                         (foldl' (\a b -> a `AppE` VarE b) (VarE (mkName getSub) `AppE` VarE sub) ys)
                 [|$(mdsDispatcher mds)
-                    $(return $ VarE app404)
-                    ($(return $ VarE handler405) . $(return route))
                     ($(mdsFixEnv mds)
                         $(return sub2)
                         $(return route)