From dc8f7946dc4e3b6d32c819dfba5b9c330c2442e8 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 3 Jan 2012 11:35:16 +0200 Subject: [PATCH] Better dispatch sample code --- yesod-routes/Yesod/Routes/TH/Dispatch.hs | 56 +++++++++++++++++++++++- yesod-routes/test/main.hs | 33 +++++++------- 2 files changed, 73 insertions(+), 16 deletions(-) diff --git a/yesod-routes/Yesod/Routes/TH/Dispatch.hs b/yesod-routes/Yesod/Routes/TH/Dispatch.hs index 53e4247d..35b15249 100644 --- a/yesod-routes/Yesod/Routes/TH/Dispatch.hs +++ b/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" diff --git a/yesod-routes/test/main.hs b/yesod-routes/test/main.hs index a48e2eaf..9d3fd20f 100644 --- a/yesod-routes/test/main.hs +++ b/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" ]