58 lines
2.3 KiB
Haskell
58 lines
2.3 KiB
Haskell
{-# LANGUAGE RecordWildCards, TemplateHaskell, ViewPatterns #-}
|
|
module Yesod.Routes.TH.Simple where
|
|
|
|
import Yesod.Routes.TH
|
|
import Language.Haskell.TH.Syntax
|
|
import Web.PathPieces
|
|
import Data.Maybe (mapMaybe)
|
|
import Control.Monad (forM)
|
|
import Data.List (foldl')
|
|
import Data.ByteString (ByteString)
|
|
|
|
mkSimpleDispatchClauses :: MkDispatchSettings -> [ResourceTree a] -> Q [Clause]
|
|
mkSimpleDispatchClauses MkDispatchSettings {..} (flatten -> resources) = do
|
|
clauses <- mapM go resources
|
|
clause404 <- mkClause404
|
|
return $ 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) []
|
|
|
|
mkClause404 = 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) []
|