From 09750605a8476a7f85c990c47fe96f2940f7b281 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 3 Jan 2012 12:55:08 +0200 Subject: [PATCH] Dispatching works! (w00t) --- yesod-routes/Yesod/Routes/TH/Dispatch.hs | 35 +++++++++++++----- yesod-routes/test/main.hs | 45 +++++++++++++----------- 2 files changed, 51 insertions(+), 29 deletions(-) diff --git a/yesod-routes/Yesod/Routes/TH/Dispatch.hs b/yesod-routes/Yesod/Routes/TH/Dispatch.hs index d017d2d6..e1806d60 100644 --- a/yesod-routes/Yesod/Routes/TH/Dispatch.hs +++ b/yesod-routes/Yesod/Routes/TH/Dispatch.hs @@ -4,17 +4,16 @@ module Yesod.Routes.TH.Dispatch mkDispatchClause ) where +import Prelude hiding (exp) import Yesod.Routes.TH.Types import Language.Haskell.TH.Syntax -import Data.Maybe (maybeToList, catMaybes) -import Control.Monad (replicateM, forM) +import Data.Maybe (catMaybes) +import Control.Monad (forM) import Data.Text (pack) import qualified Yesod.Routes.Dispatch as D 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 ((<$>)) import Data.List (foldl') @@ -60,6 +59,10 @@ mkDispatchClause runHandler dispatcher ress = do u <- [|case $(return dispatched) of Just f -> f $(return $ VarE master0) $(return $ VarE sub0) + $(return $ VarE toMaster0) + $(return $ VarE app4040) + $(return $ VarE handler4050) + $(return $ VarE method0) Nothing -> $(return $ VarE app4040) |] return $ Clause pats (NormalB u) $ dispatchFun : methodMaps @@ -95,6 +98,12 @@ buildRoute runHandler dispatcher (Resource name resPieces resDisp) = do [|D.Route $(return routePieces) $(return isMulti) $(routeArg3 runHandler dispatcher name resPieces resDisp)|] +routeArg3 :: Q Exp -- ^ runHandler + -> Q Exp -- ^ dispatcher + -> String -- ^ name of resource + -> [Piece] + -> Dispatch + -> Q Exp routeArg3 runHandler dispatcher name resPieces resDisp = do pieces <- newName "pieces" @@ -134,7 +143,7 @@ routeArg3 runHandler dispatcher name resPieces resDisp = do _ -> return ([], []) -- The final expression that actually uses the values we've computed - caller <- buildCaller runHandler dispatcher name resDisp $ map snd ys ++ yrest' + caller <- buildCaller runHandler dispatcher xrest name resDisp $ map snd ys ++ yrest' -- Put together all the statements just <- [|Just|] @@ -153,13 +162,20 @@ routeArg3 runHandler dispatcher name resPieces resDisp = do return $ LamE [VarP pieces] $ CaseE (VarE pieces) matches -- | The final expression in the individual Route definitions. -buildCaller runHandler dispatcher name resDisp ys = do +buildCaller :: Q Exp -- ^ runHandler + -> Q Exp -- ^ dispatcher + -> Name -- ^ xrest + -> String -- ^ name of resource + -> Dispatch + -> [Name] -- ^ ys + -> Q Exp +buildCaller runHandler dispatcher xrest name resDisp ys = do master <- newName "master" sub <- newName "sub" toMaster <- newName "toMaster" - app404 <- newName "app404" - handler405 <- newName "handler405" - method <- newName "method" + app404 <- newName "_app404" + handler405 <- newName "_handler405" + method <- newName "_method" let pat = map VarP [master, sub, toMaster, app404, handler405, method] @@ -202,6 +218,7 @@ buildCaller runHandler dispatcher name resDisp ys = do $(return $ VarE app404) $(return $ VarE handler405) $(return $ VarE method) + $(return $ VarE xrest) |] return $ LamE pat exp diff --git a/yesod-routes/test/main.hs b/yesod-routes/test/main.hs index 2a0184b2..5d40ecec 100644 --- a/yesod-routes/test/main.hs +++ b/yesod-routes/test/main.hs @@ -5,6 +5,8 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE TypeSynonymInstances #-} import Test.Hspec.Monadic import Test.Hspec.HUnit () import Test.HUnit ((@?=)) @@ -17,7 +19,6 @@ import qualified Yesod.Routes.Dispatch as D import Yesod.Routes.TH hiding (Dispatch) import Language.Haskell.TH.Syntax import qualified Data.Map as Map -import Data.Maybe (fromMaybe) result :: ([Text] -> Maybe Int) -> Dispatch Int result f ts = f ts @@ -81,25 +82,28 @@ instance RenderRoute MySubParam where getMySubParam :: MyApp -> Int -> MySubParam getMySubParam _ = MySubParam -class Dispatcher handler master sub app where +type Handler sub master = String +type App sub master = (String, Maybe (YRC.Route master)) + +class Dispatcher sub master where dispatcher :: master -> sub -> (YRC.Route sub -> YRC.Route master) - -> app -- ^ 404 page - -> handler -- ^ 405 page + -> App sub master -- ^ 404 page + -> Handler sub master -- ^ 405 page -> Text -- ^ method -> [Text] - -> app + -> App sub master -class RunHandler handler master sub app where +class RunHandler sub master where runHandler - :: handler + :: Handler sub master -> master -> sub -> YRC.Route sub -> (YRC.Route sub -> YRC.Route master) - -> app + -> App sub master do texts <- [t|[Text]|] @@ -114,20 +118,21 @@ do dispatch <- mkDispatchClause [|runHandler|] [|dispatcher|] ress return [ rrinst - , FunD (mkName "thDispatch") [dispatch] + , InstanceD + [] + (ConT ''Dispatcher + `AppT` ConT ''MyApp + `AppT` ConT ''MyApp) + [FunD (mkName "dispatcher") [dispatch]] ] -instance Dispatcher [Char] MyApp MyApp ([Char], Maybe (YRC.Route MyApp)) where - dispatcher = thDispatchAlias - --dispatcher = thDispatch - -instance RunHandler [Char] MyApp MyApp ([Char], Maybe (YRC.Route MyApp)) where +instance RunHandler MyApp master where runHandler h _ _ subRoute toMaster = (h, Just $ toMaster subRoute) -instance Dispatcher [Char] master MySub ([Char], Maybe (YRC.Route master)) where +instance Dispatcher MySub master where dispatcher _ _ toMaster _ _ _ pieces = ("subsite: " ++ show pieces, Just $ toMaster $ MySubRoute (pieces, [])) -instance Dispatcher [Char] master MySubParam ([Char], Maybe (YRC.Route master)) where +instance Dispatcher MySubParam master where dispatcher _ (MySubParam i) toMaster app404 _ _ pieces = case map unpack pieces of [[c]] -> ("subparam " ++ show i ++ ' ' : [c], Just $ toMaster $ ParamRoute c) @@ -153,7 +158,7 @@ thDispatchAlias master sub toMaster app404 handler405 method0 pieces0 = [ Route [] False $ \pieces -> case pieces of [] -> do - Just $ \master' sub' toMaster' app404' handler405' method -> + Just $ \master' sub' toMaster' _app404' handler405' method -> let handler = case Map.lookup method methodsRootR of Just f -> f @@ -164,7 +169,7 @@ thDispatchAlias master sub toMaster app404 handler405 method0 pieces0 = case pieces of [_, x2] -> do y2 <- fromPathPiece x2 - Just $ \master' sub' toMaster' app404' handler405' method -> + Just $ \master' sub' toMaster' _app404' handler405' method -> let handler = case Map.lookup method methodsBlogPostR of Just f -> f y2 @@ -175,7 +180,7 @@ thDispatchAlias master sub toMaster app404 handler405 method0 pieces0 = case pieces of _:x2 -> do y2 <- fromPathMultiPiece x2 - Just $ \master' sub' toMaster' app404' handler405' method -> + Just $ \master' sub' toMaster' _app404' _handler405' _method -> let handler = handleWikiR y2 in runHandler handler master' sub' (WikiR y2) toMaster' _ -> error "Invariant violated" @@ -235,7 +240,7 @@ main = hspecX $ do @?= (["subparam", "6", "c"], []) describe "thDispatch" $ do - let disp = thDispatchAlias MyApp MyApp id ("404", Nothing) "405" + let disp = dispatcher MyApp MyApp id ("404" :: String, Nothing) "405" it "routes to root" $ disp "GET" [] @?= ("this is the root", Just RootR) it "POST root is 405" $ disp "POST" [] @?= ("405", Just RootR) it "invalid page is a 404" $ disp "GET" ["not-found"] @?= ("404", Nothing)