module Yesod.Routes.TH.Dispatch
(
mkDispatchClause
) where
import Prelude hiding (exp)
import Yesod.Routes.TH.Types
import Language.Haskell.TH.Syntax
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 Data.List (foldl')
data FlatResource a = FlatResource [(String, [(CheckOverlap, Piece a)])] String [(CheckOverlap, Piece a)] (Dispatch a)
flatten :: [ResourceTree a] -> [FlatResource a]
flatten =
concatMap (go id)
where
go front (ResourceLeaf (Resource a b c)) = [FlatResource (front []) a b c]
go front (ResourceParent name pieces children) =
concatMap (go (front . ((name, pieces):))) children
mkDispatchClause :: Q Exp
-> Q Exp
-> Q Exp
-> [ResourceTree a]
-> Q Clause
mkDispatchClause runHandler dispatcher fixHandler ress' = do
master0 <- newName "master0"
sub0 <- newName "sub0"
toMaster0 <- newName "toMaster0"
app4040 <- newName "app4040"
handler4050 <- newName "handler4050"
method0 <- newName "method0"
pieces0 <- newName "pieces0"
dispatch <- newName "dispatch"
let dispatched = VarE dispatch `AppE` VarE pieces0
routes <- mapM (buildRoute runHandler dispatcher fixHandler) ress
toDispatch <- [|D.toDispatch|]
let dispatchFun = FunD dispatch [Clause [] (NormalB $ toDispatch `AppE` ListE routes) []]
let pats = map VarP [master0, sub0, toMaster0, app4040, handler4050, method0, pieces0]
methodMaps <- catMaybes <$> mapM (buildMethodMap fixHandler) ress
u <- [|case $(return dispatched) of
Just f -> f $(return $ VarE master0)
$(return $ VarE sub0)
$(return $ VarE toMaster0)
$(return $ VarE app4040)
$(return $ VarE handler4050)
$(return $ VarE method0)
Nothing -> $(return $ VarE app4040)
|]
return $ Clause pats (NormalB u) $ dispatchFun : methodMaps
where
ress = flatten ress'
methodMapName :: String -> Name
methodMapName s = mkName $ "methods" ++ s
buildMethodMap :: Q Exp
-> FlatResource a
-> Q (Maybe Dec)
buildMethodMap _ (FlatResource _ _ _ (Methods _ [])) = return Nothing
buildMethodMap fixHandler (FlatResource parents name pieces' (Methods mmulti methods)) = 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
fh <- fixHandler
let func = VarE $ mkName $ map toLower method ++ name
pack' <- [|pack|]
let isDynamic Dynamic{} = True
isDynamic _ = False
let argCount = length (filter (isDynamic . snd) pieces) + maybe 0 (const 1) mmulti
xs <- replicateM argCount $ newName "arg"
let rhs = LamE (map VarP xs) $ fh `AppE` (foldl' AppE func $ map VarE xs)
return $ TupE [pack' `AppE` LitE (StringL method), rhs]
buildMethodMap _ (FlatResource _ _ _ Subsite{}) = return Nothing
buildRoute :: Q Exp -> Q Exp -> Q Exp -> FlatResource a -> Q Exp
buildRoute runHandler dispatcher fixHandler (FlatResource parents name resPieces resDisp) = do
routePieces <- ListE <$> mapM (convertPiece . snd) allPieces
isMulti <-
case resDisp of
Methods Nothing _ -> [|False|]
_ -> [|True|]
[|D.Route $(return routePieces) $(return isMulti) $(routeArg3 runHandler dispatcher fixHandler parents name (map snd allPieces) resDisp)|]
where
allPieces = concat $ map snd parents ++ [resPieces]
routeArg3 :: Q Exp
-> Q Exp
-> Q Exp
-> [(String, [(CheckOverlap, Piece a)])]
-> String
-> [Piece a]
-> Dispatch a
-> Q Exp
routeArg3 runHandler dispatcher fixHandler parents name resPieces resDisp = do
pieces <- newName "pieces"
xs <- forM resPieces $ \piece ->
case piece of
Static _ -> return Nothing
Dynamic _ -> Just <$> newName "x"
ys <- forM (zip (catMaybes xs) [1..]) $ \(x, i) -> do
y <- newName $ "y" ++ show (i :: Int)
return (x, y)
xrest <- newName "xrest"
yrest <- newName "yrest"
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
fromPathPiece' <- [|fromPathPiece|]
xstmts <- forM ys $ \(x, y) -> return $ BindS (VarP y) (fromPathPiece' `AppE` VarE x)
(reststmts, yrest') <-
case resDisp of
Methods (Just _) _ -> do
fromPathMultiPiece' <- [|fromPathMultiPiece|]
return ([BindS (VarP yrest) (fromPathMultiPiece' `AppE` VarE xrest)], [yrest])
_ -> return ([], [])
caller <- buildCaller runHandler dispatcher fixHandler xrest parents name resDisp $ map snd ys ++ yrest'
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
buildCaller :: Q Exp
-> Q Exp
-> Q Exp
-> Name
-> [(String, [(CheckOverlap, Piece a)])]
-> String
-> Dispatch a
-> [Name]
-> Q Exp
buildCaller runHandler dispatcher fixHandler xrest parents name resDisp ys = do
master <- newName "master"
sub <- newName "sub"
toMaster <- newName "toMaster"
app404 <- newName "_app404"
handler405 <- newName "_handler405"
method <- newName "_method"
let pat = map VarP [master, sub, toMaster, app404, handler405, method]
let route = routeFromDynamics parents name ys
exp <-
case resDisp of
Methods _ ms -> do
handler <- newName "handler"
runner <- [|$(runHandler)
$(return $ VarE handler)
$(return $ VarE master)
$(return $ VarE sub)
(Just $(return route))
$(return $ VarE toMaster)|]
let myLet handlerExp =
LetE [FunD handler [Clause [] (NormalB handlerExp) []]] runner
if null ms
then do
fh <- fixHandler
let he = fh `AppE` foldl' (\a b -> a `AppE` VarE b) (VarE $ mkName $ "handle" ++ name) ys
return $ myLet he
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
let body405 =
VarE handler405
`AppE` route
return $ CaseE mf
[ Match (ConP 'Just [VarP f]) (NormalB $ myLet apply) []
, Match (ConP 'Nothing []) (NormalB body405) []
]
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 route))
$(return $ VarE method)
$(return $ VarE xrest)
|]
return $ LamE pat exp
convertPiece :: Piece a -> Q Exp
convertPiece (Static s) = [|D.Static (pack $(lift s))|]
convertPiece (Dynamic _) = [|D.Dynamic|]
routeFromDynamics :: [(String, [(CheckOverlap, Piece a)])]
-> String
-> [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 . snd) pieces) ys
isDynamic Dynamic{} = True
isDynamic _ = False
here = map VarE here' ++ [routeFromDynamics rest name ys']