diff --git a/yesod-routes/Yesod/Routes/TH/Dispatch.hs b/yesod-routes/Yesod/Routes/TH/Dispatch.hs index 93dde40b..7914febe 100644 --- a/yesod-routes/Yesod/Routes/TH/Dispatch.hs +++ b/yesod-routes/Yesod/Routes/TH/Dispatch.hs @@ -1,24 +1,20 @@ -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE RecordWildCards, TemplateHaskell, ViewPatterns #-} module Yesod.Routes.TH.Dispatch - ( -- ** Dispatch - mkDispatchClause - , MkDispatchSettings (..) + ( MkDispatchSettings (..) + , mkDispatchClause , defaultGetHandler ) where import Prelude hiding (exp) -import Yesod.Routes.TH.Types import Language.Haskell.TH.Syntax +import Web.PathPieces import Data.Maybe (catMaybes) -import Control.Monad (forM, replicateM) -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 Control.Applicative ((<$>)) +import Control.Monad (forM) import Data.List (foldl') -import Data.Text.Encoding (encodeUtf8) +import Control.Arrow (second) +import System.Random (randomRIO) +import Yesod.Routes.TH.Types +import Data.Char (toLower) data MkDispatchSettings = MkDispatchSettings { mdsRunHandler :: Q Exp @@ -31,340 +27,173 @@ data MkDispatchSettings = MkDispatchSettings , mdsGetHandler :: Maybe String -> String -> Q Exp } +data SDC = SDC + { clause404 :: Clause + , extraParams :: [Exp] + , extraCons :: [Exp] + , envExp :: Exp + , reqExp :: Exp + } + +-- | A simpler version of Yesod.Routes.TH.Dispatch.mkDispatchClause, based on +-- view patterns. +-- +-- Since 1.4.0 +mkDispatchClause :: MkDispatchSettings -> [ResourceTree a] -> Q Clause +mkDispatchClause MkDispatchSettings {..} resources = do + suffix <- qRunIO $ randomRIO (1000, 9999 :: Int) + envName <- newName $ "env" ++ show suffix + reqName <- newName $ "req" ++ show suffix + helperName <- newName $ "helper" ++ show suffix + + let envE = VarE envName + reqE = VarE reqName + helperE = VarE helperName + + clause404' <- mkClause404 envE reqE + getPathInfo <- mdsGetPathInfo + let pathInfo = getPathInfo `AppE` reqE + + let sdc = SDC + { clause404 = clause404' + , extraParams = [] + , extraCons = [] + , envExp = envE + , reqExp = reqE + } + clauses <- mapM (go sdc) resources + + return $ Clause + [VarP envName, VarP reqName] + (NormalB $ helperE `AppE` pathInfo) + [FunD helperName $ clauses ++ [clause404']] + where + handlePiece :: Piece a -> Q (Pat, Maybe Exp) + handlePiece (Static str) = return (LitP $ StringL str, Nothing) + handlePiece (Dynamic _) = do + x <- newName "dyn" + let pat = ViewP (VarE 'fromPathPiece) (ConP 'Just [VarP x]) + return (pat, Just $ VarE x) + + handlePieces :: [Piece a] -> Q ([Pat], [Exp]) + handlePieces = fmap (second catMaybes . unzip) . mapM handlePiece + + mkCon :: String -> [Exp] -> Exp + mkCon name = foldl' AppE (ConE $ mkName name) + + mkPathPat :: Pat -> [Pat] -> Pat + mkPathPat final = + foldr addPat final + where + addPat x y = ConP '(:) [x, y] + + go :: SDC -> ResourceTree a -> Q Clause + go sdc (ResourceParent name _check pieces children) = do + (pats, dyns) <- handlePieces pieces + let sdc' = sdc + { extraParams = extraParams sdc ++ dyns + , extraCons = extraCons sdc ++ [mkCon name dyns] + } + childClauses <- mapM (go sdc') children + + restName <- newName "rest" + let restE = VarE restName + restP = VarP restName + + helperName <- newName $ "helper" ++ name + let helperE = VarE helperName + + return $ Clause + [mkPathPat restP pats] + (NormalB $ helperE `AppE` restE) + [FunD helperName $ childClauses ++ [clause404 sdc]] + go SDC {..} (ResourceLeaf (Resource name pieces dispatch _ _check)) = do + (pats, dyns) <- handlePieces pieces + + (chooseMethod, finalPat) <- handleDispatch dispatch dyns + + return $ Clause + [mkPathPat finalPat pats] + (NormalB chooseMethod) + [] + where + handleDispatch :: Dispatch a -> [Exp] -> Q (Exp, Pat) + handleDispatch dispatch dyns = + case dispatch of + Methods multi methods -> do + (finalPat, mfinalE) <- + case multi of + Nothing -> return (ConP '[] [], Nothing) + Just _ -> do + multiName <- newName "multi" + let pat = ViewP (VarE 'fromPathMultiPiece) + (ConP 'Just [VarP multiName]) + return (pat, Just $ VarE multiName) + + let dynsMulti = + case mfinalE of + Nothing -> dyns + Just e -> dyns ++ [e] + route' = foldl' AppE (ConE (mkName name)) dynsMulti + route = foldr AppE route' extraCons + jroute = ConE 'Just `AppE` route + allDyns = extraParams ++ dynsMulti + mkRunExp mmethod = do + runHandlerE <- mdsRunHandler + handlerE' <- mdsGetHandler mmethod name + let handlerE = foldl' AppE handlerE' allDyns + return $ runHandlerE + `AppE` handlerE + `AppE` envExp + `AppE` jroute + `AppE` reqExp + + func <- + case methods of + [] -> mkRunExp Nothing + _ -> do + getMethod <- mdsMethod + let methodE = getMethod `AppE` reqExp + matches <- forM methods $ \method -> do + exp <- mkRunExp (Just method) + return $ Match (LitP $ StringL method) (NormalB exp) [] + match405 <- do + runHandlerE <- mdsRunHandler + handlerE <- mds405 + let exp = runHandlerE + `AppE` handlerE + `AppE` envExp + `AppE` jroute + `AppE` reqExp + return $ Match WildP (NormalB exp) [] + return $ CaseE methodE $ matches ++ [match405] + + return (func, finalPat) + Subsite _ getSub -> do + restPath <- newName "restPath" + setPathInfoE <- mdsSetPathInfo + subDispatcherE <- mdsSubDispatcher + runHandlerE <- mdsRunHandler + sub <- newName "sub" + let sub2 = LamE [VarP sub] + (foldl' (\a b -> a `AppE` b) (VarE (mkName getSub) `AppE` VarE sub) dyns) + let reqExp' = setPathInfoE `AppE` VarE restPath `AppE` reqExp + route' = foldl' AppE (ConE (mkName name)) dyns + route = foldr AppE route' extraCons + exp = subDispatcherE + `AppE` runHandlerE + `AppE` sub2 + `AppE` route + `AppE` envExp + `AppE` reqExp' + return (exp, VarP restPath) + + mkClause404 envE reqE = do + handler <- mds404 + runHandler <- mdsRunHandler + let exp = runHandler `AppE` handler `AppE` envE `AppE` ConE 'Nothing `AppE` reqE + return $ Clause [WildP] (NormalB exp) [] + defaultGetHandler :: Maybe String -> String -> Q Exp defaultGetHandler Nothing s = return $ VarE $ mkName $ "handle" ++ s defaultGetHandler (Just method) s = return $ VarE $ mkName $ map toLower method ++ s - --- | --- --- This function will generate a single clause that will address all --- your routing needs. It takes four arguments. The fourth (a list of --- 'Resource's) is self-explanatory. We\'ll discuss the first --- three. But first, let\'s cover the terminology. --- --- Dispatching involves a master type and a sub type. When you dispatch to the --- top level type, master and sub are the same. Each time to dispatch to --- another subsite, the sub changes. This requires two changes: --- --- * Getting the new sub value. This is handled via 'subsiteFunc'. --- --- * Figure out a way to convert sub routes to the original master route. To --- address this, we keep a toMaster function, and each time we dispatch to a --- new subsite, we compose it with the constructor for that subsite. --- --- Dispatching acts on two different components: the request method and a list --- of path pieces. If we cannot match the path pieces, we need to return a 404 --- response. If the path pieces match, but the method is not supported, we need --- to return a 405 response. --- --- The final result of dispatch is going to be an application type. A simple --- example would be the WAI Application type. However, our handler functions --- will need more input: the master/subsite, the toMaster function, and the --- type-safe route. Therefore, we need to have another type, the handler type, --- and a function that turns a handler into an application, i.e. --- --- > runHandler :: handler sub master -> master -> sub -> Route sub -> (Route sub -> Route master) -> app --- --- This is the first argument to our function. Note that this will almost --- certainly need to be a method of a typeclass, since it will want to behave --- differently based on the subsite. --- --- Note that the 404 response passed in is an application, while the 405 --- response is a handler, since the former can\'t be passed the type-safe --- route. --- --- In the case of a subsite, we don\'t directly deal with a handler function. --- Instead, we redispatch to the subsite, passing on the updated sub value and --- toMaster function, as well as any remaining, unparsed path pieces. This --- function looks like: --- --- > dispatcher :: master -> sub -> (Route sub -> Route master) -> app -> handler sub master -> Text -> [Text] -> app --- --- Where the parameters mean master, sub, toMaster, 404 response, 405 response, --- request method and path pieces. This is the second argument of our function. --- --- Finally, we need a way to decide which of the possible formats --- should the handler send the data out. Think of each URL holding an --- abstract object which has multiple representation (JSON, plain HTML --- etc). Each client might have a preference on which format it wants --- the abstract object in. For example, a javascript making a request --- (on behalf of a browser) might prefer a JSON object over a plain --- HTML file where as a user browsing with javascript disabled would --- want the page in HTML. The third argument is a function that --- converts the abstract object to the desired representation --- depending on the preferences sent by the client. --- --- The typical values for the first three arguments are, --- @'yesodRunner'@ for the first, @'yesodDispatch'@ for the second and --- @fmap 'chooseRep'@. - -mkDispatchClause :: MkDispatchSettings - -> [ResourceTree a] - -> Q Clause -mkDispatchClause mds 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. - getEnv0 <- newName "yesod_dispatch_env0" - req0 <- newName "req0" - pieces <- [|$(mdsGetPathInfo mds) $(return $ VarE req0)|] - - -- Name of the dispatch function - dispatch <- newName "dispatch" - - -- Dispatch function applied to the pieces - let dispatched = VarE dispatch `AppE` pieces - - -- The 'D.Route's used in the dispatch function - routes <- mapM (buildRoute mds) 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 [getEnv0, req0] - - -- For each resource that dispatches based on methods, build up a map for handling the dispatching. - methodMaps <- catMaybes <$> mapM (buildMethodMap mds) ress - - u <- [|case $(return dispatched) of - Just f -> f $(return $ VarE getEnv0) - $(return $ VarE req0) - Nothing -> $(mdsRunHandler mds) - $(mds404 mds) - $(return $ VarE getEnv0) - Nothing - $(return $ VarE req0) - |] - return $ Clause pats (NormalB u) $ dispatchFun : methodMaps - where - ress = flatten ress' - --- | Determine the name of the method map for a given resource name. -methodMapName :: String -> Name -methodMapName s = mkName $ "methods" ++ s - -buildMethodMap :: MkDispatchSettings - -> FlatResource a - -> Q (Maybe Dec) -buildMethodMap _ (FlatResource _ _ _ (Methods _ []) _) = return Nothing -- single handle function -buildMethodMap mds (FlatResource parents name pieces' (Methods mmulti methods) _check) = do - fromList <- [|Map.fromList|] - methods' <- mapM go methods - let exp = fromList `AppE` ListE methods' - let fun = FunD (methodMapName name) [Clause [] (NormalB exp) []] - return $ Just fun - where - pieces = concat $ map snd parents ++ [pieces'] - go method = do - func <- mdsGetHandler mds (Just method) name - pack' <- [|encodeUtf8 . pack|] - let isDynamic Dynamic{} = True - isDynamic _ = False - let argCount = length (filter isDynamic pieces) + maybe 0 (const 1) mmulti - xs <- replicateM argCount $ newName "arg" - runHandler <- mdsRunHandler mds - let rhs - | null xs = runHandler `AppE` func - | otherwise = - LamE (map VarP xs) $ - runHandler `AppE` (foldl' AppE func $ map VarE xs) - return $ TupE - [ pack' `AppE` LitE (StringL method) - , rhs - ] -buildMethodMap _ (FlatResource _ _ _ Subsite{} _check) = return Nothing - --- | Build a single 'D.Route' expression. -buildRoute :: MkDispatchSettings -> FlatResource a -> Q Exp -buildRoute mds (FlatResource parents name resPieces resDisp _) = do - -- First two arguments to D.Route - routePieces <- ListE <$> mapM convertPiece allPieces - isMulti <- - case resDisp of - Methods Nothing _ -> [|False|] - _ -> [|True|] - - [|D.Route - $(return routePieces) - $(return isMulti) - $(routeArg3 - mds - parents - name - allPieces - resDisp) - |] - where - allPieces = concat $ map snd parents ++ [resPieces] - -routeArg3 :: MkDispatchSettings - -> [(String, [Piece a])] - -> String -- ^ name of resource - -> [Piece a] - -> Dispatch a - -> Q Exp -routeArg3 mds parents 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" - - -- Note: the zipping with Ints is just a workaround for (apparently) a bug - -- in GHC where the identifiers are considered to be overlapping. Using - -- newName should avoid the problem, but it doesn't. - ys <- forM (zip (catMaybes xs) [1..]) $ \(x, i) -> do - y <- newName $ "y" ++ show (i :: Int) - 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 mds xrest parents name resDisp $ map snd ys ++ yrest' - - -- Put together all the statements - just <- [|Just|] - let stmts = concat - [ xstmts - , reststmts - , [NoBindS $ just `AppE` caller] - ] - - errorMsg <- [|error "Invariant violated"|] - let matches = - [ Match pat (NormalB $ DoE stmts) [] - , Match WildP (NormalB errorMsg) [] - ] - - return $ LamE [VarP pieces] $ CaseE (VarE pieces) matches - --- | The final expression in the individual Route definitions. -buildCaller :: MkDispatchSettings - -> Name -- ^ xrest - -> [(String, [Piece a])] - -> String -- ^ name of resource - -> Dispatch a - -> [Name] -- ^ ys - -> Q Exp -buildCaller mds xrest parents name resDisp ys = do - getEnv <- newName "yesod_dispatch_env" - req <- newName "req" - - method <- [|$(mdsMethod mds) $(return $ VarE req)|] - - let pat = map VarP [getEnv, req] - - -- Create the route - let route = routeFromDynamics parents name ys - - exp <- - case resDisp of - Methods _ ms -> do - handler <- newName "handler" - - env <- [|$(return $ VarE getEnv) (Just $(return route))|] - - -- Run the whole thing - runner <- [|$(return $ VarE handler) - $(return $ VarE getEnv) - (Just $(return route)) - $(return $ VarE req) - |] - - let myLet handlerExp = - LetE [FunD handler [Clause [] (NormalB handlerExp) []]] runner - - if null ms - then do - -- Just a single handler - base <- mdsGetHandler mds Nothing name - let he = foldl' (\a b -> a `AppE` VarE b) base ys - runHandler <- mdsRunHandler mds - return $ myLet $ runHandler `AppE` he - else do - -- Individual methods - mf <- [|Map.lookup $(return method) $(return $ VarE $ methodMapName name)|] - f <- newName "f" - let apply = foldl' (\a b -> a `AppE` VarE b) (VarE f) ys - body405 <- - [|$(mdsRunHandler mds) - $(mds405 mds) - $(return $ VarE getEnv) - (Just $(return route)) - $(return $ VarE req) - |] - return $ CaseE mf - [ Match (ConP 'Just [VarP f]) (NormalB $ myLet apply) [] - , Match (ConP 'Nothing []) (NormalB body405) [] - ] - - Subsite _ getSub -> do - sub <- newName "sub" - let sub2 = LamE [VarP sub] - (foldl' (\a b -> a `AppE` VarE b) (VarE (mkName getSub) `AppE` VarE sub) ys) - [|$(mdsSubDispatcher mds) - $(mdsRunHandler mds) - $(return sub2) - $(return route) - $(return $ VarE getEnv) - ($(mdsSetPathInfo mds) - $(return $ VarE xrest) - $(return $ VarE req) - ) - |] - - return $ LamE pat exp - --- | Convert a 'Piece' to a 'D.Piece' -convertPiece :: Piece a -> Q Exp -convertPiece (Static s) = [|D.Static (pack $(lift s))|] -convertPiece (Dynamic _) = [|D.Dynamic|] - -routeFromDynamics :: [(String, [Piece a])] -- ^ parents - -> String -- ^ constructor name - -> [Name] - -> Exp -routeFromDynamics [] name ys = foldl' (\a b -> a `AppE` VarE b) (ConE $ mkName name) ys -routeFromDynamics ((parent, pieces):rest) name ys = - foldl' (\a b -> a `AppE` b) (ConE $ mkName parent) here - where - (here', ys') = splitAt (length $ filter isDynamic pieces) ys - isDynamic Dynamic{} = True - isDynamic _ = False - here = map VarE here' ++ [routeFromDynamics rest name ys'] diff --git a/yesod-routes/Yesod/Routes/TH/Simple.hs b/yesod-routes/Yesod/Routes/TH/Simple.hs deleted file mode 100644 index 62ba97b4..00000000 --- a/yesod-routes/Yesod/Routes/TH/Simple.hs +++ /dev/null @@ -1,179 +0,0 @@ -{-# LANGUAGE RecordWildCards, TemplateHaskell, ViewPatterns #-} -module Yesod.Routes.TH.Simple where - -import Prelude hiding (exp) -import Yesod.Routes.TH -import Language.Haskell.TH.Syntax -import Web.PathPieces -import Data.Maybe (catMaybes) -import Control.Monad (forM) -import Data.List (foldl') -import Control.Arrow (second) -import System.Random (randomRIO) - -data SDC = SDC - { clause404 :: Clause - , extraParams :: [Exp] - , extraCons :: [Exp] - , envExp :: Exp - , reqExp :: Exp - } - --- | A simpler version of Yesod.Routes.TH.Dispatch.mkDispatchClause, based on --- view patterns. --- --- Since 1.2.1 -mkSimpleDispatchClause :: MkDispatchSettings -> [ResourceTree a] -> Q Clause -mkSimpleDispatchClause MkDispatchSettings {..} resources = do - suffix <- qRunIO $ randomRIO (1000, 9999 :: Int) - envName <- newName $ "env" ++ show suffix - reqName <- newName $ "req" ++ show suffix - helperName <- newName $ "helper" ++ show suffix - - let envE = VarE envName - reqE = VarE reqName - helperE = VarE helperName - - clause404' <- mkClause404 envE reqE - getPathInfo <- mdsGetPathInfo - let pathInfo = getPathInfo `AppE` reqE - - let sdc = SDC - { clause404 = clause404' - , extraParams = [] - , extraCons = [] - , envExp = envE - , reqExp = reqE - } - clauses <- mapM (go sdc) resources - - return $ Clause - [VarP envName, VarP reqName] - (NormalB $ helperE `AppE` pathInfo) - [FunD helperName $ clauses ++ [clause404']] - where - handlePiece :: Piece a -> Q (Pat, Maybe Exp) - handlePiece (Static str) = return (LitP $ StringL str, Nothing) - handlePiece (Dynamic _) = do - x <- newName "dyn" - let pat = ViewP (VarE 'fromPathPiece) (ConP 'Just [VarP x]) - return (pat, Just $ VarE x) - - handlePieces :: [Piece a] -> Q ([Pat], [Exp]) - handlePieces = fmap (second catMaybes . unzip) . mapM handlePiece - - mkCon :: String -> [Exp] -> Exp - mkCon name = foldl' AppE (ConE $ mkName name) - - mkPathPat :: Pat -> [Pat] -> Pat - mkPathPat final = - foldr addPat final - where - addPat x y = ConP '(:) [x, y] - - go :: SDC -> ResourceTree a -> Q Clause - go sdc (ResourceParent name _check pieces children) = do - (pats, dyns) <- handlePieces pieces - let sdc' = sdc - { extraParams = extraParams sdc ++ dyns - , extraCons = extraCons sdc ++ [mkCon name dyns] - } - childClauses <- mapM (go sdc') children - - restName <- newName "rest" - let restE = VarE restName - restP = VarP restName - - helperName <- newName $ "helper" ++ name - let helperE = VarE helperName - - return $ Clause - [mkPathPat restP pats] - (NormalB $ helperE `AppE` restE) - [FunD helperName $ childClauses ++ [clause404 sdc]] - go SDC {..} (ResourceLeaf (Resource name pieces dispatch _ _check)) = do - (pats, dyns) <- handlePieces pieces - - (chooseMethod, finalPat) <- handleDispatch dispatch dyns - - return $ Clause - [mkPathPat finalPat pats] - (NormalB chooseMethod) - [] - where - handleDispatch :: Dispatch a -> [Exp] -> Q (Exp, Pat) - handleDispatch dispatch dyns = - case dispatch of - Methods multi methods -> do - (finalPat, mfinalE) <- - case multi of - Nothing -> return (ConP '[] [], Nothing) - Just _ -> do - multiName <- newName "multi" - let pat = ViewP (VarE 'fromPathMultiPiece) - (ConP 'Just [VarP multiName]) - return (pat, Just $ VarE multiName) - - let dynsMulti = - case mfinalE of - Nothing -> dyns - Just e -> dyns ++ [e] - route' = foldl' AppE (ConE (mkName name)) dynsMulti - route = foldr AppE route' extraCons - jroute = ConE 'Just `AppE` route - allDyns = extraParams ++ dynsMulti - mkRunExp mmethod = do - runHandlerE <- mdsRunHandler - handlerE' <- mdsGetHandler mmethod name - let handlerE = foldl' AppE handlerE' allDyns - return $ runHandlerE - `AppE` handlerE - `AppE` envExp - `AppE` jroute - `AppE` reqExp - - func <- - case methods of - [] -> mkRunExp Nothing - _ -> do - getMethod <- mdsMethod - let methodE = getMethod `AppE` reqExp - matches <- forM methods $ \method -> do - exp <- mkRunExp (Just method) - return $ Match (LitP $ StringL method) (NormalB exp) [] - match405 <- do - runHandlerE <- mdsRunHandler - handlerE <- mds405 - let exp = runHandlerE - `AppE` handlerE - `AppE` envExp - `AppE` jroute - `AppE` reqExp - return $ Match WildP (NormalB exp) [] - return $ CaseE methodE $ matches ++ [match405] - - return (func, finalPat) - Subsite _ getSub -> do - restPath <- newName "restPath" - setPathInfoE <- mdsSetPathInfo - subDispatcherE <- mdsSubDispatcher - runHandlerE <- mdsRunHandler - sub <- newName "sub" - let sub2 = LamE [VarP sub] - (foldl' (\a b -> a `AppE` b) (VarE (mkName getSub) `AppE` VarE sub) dyns) - let reqExp' = setPathInfoE `AppE` VarE restPath `AppE` reqExp - route' = foldl' AppE (ConE (mkName name)) dyns - route = foldr AppE route' extraCons - exp = subDispatcherE - `AppE` runHandlerE - `AppE` sub2 - `AppE` route - `AppE` envExp - `AppE` reqExp' - return (exp, VarP restPath) - - mkClause404 envE reqE = do - handler <- mds404 - runHandler <- mdsRunHandler - let exp = runHandler `AppE` handler `AppE` envE `AppE` ConE 'Nothing `AppE` reqE - return $ Clause [WildP] (NormalB exp) [] diff --git a/yesod-routes/test/Hierarchy.hs b/yesod-routes/test/Hierarchy.hs index 9268c2e1..c19935b7 100644 --- a/yesod-routes/test/Hierarchy.hs +++ b/yesod-routes/test/Hierarchy.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} @@ -29,9 +28,6 @@ import qualified Yesod.Routes.Class as YRC import Data.Text (Text, pack, unpack, append) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as S8 -#if SIMPLE_DISPATCH -import Yesod.Routes.TH.Simple -#endif import qualified Data.Set as Set class ToText a where @@ -115,11 +111,7 @@ do rrinst <- mkRenderRouteInstance (ConT ''Hierarchy) $ map (fmap parseType) resources rainst <- mkRouteAttrsInstance (ConT ''Hierarchy) $ map (fmap parseType) resources prinst <- mkParseRouteInstance (ConT ''Hierarchy) $ map (fmap parseType) resources -#if SIMPLE_DISPATCH - dispatch <- mkSimpleDispatchClause MkDispatchSettings -#else dispatch <- mkDispatchClause MkDispatchSettings -#endif { mdsRunHandler = [|runHandler|] , mdsSubDispatcher = [|subDispatch|] , mdsGetPathInfo = [|fst|] diff --git a/yesod-routes/test/main.hs b/yesod-routes/test/main.hs index f782590e..7e2a031d 100644 --- a/yesod-routes/test/main.hs +++ b/yesod-routes/test/main.hs @@ -26,9 +26,6 @@ import Language.Haskell.TH.Syntax import Hierarchy import qualified Data.ByteString.Char8 as S8 import qualified Data.Set as Set -#if SIMPLE_DISPATCH -import Yesod.Routes.TH.Simple -#endif result :: ([Text] -> Maybe Int) -> Dispatch Int result f ts = f ts @@ -130,11 +127,7 @@ do rrinst <- mkRenderRouteInstance (ConT ''MyApp) ress rainst <- mkRouteAttrsInstance (ConT ''MyApp) ress prinst <- mkParseRouteInstance (ConT ''MyApp) ress -#if SIMPLE_DISPATCH - dispatch <- mkSimpleDispatchClause MkDispatchSettings -#else dispatch <- mkDispatchClause MkDispatchSettings -#endif { mdsRunHandler = [|runHandler|] , mdsSubDispatcher = [|subDispatch dispatcher|] , mdsGetPathInfo = [|fst|] diff --git a/yesod-routes/yesod-routes.cabal b/yesod-routes/yesod-routes.cabal index 3ae67e54..5d0ae04f 100644 --- a/yesod-routes/yesod-routes.cabal +++ b/yesod-routes/yesod-routes.cabal @@ -26,7 +26,6 @@ library exposed-modules: Yesod.Routes.Dispatch Yesod.Routes.TH - Yesod.Routes.TH.Simple Yesod.Routes.Class Yesod.Routes.Parse Yesod.Routes.Overlap