Better dispatch sample code

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

@@ -14,12 +14,66 @@ import qualified Data.Map as Map
 import Data.Char (toLower)
 import Web.PathPieces (PathPiece (..), PathMultiPiece (..))
 import Yesod.Routes.Class
+import Data.Maybe (catMaybes)
+import Control.Applicative ((<$>))
 
 mkDispatchClause :: [Resource]
                  -> Q Clause
 mkDispatchClause ress = do
+    -- Allocate the names to be used. Start off with the names passed to the
+    -- function itself (with a 0 suffix).
+    master0 <- newName "master0"
+    sub0 <- newName "sub0"
+    toMaster0 <- newName "toMaster0"
+    app4040 <- newName "app4040"
+    handler4050 <- newName "handler4050"
+    method0 <- newName "method0"
+    pieces0 <- newName "pieces0"
+
+    -- The following names will be used internally. We don't reuse names so as
+    -- to avoid shadowing names (triggers warnings 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.
+    master <- newName "master"
+    sub <- newName "sub"
+    toMaster <- newName "toMaster"
+    app404 <- newName "app404"
+    handler405 <- newName "handler405"
+    method <- newName "method"
+    pieces <- newName "pieces"
+
+    -- Name of the dispatch function itself
+    dispatch <- newName "dispatch"
+
+    -- The input to the clause.
+    let pats = map VarP [master0, sub0, toMaster0, app4040, handler4050, method0, pieces0]
+
+    -- For each resource that dispatches based on methods, build up a map for handling the dispatching.
+    methodMaps <- catMaybes <$> mapM buildMethodMap ress
+
     u <- [|error "mkDispatchClause"|]
-    return $ Clause [] (NormalB u) []
+    return $ Clause pats (NormalB u) methodMaps
+
+-- | Determine the name of the method map for a given resource name.
+methodMapName :: String -> Name
+methodMapName s = mkName $ "methods" ++ s
+
+buildMethodMap :: Resource -> Q (Maybe Dec)
+buildMethodMap (Resource _ _ (Methods _ [])) = return Nothing -- single handle function
+buildMethodMap (Resource name _ (Methods _ methods)) = do
+    fromList <- [|Map.fromList|]
+    methods' <- mapM go methods
+    let exp = fromList `AppE` ListE methods'
+    let fun = FunD (methodMapName name) [Clause [] (NormalB exp) []]
+    return $ Just fun
+  where
+    go method = do
+        let func = VarE $ mkName $ map toLower method ++ name
+        pack' <- [|pack|]
+        return $ TupE [pack' `AppE` LitE (StringL method), func]
+buildMethodMap (Resource _ _ Subsite{}) = return Nothing
+
 {- FIXME
     let routes = fmap ListE $ mapM toRoute ress
     sub <- newName "sub"

yesod-routes/test/main.hs

@@ -145,47 +145,50 @@ thDispatchAlias
 --thDispatchAlias = thDispatch
 thDispatchAlias master sub toMaster app404 handler405 method0 pieces0 =
     case dispatch pieces0 of
-        Just (Left (route, mhandler)) ->
-            let handler = fromMaybe handler405 $ mhandler method0
-             in runHandler handler master sub route toMaster
-        Just (Right f) -> f master sub toMaster app404 handler405 method0
+        Just f -> f master sub toMaster app404 handler405 method0
         Nothing -> app404
   where
     dispatch = toDispatch
         [ Route [] False $ \pieces ->
             case pieces of
                 [] -> do
-                    Just $ Left (RootR, \method ->
-                        case Map.lookup method methodsRootR of
-                            Just f -> Just f
-                            Nothing -> Nothing)
+                    Just $ \master' sub' toMaster' app404' handler405' method ->
+                        let handler =
+                                case Map.lookup method methodsRootR of
+                                    Just f -> f
+                                    Nothing -> handler405'
+                         in runHandler handler master' sub' RootR toMaster'
                 _ -> error "Invariant violated"
         , Route [D.Static "blog", D.Dynamic] False $ \pieces ->
             case pieces of
                 [_, x2] -> do
                     y2 <- fromPathPiece x2
-                    Just $ Left (BlogPostR y2, \method ->
-                        case Map.lookup method methodsBlogPostR of
-                            Just f -> Just (f y2)
-                            Nothing -> Nothing)
+                    Just $ \master' sub' toMaster' app404' handler405' method ->
+                        let handler =
+                                case Map.lookup method methodsBlogPostR of
+                                    Just f -> f y2
+                                    Nothing -> handler405'
+                         in runHandler handler master' sub' (BlogPostR y2) toMaster'
                 _ -> error "Invariant violated"
         , Route [D.Static "wiki"] True $ \pieces ->
             case pieces of
                 _:x2 -> do
                     y2 <- fromPathMultiPiece x2
-                    Just $ Left (WikiR y2, const $ Just $ handleWikiR y2)
+                    Just $ \master' sub' toMaster' app404' handler405' method ->
+                        let handler = handleWikiR y2
+                         in runHandler handler master' sub' (WikiR y2) toMaster'
                 _ -> error "Invariant violated"
         , Route [D.Static "subsite"] True $ \pieces ->
             case pieces of
                 _:x2 -> do
-                    Just $ Right $ \master' sub' toMaster' app404' handler405' method ->
+                    Just $ \master' sub' toMaster' app404' handler405' method ->
                         dispatcher master' (getMySub sub') (toMaster' . SubsiteR) app404' handler405' method x2
                 _ -> error "Invariant violated"
         , Route [D.Static "subparam", D.Dynamic] True $ \pieces ->
             case pieces of
                 _:x2:x3 -> do
                     y2 <- fromPathPiece x2
-                    Just $ Right $ \master' sub' toMaster' app404' handler405' method ->
+                    Just $ \master' sub' toMaster' app404' handler405' method ->
                         dispatcher master' (getMySubParam sub' y2) (toMaster' . SubparamR y2) app404' handler405' method x3
                 _ -> error "Invariant violated"
         ]