haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Disaptch TH code mostly written

Browse Source
This commit is contained in:
Michael Snoyman 2012-01-03 12:34:34 +02:00
parent dc8f7946dc
commit c946fd2068
2 changed files with 167 additions and 108 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

242
yesod-routes/Yesod/Routes/TH/Dispatch.hs
View File

@ -7,7 +7,7 @@ module Yesod.Routes.TH.Dispatch
import Yesod.Routes.TH.Types import Yesod.Routes.TH.Types
import Language.Haskell.TH.Syntax import Language.Haskell.TH.Syntax
import Data.Maybe (maybeToList, catMaybes) import Data.Maybe (maybeToList, catMaybes)
import Control.Monad (replicateM) import Control.Monad (replicateM, forM)
import Data.Text (pack) import Data.Text (pack)
import qualified Yesod.Routes.Dispatch as D import qualified Yesod.Routes.Dispatch as D
import qualified Data.Map as Map import qualified Data.Map as Map
@ -16,12 +16,20 @@ import Web.PathPieces (PathPiece (..), PathMultiPiece (..))
import Yesod.Routes.Class import Yesod.Routes.Class
import Data.Maybe (catMaybes) import Data.Maybe (catMaybes)
import Control.Applicative ((<$>)) import Control.Applicative ((<$>))
import Data.List (foldl')
mkDispatchClause :: [Resource] mkDispatchClause :: Q Exp -- ^ runHandler function
-> Q Exp -- ^ dispatcher function
-> [Resource]
-> Q Clause -> Q Clause
mkDispatchClause ress = do mkDispatchClause runHandler dispatcher ress = do
-- Allocate the names to be used. Start off with the names passed to the -- Allocate the names to be used. Start off with the names passed to the
-- function itself (with a 0 suffix). -- 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" master0 <- newName "master0"
sub0 <- newName "sub0" sub0 <- newName "sub0"
toMaster0 <- newName "toMaster0" toMaster0 <- newName "toMaster0"
@ -30,30 +38,31 @@ mkDispatchClause ress = do
method0 <- newName "method0" method0 <- newName "method0"
pieces0 <- newName "pieces0" pieces0 <- newName "pieces0"
-- The following names will be used internally. We don't reuse names so as -- Name of the dispatch function
-- 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" 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. -- The input to the clause.
let pats = map VarP [master0, sub0, toMaster0, app4040, handler4050, method0, pieces0] 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. -- For each resource that dispatches based on methods, build up a map for handling the dispatching.
methodMaps <- catMaybes <$> mapM buildMethodMap ress methodMaps <- catMaybes <$> mapM buildMethodMap ress
u <- [|error "mkDispatchClause"|] u <- [|case $(return dispatched) of
return $ Clause pats (NormalB u) methodMaps 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. -- | Determine the name of the method map for a given resource name.
methodMapName :: String -> Name methodMapName :: String -> Name
@ -74,81 +83,130 @@ buildMethodMap (Resource name _ (Methods _ methods)) = do
return $ TupE [pack' `AppE` LitE (StringL method), func] return $ TupE [pack' `AppE` LitE (StringL method), func]
buildMethodMap (Resource _ _ Subsite{}) = return Nothing buildMethodMap (Resource _ _ Subsite{}) = return Nothing
{- FIXME -- | Build a single 'D.Route' expression.
let routes = fmap ListE $ mapM toRoute ress buildRoute :: Q Exp -> Q Exp -> Resource -> Q Exp
sub <- newName "sub" buildRoute runHandler dispatcher (Resource name resPieces resDisp) = do
mkey <- newName "mkey" -- First two arguments to D.Route
ts <- newName "ts" routePieces <- ListE <$> mapM convertPiece resPieces
master <- newName "master" isMulti <-
toMaster <- newName "toMaster" case resDisp of
let pats = Methods Nothing _ -> [|False|]
[ VarP sub _ -> [|True|]
, VarP mkey
, VarP ts [|D.Route $(return routePieces) $(return isMulti) $(routeArg3 runHandler dispatcher name resPieces resDisp)|]
, VarP master
, VarP toMaster 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" errorMsg <- [|error "Invariant violated"|]
body <- [|D.toDispatch $(routes)|] let matches =
return $ Clause [ Match pat (NormalB $ DoE stmts) []
pats , Match WildP (NormalB errorMsg) []
(NormalB $ VarE dispatch `AppE` VarE ts `AppE` TupE (map VarE [sub, mkey, master, toMaster])) ]
[FunD dispatch [Clause [] (NormalB body) []]]
where
mkTsPattern :: [Piece] -> Maybe t -> Q ([Name], Maybe Name, Pat) return $ LamE [VarP pieces] $ CaseE (VarE pieces) matches
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)
-- | Convert a 'Piece' into a 'D.Piece'. -- | The final expression in the individual Route definitions.
toPiece :: Piece -> Q Exp buildCaller runHandler dispatcher name resDisp ys = do
toPiece (Static s) = [|D.Static $ pack $(lift s)|] master <- newName "master"
toPiece Dynamic{} = [|D.Dynamic|] sub <- newName "sub"
toMaster <- newName "toMaster"
app404 <- newName "app404"
handler405 <- newName "handler405"
method <- newName "method"
-- | Convert a 'Resource' into a 'D.Route'. let pat = map VarP [master, sub, toMaster, app404, handler405, method]
toRoute :: Resource -> Q Exp
toRoute res = do -- Create the route
let ps = fmap ListE $ mapM toPiece $ resourcePieces res let route = foldl' (\a b -> a `AppE` VarE b) (ConE $ mkName name) ys
let m = maybe [|False|] (const [|True|]) $ resourceMulti res
case resourceDispatch res of exp <-
Methods mmulti mds -> do case resDisp of
let toPair m' = do Methods _ ms -> do
key <- [|pack $(lift m')|] handler <- newName "handler"
let value = VarE $ mkName $ map toLower m' ++ resourceName res
return $ TupE [key, value] -- Figure out what the handler is
let handler = handlerExp <-
if null mds if null ms
then [|Left $(return $ VarE $ mkName $ "handle" ++ resourceName res)|] then return $ foldl' (\a b -> a `AppE` VarE b) (VarE $ mkName $ "handle" ++ name) ys
else [|Right $ Map.fromList $(fmap ListE $ mapM toPair mds)|] else do
sub <- newName "sub" mf <- [|Map.lookup $(return $ VarE method) $(return $ VarE $ methodMapName name)|]
mkey <- newName "mkey" f <- newName "f"
(dyns, mend, tsPattern) <- mkTsPattern (resourcePieces res) mmulti let apply = foldl' (\a b -> a `AppE` VarE b) (VarE f) ys
master <- newName "master" return $ CaseE mf
toMaster <- newName "toMaster" [ Match (ConP 'Just [VarP f]) (NormalB apply) []
body <- [|$(toApp) $(handler)|] , Match (ConP 'Nothing []) (NormalB $ VarE handler405) []
let func = LamE ]
[ tsPattern
, TupP -- Run the whole thing
[ VarP sub runner <- [|$(runHandler)
, VarP mkey $(return $ VarE handler)
, VarP master $(return $ VarE master)
, VarP toMaster $(return $ VarE sub)
] $(return route)
] $(return $ VarE toMaster)|]
body
[|D.Route $(ps) $(m) $(return func)|] return $ LetE [FunD handler [Clause [] (NormalB handlerExp) []]] runner
Subsite _ func -> [|D.Route $(ps) $(m) $ $(toApp) $(return $ VarE $ mkName $ "handle" ++ resourceName res)|] -- FIXME 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|]

33
yesod-routes/test/main.hs
View File

@ -81,22 +81,6 @@ instance RenderRoute MySubParam where
getMySubParam :: MyApp -> Int -> MySubParam getMySubParam :: MyApp -> Int -> MySubParam
getMySubParam _ = 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 class Dispatcher handler master sub app where
dispatcher dispatcher
:: master :: master
@ -117,8 +101,25 @@ class RunHandler handler master sub app where
-> (YRC.Route sub -> YRC.Route master) -> (YRC.Route sub -> YRC.Route master)
-> app -> 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 instance Dispatcher [Char] MyApp MyApp ([Char], Maybe (YRC.Route MyApp)) where
dispatcher = thDispatchAlias dispatcher = thDispatchAlias
--dispatcher = thDispatch
instance RunHandler [Char] MyApp MyApp ([Char], Maybe (YRC.Route MyApp)) where instance RunHandler [Char] MyApp MyApp ([Char], Maybe (YRC.Route MyApp)) where
runHandler h _ _ subRoute toMaster = (h, Just $ toMaster subRoute) runHandler h _ _ subRoute toMaster = (h, Just $ toMaster subRoute)