Dispatching works! (w00t)
This commit is contained in:
Michael Snoyman
parent
c946fd2068
commit
09750605a8
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user