Disaptch TH code mostly written
This commit is contained in:
Michael Snoyman
parent
dc8f7946dc
commit
c946fd2068
@ -7,7 +7,7 @@ module Yesod.Routes.TH.Dispatch
|
||||
import Yesod.Routes.TH.Types
|
||||
import Language.Haskell.TH.Syntax
|
||||
import Data.Maybe (maybeToList, catMaybes)
|
||||
import Control.Monad (replicateM)
|
||||
import Control.Monad (replicateM, forM)
|
||||
import Data.Text (pack)
|
||||
import qualified Yesod.Routes.Dispatch as D
|
||||
import qualified Data.Map as Map
|
||||
@ -16,12 +16,20 @@ import Web.PathPieces (PathPiece (..), PathMultiPiece (..))
|
||||
import Yesod.Routes.Class
|
||||
import Data.Maybe (catMaybes)
|
||||
import Control.Applicative ((<$>))
|
||||
import Data.List (foldl')
|
||||
|
||||
mkDispatchClause :: [Resource]
|
||||
mkDispatchClause :: Q Exp -- ^ runHandler function
|
||||
-> Q Exp -- ^ dispatcher function
|
||||
-> [Resource]
|
||||
-> Q Clause
|
||||
mkDispatchClause ress = do
|
||||
mkDispatchClause runHandler dispatcher ress = do
|
||||
-- Allocate the names to be used. Start off with the names passed to the
|
||||
-- function itself (with a 0 suffix).
|
||||
--
|
||||
-- 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.
|
||||
master0 <- newName "master0"
|
||||
sub0 <- newName "sub0"
|
||||
toMaster0 <- newName "toMaster0"
|
||||
@ -30,30 +38,31 @@ mkDispatchClause ress = do
|
||||
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
|
||||
-- Name of the dispatch function
|
||||
dispatch <- newName "dispatch"
|
||||
|
||||
-- Dispatch function applied to the pieces
|
||||
let dispatched = VarE dispatch `AppE` VarE pieces0
|
||||
|
||||
-- The 'D.Route's used in the dispatch function
|
||||
routes <- mapM (buildRoute runHandler dispatcher) ress
|
||||
|
||||
-- The dispatch function itself
|
||||
toDispatch <- [|D.toDispatch|]
|
||||
let dispatchFun = FunD dispatch [Clause [] (NormalB $ toDispatch `AppE` ListE routes) []]
|
||||
|
||||
-- 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 pats (NormalB u) methodMaps
|
||||
u <- [|case $(return dispatched) of
|
||||
Just f -> f $(return $ VarE master0)
|
||||
$(return $ VarE sub0)
|
||||
Nothing -> $(return $ VarE app4040)
|
||||
|]
|
||||
return $ Clause pats (NormalB u) $ dispatchFun : methodMaps
|
||||
|
||||
-- | Determine the name of the method map for a given resource name.
|
||||
methodMapName :: String -> Name
|
||||
@ -74,81 +83,130 @@ buildMethodMap (Resource name _ (Methods _ methods)) = do
|
||||
return $ TupE [pack' `AppE` LitE (StringL method), func]
|
||||
buildMethodMap (Resource _ _ Subsite{}) = return Nothing
|
||||
|
||||
{- FIXME
|
||||
let routes = fmap ListE $ mapM toRoute ress
|
||||
sub <- newName "sub"
|
||||
mkey <- newName "mkey"
|
||||
ts <- newName "ts"
|
||||
master <- newName "master"
|
||||
toMaster <- newName "toMaster"
|
||||
let pats =
|
||||
[ VarP sub
|
||||
, VarP mkey
|
||||
, VarP ts
|
||||
, VarP master
|
||||
, VarP toMaster
|
||||
-- | Build a single 'D.Route' expression.
|
||||
buildRoute :: Q Exp -> Q Exp -> Resource -> Q Exp
|
||||
buildRoute runHandler dispatcher (Resource name resPieces resDisp) = do
|
||||
-- First two arguments to D.Route
|
||||
routePieces <- ListE <$> mapM convertPiece resPieces
|
||||
isMulti <-
|
||||
case resDisp of
|
||||
Methods Nothing _ -> [|False|]
|
||||
_ -> [|True|]
|
||||
|
||||
[|D.Route $(return routePieces) $(return isMulti) $(routeArg3 runHandler dispatcher name resPieces resDisp)|]
|
||||
|
||||
routeArg3 runHandler dispatcher name resPieces resDisp = do
|
||||
pieces <- newName "pieces"
|
||||
|
||||
-- Allocate input piece variables (xs) and variables that have been
|
||||
-- converted via fromPathPiece (ys)
|
||||
xs <- forM resPieces $ \piece ->
|
||||
case piece of
|
||||
Static _ -> return Nothing
|
||||
Dynamic _ -> Just <$> newName "x"
|
||||
|
||||
ys <- forM (catMaybes xs) $ \x -> do
|
||||
y <- newName "y"
|
||||
return (x, y)
|
||||
|
||||
-- In case we have multi pieces at the end
|
||||
xrest <- newName "xrest"
|
||||
yrest <- newName "yrest"
|
||||
|
||||
-- Determine the pattern for matching the pieces
|
||||
pat <-
|
||||
case resDisp of
|
||||
Methods Nothing _ -> return $ ListP $ map (maybe WildP VarP) xs
|
||||
_ -> do
|
||||
let cons = mkName ":"
|
||||
return $ foldr (\a b -> ConP cons [maybe WildP VarP a, b]) (VarP xrest) xs
|
||||
|
||||
-- Convert the xs
|
||||
fromPathPiece' <- [|fromPathPiece|]
|
||||
xstmts <- forM ys $ \(x, y) -> return $ BindS (VarP y) (fromPathPiece' `AppE` VarE x)
|
||||
|
||||
-- Convert the xrest if appropriate
|
||||
(reststmts, yrest') <-
|
||||
case resDisp of
|
||||
Methods (Just _) _ -> do
|
||||
fromPathMultiPiece' <- [|fromPathMultiPiece|]
|
||||
return ([BindS (VarP yrest) (fromPathMultiPiece' `AppE` VarE xrest)], [yrest])
|
||||
_ -> return ([], [])
|
||||
|
||||
-- The final expression that actually uses the values we've computed
|
||||
caller <- buildCaller runHandler dispatcher name resDisp $ map snd ys ++ yrest'
|
||||
|
||||
-- Put together all the statements
|
||||
just <- [|Just|]
|
||||
let stmts = concat
|
||||
[ xstmts
|
||||
, reststmts
|
||||
, [NoBindS $ just `AppE` caller]
|
||||
]
|
||||
|
||||
dispatch <- newName "dispatch"
|
||||
body <- [|D.toDispatch $(routes)|]
|
||||
return $ Clause
|
||||
pats
|
||||
(NormalB $ VarE dispatch `AppE` VarE ts `AppE` TupE (map VarE [sub, mkey, master, toMaster]))
|
||||
[FunD dispatch [Clause [] (NormalB body) []]]
|
||||
where
|
||||
errorMsg <- [|error "Invariant violated"|]
|
||||
let matches =
|
||||
[ Match pat (NormalB $ DoE stmts) []
|
||||
, Match WildP (NormalB errorMsg) []
|
||||
]
|
||||
|
||||
mkTsPattern :: [Piece] -> Maybe t -> Q ([Name], Maybe Name, Pat)
|
||||
mkTsPattern pieces mmulti = do
|
||||
end <-
|
||||
case mmulti of
|
||||
Nothing -> return (Nothing, ConP (mkName "[]") [])
|
||||
Just{} -> do
|
||||
end <- newName "end"
|
||||
return (Just end, VarP end)
|
||||
pieces' <- mapM go pieces
|
||||
return (catMaybes $ map fst pieces', fst end, foldr (flip InfixP $ mkName ":") (snd end) $ map snd pieces')
|
||||
where
|
||||
go Static{} = return (Nothing, WildP)
|
||||
go Dynamic{} = do
|
||||
dyn <- newName "dyn"
|
||||
return (Just dyn, VarP dyn)
|
||||
return $ LamE [VarP pieces] $ CaseE (VarE pieces) matches
|
||||
|
||||
-- | Convert a 'Piece' into a 'D.Piece'.
|
||||
toPiece :: Piece -> Q Exp
|
||||
toPiece (Static s) = [|D.Static $ pack $(lift s)|]
|
||||
toPiece Dynamic{} = [|D.Dynamic|]
|
||||
-- | The final expression in the individual Route definitions.
|
||||
buildCaller runHandler dispatcher name resDisp ys = do
|
||||
master <- newName "master"
|
||||
sub <- newName "sub"
|
||||
toMaster <- newName "toMaster"
|
||||
app404 <- newName "app404"
|
||||
handler405 <- newName "handler405"
|
||||
method <- newName "method"
|
||||
|
||||
-- | Convert a 'Resource' into a 'D.Route'.
|
||||
toRoute :: Resource -> Q Exp
|
||||
toRoute res = do
|
||||
let ps = fmap ListE $ mapM toPiece $ resourcePieces res
|
||||
let m = maybe [|False|] (const [|True|]) $ resourceMulti res
|
||||
case resourceDispatch res of
|
||||
Methods mmulti mds -> do
|
||||
let toPair m' = do
|
||||
key <- [|pack $(lift m')|]
|
||||
let value = VarE $ mkName $ map toLower m' ++ resourceName res
|
||||
return $ TupE [key, value]
|
||||
let handler =
|
||||
if null mds
|
||||
then [|Left $(return $ VarE $ mkName $ "handle" ++ resourceName res)|]
|
||||
else [|Right $ Map.fromList $(fmap ListE $ mapM toPair mds)|]
|
||||
sub <- newName "sub"
|
||||
mkey <- newName "mkey"
|
||||
(dyns, mend, tsPattern) <- mkTsPattern (resourcePieces res) mmulti
|
||||
master <- newName "master"
|
||||
toMaster <- newName "toMaster"
|
||||
body <- [|$(toApp) $(handler)|]
|
||||
let func = LamE
|
||||
[ tsPattern
|
||||
, TupP
|
||||
[ VarP sub
|
||||
, VarP mkey
|
||||
, VarP master
|
||||
, VarP toMaster
|
||||
]
|
||||
]
|
||||
body
|
||||
[|D.Route $(ps) $(m) $(return func)|]
|
||||
Subsite _ func -> [|D.Route $(ps) $(m) $ $(toApp) $(return $ VarE $ mkName $ "handle" ++ resourceName res)|] -- FIXME
|
||||
-}
|
||||
let pat = map VarP [master, sub, toMaster, app404, handler405, method]
|
||||
|
||||
-- Create the route
|
||||
let route = foldl' (\a b -> a `AppE` VarE b) (ConE $ mkName name) ys
|
||||
|
||||
exp <-
|
||||
case resDisp of
|
||||
Methods _ ms -> do
|
||||
handler <- newName "handler"
|
||||
|
||||
-- Figure out what the handler is
|
||||
handlerExp <-
|
||||
if null ms
|
||||
then return $ foldl' (\a b -> a `AppE` VarE b) (VarE $ mkName $ "handle" ++ name) ys
|
||||
else do
|
||||
mf <- [|Map.lookup $(return $ VarE method) $(return $ VarE $ methodMapName name)|]
|
||||
f <- newName "f"
|
||||
let apply = foldl' (\a b -> a `AppE` VarE b) (VarE f) ys
|
||||
return $ CaseE mf
|
||||
[ Match (ConP 'Just [VarP f]) (NormalB apply) []
|
||||
, Match (ConP 'Nothing []) (NormalB $ VarE handler405) []
|
||||
]
|
||||
|
||||
-- Run the whole thing
|
||||
runner <- [|$(runHandler)
|
||||
$(return $ VarE handler)
|
||||
$(return $ VarE master)
|
||||
$(return $ VarE sub)
|
||||
$(return route)
|
||||
$(return $ VarE toMaster)|]
|
||||
|
||||
return $ LetE [FunD handler [Clause [] (NormalB handlerExp) []]] runner
|
||||
Subsite _ getSub -> do
|
||||
let sub2 = foldl' (\a b -> a `AppE` VarE b) (VarE (mkName getSub) `AppE` VarE sub) ys
|
||||
[|$(dispatcher)
|
||||
$(return $ VarE master)
|
||||
$(return sub2)
|
||||
($(return $ VarE toMaster) . $(return route))
|
||||
$(return $ VarE app404)
|
||||
$(return $ VarE handler405)
|
||||
$(return $ VarE method)
|
||||
|]
|
||||
|
||||
return $ LamE pat exp
|
||||
|
||||
-- | Convert a 'Piece' to a 'D.Piece'
|
||||
convertPiece :: Piece -> Q Exp
|
||||
convertPiece (Static s) = [|D.Static $(lift s)|]
|
||||
convertPiece (Dynamic _) = [|D.Dynamic|]
|
||||
|
||||
@ -81,22 +81,6 @@ instance RenderRoute MySubParam where
|
||||
getMySubParam :: MyApp -> Int -> MySubParam
|
||||
getMySubParam _ = MySubParam
|
||||
|
||||
do
|
||||
texts <- [t|[Text]|]
|
||||
let ress =
|
||||
[ Resource "RootR" [] $ Methods Nothing ["GET"]
|
||||
, Resource "BlogPostR" [Static "blog", Dynamic $ ConT ''Text] $ Methods Nothing ["GET", "POST"]
|
||||
, Resource "WikiR" [Static "wiki"] $ Methods (Just texts) []
|
||||
, Resource "SubsiteR" [Static "subsite"] $ Subsite (ConT ''MySub) "getMySub"
|
||||
, Resource "SubparamR" [Static "subparam", Dynamic $ ConT ''Int] $ Subsite (ConT ''MySubParam) "getMySubParam"
|
||||
]
|
||||
rrinst <- mkRenderRouteInstance (ConT ''MyApp) ress
|
||||
dispatch <- mkDispatchClause ress
|
||||
return
|
||||
[ rrinst
|
||||
, FunD (mkName "thDispatch") [dispatch]
|
||||
]
|
||||
|
||||
class Dispatcher handler master sub app where
|
||||
dispatcher
|
||||
:: master
|
||||
@ -117,8 +101,25 @@ class RunHandler handler master sub app where
|
||||
-> (YRC.Route sub -> YRC.Route master)
|
||||
-> app
|
||||
|
||||
do
|
||||
texts <- [t|[Text]|]
|
||||
let ress =
|
||||
[ Resource "RootR" [] $ Methods Nothing ["GET"]
|
||||
, Resource "BlogPostR" [Static "blog", Dynamic $ ConT ''Text] $ Methods Nothing ["GET", "POST"]
|
||||
, Resource "WikiR" [Static "wiki"] $ Methods (Just texts) []
|
||||
, Resource "SubsiteR" [Static "subsite"] $ Subsite (ConT ''MySub) "getMySub"
|
||||
, Resource "SubparamR" [Static "subparam", Dynamic $ ConT ''Int] $ Subsite (ConT ''MySubParam) "getMySubParam"
|
||||
]
|
||||
rrinst <- mkRenderRouteInstance (ConT ''MyApp) ress
|
||||
dispatch <- mkDispatchClause [|runHandler|] [|dispatcher|] ress
|
||||
return
|
||||
[ rrinst
|
||||
, FunD (mkName "thDispatch") [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
|
||||
runHandler h _ _ subRoute toMaster = (h, Just $ toMaster subRoute)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user