diff --git a/yesod-routes/Yesod/Routes/TH/Dispatch.hs b/yesod-routes/Yesod/Routes/TH/Dispatch.hs index 35b15249..d017d2d6 100644 --- a/yesod-routes/Yesod/Routes/TH/Dispatch.hs +++ b/yesod-routes/Yesod/Routes/TH/Dispatch.hs @@ -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|] diff --git a/yesod-routes/test/main.hs b/yesod-routes/test/main.hs index 9d3fd20f..2a0184b2 100644 --- a/yesod-routes/test/main.hs +++ b/yesod-routes/test/main.hs @@ -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)