All simpler dispatch tests pass
This commit is contained in:
Michael Snoyman
parent
9fad1071fc
commit
750bc9c9ac
@ -1,57 +1,175 @@
|
||||
{-# 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 (mapMaybe)
|
||||
import Data.Maybe (mapMaybe, catMaybes)
|
||||
import Control.Monad (forM)
|
||||
import Data.List (foldl')
|
||||
import Data.ByteString (ByteString)
|
||||
import Control.Arrow (second)
|
||||
|
||||
mkSimpleDispatchClauses :: MkDispatchSettings -> [ResourceTree a] -> Q [Clause]
|
||||
mkSimpleDispatchClauses MkDispatchSettings {..} (flatten -> resources) = do
|
||||
clauses <- mapM go resources
|
||||
clause404 <- mkClause404
|
||||
return $ clauses ++ [clause404]
|
||||
data SDC = SDC
|
||||
{ clause404 :: Clause
|
||||
, extraParams :: [Exp]
|
||||
, extraCons :: [Exp]
|
||||
, envExp :: Exp
|
||||
, reqExp :: Exp
|
||||
}
|
||||
|
||||
mkSimpleDispatchClause :: MkDispatchSettings -> [ResourceTree a] -> Q Clause
|
||||
mkSimpleDispatchClause MkDispatchSettings {..} resources = do
|
||||
envName <- newName "env"
|
||||
reqName <- newName "req"
|
||||
helperName <- newName "helper"
|
||||
|
||||
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
|
||||
go (FlatResource _ name pieces dispatch) = do
|
||||
let env = VarE $ mkName "env"
|
||||
req = VarE $ mkName "req"
|
||||
gpi <- mdsGetPathInfo
|
||||
gm <- mdsMethod
|
||||
let handlePiece (_, Static str) = return (LitP $ StringL str, Nothing)
|
||||
handlePiece (_, Dynamic _) = do
|
||||
x <- newName "x"
|
||||
let pat = ViewP (VarE 'fromPathPiece) (ConP 'Just [VarP x])
|
||||
return (pat, Just x)
|
||||
pairs <- mapM handlePiece pieces
|
||||
let pats = map fst pairs
|
||||
names = mapMaybe snd pairs
|
||||
runHandler <- mdsRunHandler
|
||||
let route = foldl' AppE (ConE (mkName name)) (map VarE names)
|
||||
exp <- case dispatch of
|
||||
Methods _ [] -> error "no methods"
|
||||
Methods _ methods -> do
|
||||
matches <- forM methods $ \method -> do
|
||||
handler' <- mdsGetHandler (Just method) name
|
||||
let handler = foldl' AppE handler' (map VarE names)
|
||||
let body = NormalB exp
|
||||
jroute = ConE 'Just `AppE` route
|
||||
exp = runHandler `AppE` handler `AppE` env `AppE` jroute `AppE` req
|
||||
return $ Match (LitP $ StringL method) body []
|
||||
let method = SigE (gm `AppE` req) (ConT ''ByteString)
|
||||
return $ CaseE method matches
|
||||
return $ Clause
|
||||
[ VarP $ mkName "env"
|
||||
, AsP (mkName "req") (ViewP gpi (ListP pats))
|
||||
] (NormalB exp) []
|
||||
handlePiece :: (CheckOverlap, 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)
|
||||
|
||||
mkClause404 = do
|
||||
handlePieces :: [(CheckOverlap, 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 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"
|
||||
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 _)) = 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
|
||||
getEnv = LitE $ StringL "FIXME2"
|
||||
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` VarE (mkName "env") `AppE` ConE 'Nothing `AppE` VarE (mkName "req")
|
||||
return $ Clause
|
||||
[ VarP (mkName "env")
|
||||
, VarP (mkName "req")
|
||||
] (NormalB exp) []
|
||||
let exp = runHandler `AppE` handler `AppE` envE `AppE` ConE 'Nothing `AppE` reqE
|
||||
return $ Clause [WildP] (NormalB exp) []
|
||||
|
||||
@ -7,6 +7,7 @@
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
module Hierarchy
|
||||
( hierarchy
|
||||
, Dispatcher (..)
|
||||
@ -113,9 +114,9 @@ do
|
||||
rrinst <- mkRenderRouteInstance (ConT ''Hierarchy) $ map (fmap parseType) resources
|
||||
prinst <- mkParseRouteInstance (ConT ''Hierarchy) $ map (fmap parseType) resources
|
||||
#if SIMPLE_DISPATCH
|
||||
dispatch <- mkSimpleDispatchClauses MkDispatchSettings
|
||||
dispatch <- mkSimpleDispatchClause MkDispatchSettings
|
||||
#else
|
||||
dispatch <- fmap return $ mkDispatchClause MkDispatchSettings
|
||||
dispatch <- mkDispatchClause MkDispatchSettings
|
||||
#endif
|
||||
{ mdsRunHandler = [|runHandler|]
|
||||
, mdsSubDispatcher = [|subDispatch|]
|
||||
@ -132,7 +133,7 @@ do
|
||||
(ConT ''Dispatcher
|
||||
`AppT` ConT ''Hierarchy
|
||||
`AppT` ConT ''Hierarchy)
|
||||
[FunD (mkName "dispatcher") dispatch]
|
||||
[FunD (mkName "dispatcher") [dispatch]]
|
||||
: prinst
|
||||
: rrinst
|
||||
|
||||
|
||||
@ -10,6 +10,8 @@
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# OPTIONS_GHC -ddump-splices #-}
|
||||
import Test.Hspec
|
||||
import Test.HUnit ((@?=))
|
||||
import Data.Text (Text, pack, unpack, singleton)
|
||||
@ -129,9 +131,9 @@ do
|
||||
rainst <- mkRouteAttrsInstance (ConT ''MyApp) ress
|
||||
prinst <- mkParseRouteInstance (ConT ''MyApp) ress
|
||||
#if SIMPLE_DISPATCH
|
||||
dispatch <- mkSimpleDispatchClauses MkDispatchSettings
|
||||
dispatch <- mkSimpleDispatchClause MkDispatchSettings
|
||||
#else
|
||||
dispatch <- fmap return $ mkDispatchClause MkDispatchSettings
|
||||
dispatch <- mkDispatchClause MkDispatchSettings
|
||||
#endif
|
||||
{ mdsRunHandler = [|runHandler|]
|
||||
, mdsSubDispatcher = [|subDispatch dispatcher|]
|
||||
@ -148,7 +150,7 @@ do
|
||||
(ConT ''Dispatcher
|
||||
`AppT` ConT ''MyApp
|
||||
`AppT` ConT ''MyApp)
|
||||
[FunD (mkName "dispatcher") dispatch]
|
||||
[FunD (mkName "dispatcher") [dispatch]]
|
||||
: prinst
|
||||
: rainst
|
||||
: rrinst
|
||||
|
||||
Loading…
Reference in New Issue
Block a user