Remove old dispatch method
This commit is contained in:
Michael Snoyman
parent
8cbcc5fab3
commit
a1ea34f196
@ -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']
|
||||
|
||||
@ -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) []
|
||||
@ -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|]
|
||||
|
||||
@ -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|]
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user