{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}
module Yesod.Routes.TH.Dispatch
( MkDispatchSettings (..)
, mkDispatchClause
, defaultGetHandler
) where
import Prelude hiding (exp)
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)
import Yesod.Routes.TH.Types
import Data.Char (toLower)
data MkDispatchSettings b site c = MkDispatchSettings
{ forall b site c. MkDispatchSettings b site c -> Q Exp
mdsRunHandler :: Q Exp
, forall b site c. MkDispatchSettings b site c -> Q Exp
mdsSubDispatcher :: Q Exp
, forall b site c. MkDispatchSettings b site c -> Q Exp
mdsGetPathInfo :: Q Exp
, forall b site c. MkDispatchSettings b site c -> Q Exp
mdsSetPathInfo :: Q Exp
, forall b site c. MkDispatchSettings b site c -> Q Exp
mdsMethod :: Q Exp
, forall b site c. MkDispatchSettings b site c -> Q Exp
mds404 :: Q Exp
, forall b site c. MkDispatchSettings b site c -> Q Exp
mds405 :: Q Exp
, forall b site c.
MkDispatchSettings b site c -> Maybe String -> String -> Q Exp
mdsGetHandler :: Maybe String -> String -> Q Exp
, forall b site c. MkDispatchSettings b site c -> Exp -> Q Exp
mdsUnwrapper :: Exp -> Q Exp
}
data SDC = SDC
{ SDC -> Clause
clause404 :: Clause
, :: [Exp]
, :: [Exp]
, SDC -> Exp
envExp :: Exp
, SDC -> Exp
reqExp :: Exp
}
mkDispatchClause :: MkDispatchSettings b site c -> [ResourceTree a] -> Q Clause
mkDispatchClause :: forall b site c a.
MkDispatchSettings b site c -> [ResourceTree a] -> Q Clause
mkDispatchClause MkDispatchSettings {Q Exp
Maybe String -> String -> Q Exp
Exp -> Q Exp
mdsRunHandler :: forall b site c. MkDispatchSettings b site c -> Q Exp
mdsSubDispatcher :: forall b site c. MkDispatchSettings b site c -> Q Exp
mdsGetPathInfo :: forall b site c. MkDispatchSettings b site c -> Q Exp
mdsSetPathInfo :: forall b site c. MkDispatchSettings b site c -> Q Exp
mdsMethod :: forall b site c. MkDispatchSettings b site c -> Q Exp
mds404 :: forall b site c. MkDispatchSettings b site c -> Q Exp
mds405 :: forall b site c. MkDispatchSettings b site c -> Q Exp
mdsGetHandler :: forall b site c.
MkDispatchSettings b site c -> Maybe String -> String -> Q Exp
mdsUnwrapper :: forall b site c. MkDispatchSettings b site c -> Exp -> Q Exp
mdsRunHandler :: Q Exp
mdsSubDispatcher :: Q Exp
mdsGetPathInfo :: Q Exp
mdsSetPathInfo :: Q Exp
mdsMethod :: Q Exp
mds404 :: Q Exp
mds405 :: Q Exp
mdsGetHandler :: Maybe String -> String -> Q Exp
mdsUnwrapper :: Exp -> Q Exp
..} [ResourceTree a]
resources = do
suffix <- IO Int -> Q Int
forall a. IO a -> Q a
forall (m :: * -> *) a. Quasi m => IO a -> m a
qRunIO (IO Int -> Q Int) -> IO Int -> Q Int
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> IO Int
forall a (m :: * -> *). (Random a, MonadIO m) => (a, a) -> m a
randomRIO (Int
1000, Int
9999 :: Int)
envName <- newName $ "env" ++ show suffix
reqName <- newName $ "req" ++ show suffix
helperName <- newName $ "helper" ++ show suffix
let envE = Name -> Exp
VarE Name
envName
reqE = Name -> Exp
VarE Name
reqName
helperE = Name -> Exp
VarE Name
helperName
clause404' <- mkClause404 envE reqE
getPathInfo <- mdsGetPathInfo
let pathInfo = Exp
getPathInfo Exp -> Exp -> Exp
`AppE` Exp
reqE
let sdc = SDC
{ clause404 :: Clause
clause404 = Clause
clause404'
, extraParams :: [Exp]
extraParams = []
, extraCons :: [Exp]
extraCons = []
, envExp :: Exp
envExp = Exp
envE
, reqExp :: Exp
reqExp = Exp
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 :: forall a. Piece a -> Q (Pat, Maybe Exp)
handlePiece (Static String
str) = (Pat, Maybe Exp) -> Q (Pat, Maybe Exp)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Lit -> Pat
LitP (Lit -> Pat) -> Lit -> Pat
forall a b. (a -> b) -> a -> b
$ String -> Lit
StringL String
str, Maybe Exp
forall a. Maybe a
Nothing)
handlePiece (Dynamic a
_) = do
x <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"dyn"
let pat = Exp -> Pat -> Pat
ViewP (Name -> Exp
VarE 'fromPathPiece) (Name -> [Pat] -> Pat
conPCompat 'Just [Name -> Pat
VarP Name
x])
return (pat, Just $ VarE x)
handlePieces :: [Piece a] -> Q ([Pat], [Exp])
handlePieces :: forall a. [Piece a] -> Q ([Pat], [Exp])
handlePieces = ([(Pat, Maybe Exp)] -> ([Pat], [Exp]))
-> Q [(Pat, Maybe Exp)] -> Q ([Pat], [Exp])
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([Maybe Exp] -> [Exp]) -> ([Pat], [Maybe Exp]) -> ([Pat], [Exp])
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second [Maybe Exp] -> [Exp]
forall a. [Maybe a] -> [a]
catMaybes (([Pat], [Maybe Exp]) -> ([Pat], [Exp]))
-> ([(Pat, Maybe Exp)] -> ([Pat], [Maybe Exp]))
-> [(Pat, Maybe Exp)]
-> ([Pat], [Exp])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Pat, Maybe Exp)] -> ([Pat], [Maybe Exp])
forall a b. [(a, b)] -> ([a], [b])
unzip) (Q [(Pat, Maybe Exp)] -> Q ([Pat], [Exp]))
-> ([Piece a] -> Q [(Pat, Maybe Exp)])
-> [Piece a]
-> Q ([Pat], [Exp])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Piece a -> Q (Pat, Maybe Exp))
-> [Piece a] -> Q [(Pat, Maybe Exp)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Piece a -> Q (Pat, Maybe Exp)
forall a. Piece a -> Q (Pat, Maybe Exp)
handlePiece
mkCon :: String -> [Exp] -> Exp
mkCon :: String -> [Exp] -> Exp
mkCon String
name = (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Exp -> Exp -> Exp
AppE (Name -> Exp
ConE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
name)
mkPathPat :: Pat -> [Pat] -> Pat
mkPathPat :: Pat -> [Pat] -> Pat
mkPathPat Pat
final =
(Pat -> Pat -> Pat) -> Pat -> [Pat] -> Pat
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Pat -> Pat -> Pat
addPat Pat
final
where
addPat :: Pat -> Pat -> Pat
addPat Pat
x Pat
y = Name -> [Pat] -> Pat
conPCompat '(:) [Pat
x, Pat
y]
go :: SDC -> ResourceTree a -> Q Clause
go :: forall a. SDC -> ResourceTree a -> Q Clause
go SDC
sdc (ResourceParent String
name CheckOverlap
_check [Piece a]
pieces [ResourceTree a]
children) = do
(pats, dyns) <- [Piece a] -> Q ([Pat], [Exp])
forall a. [Piece a] -> Q ([Pat], [Exp])
handlePieces [Piece a]
pieces
let sdc' = SDC
sdc
{ extraParams = extraParams sdc ++ dyns
, extraCons = extraCons sdc ++ [mkCon name dyns]
}
childClauses <- mapM (go sdc') children
restName <- newName "rest"
let restE = Name -> Exp
VarE Name
restName
restP = Name -> Pat
VarP Name
restName
helperName <- newName $ "helper" ++ name
let helperE = Name -> Exp
VarE Name
helperName
return $ Clause
[mkPathPat restP pats]
(NormalB $ helperE `AppE` restE)
[FunD helperName $ childClauses ++ [clause404 sdc]]
go SDC {[Exp]
Exp
Clause
clause404 :: SDC -> Clause
extraParams :: SDC -> [Exp]
extraCons :: SDC -> [Exp]
envExp :: SDC -> Exp
reqExp :: SDC -> Exp
clause404 :: Clause
extraParams :: [Exp]
extraCons :: [Exp]
envExp :: Exp
reqExp :: Exp
..} (ResourceLeaf (Resource String
name [Piece a]
pieces Dispatch a
dispatch [String]
_ CheckOverlap
_check)) = do
(pats, dyns) <- [Piece a] -> Q ([Pat], [Exp])
forall a. [Piece a] -> Q ([Pat], [Exp])
handlePieces [Piece a]
pieces
(chooseMethod, finalPat) <- handleDispatch dispatch dyns
return $ Clause
[mkPathPat finalPat pats]
(NormalB chooseMethod)
[]
where
handleDispatch :: Dispatch a -> [Exp] -> Q (Exp, Pat)
handleDispatch :: forall a. Dispatch a -> [Exp] -> Q (Exp, Pat)
handleDispatch Dispatch a
dispatch' [Exp]
dyns =
case Dispatch a
dispatch' of
Methods Maybe a
multi [String]
methods -> do
(finalPat, mfinalE) <-
case Maybe a
multi of
Maybe a
Nothing -> (Pat, Maybe Exp) -> Q (Pat, Maybe Exp)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> [Pat] -> Pat
conPCompat '[] [], Maybe Exp
forall a. Maybe a
Nothing)
Just a
_ -> do
multiName <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"multi"
let pat = Exp -> Pat -> Pat
ViewP (Name -> Exp
VarE 'fromPathMultiPiece)
(Name -> [Pat] -> Pat
conPCompat 'Just [Name -> Pat
VarP Name
multiName])
return (pat, Just $ VarE multiName)
let dynsMulti =
case Maybe Exp
mfinalE of
Maybe Exp
Nothing -> [Exp]
dyns
Just Exp
e -> [Exp]
dyns [Exp] -> [Exp] -> [Exp]
forall a. [a] -> [a] -> [a]
++ [Exp
e]
route' = (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Exp -> Exp -> Exp
AppE (Name -> Exp
ConE (String -> Name
mkName String
name)) [Exp]
dynsMulti
route = (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Exp -> Exp -> Exp
AppE Exp
route' [Exp]
extraCons
jroute = Name -> Exp
ConE 'Just Exp -> Exp -> Exp
`AppE` Exp
route
allDyns = [Exp]
extraParams [Exp] -> [Exp] -> [Exp]
forall a. [a] -> [a] -> [a]
++ [Exp]
dynsMulti
mkRunExp Maybe String
mmethod = do
runHandlerE <- Q Exp
mdsRunHandler
handlerE' <- mdsGetHandler mmethod name
handlerE <- mdsUnwrapper $ foldl' AppE handlerE' allDyns
return $ runHandlerE
`AppE` handlerE
`AppE` envExp
`AppE` jroute
`AppE` reqExp
func <-
case methods of
[] -> Maybe String -> Q Exp
mkRunExp Maybe String
forall a. Maybe a
Nothing
[String]
_ -> do
getMethod <- Q Exp
mdsMethod
let methodE = Exp
getMethod Exp -> Exp -> Exp
`AppE` Exp
reqExp
matches <- forM methods $ \String
method -> do
exp <- Maybe String -> Q Exp
mkRunExp (String -> Maybe String
forall a. a -> Maybe a
Just String
method)
return $ Match (LitP $ StringL method) (NormalB exp) []
match405 <- do
runHandlerE <- mdsRunHandler
handlerE <- mds405
let exp = Exp
runHandlerE
Exp -> Exp -> Exp
`AppE` Exp
handlerE
Exp -> Exp -> Exp
`AppE` Exp
envExp
Exp -> Exp -> Exp
`AppE` Exp
jroute
Exp -> Exp -> Exp
`AppE` Exp
reqExp
return $ Match WildP (NormalB exp) []
return $ CaseE methodE $ matches ++ [match405]
return (func, finalPat)
Subsite a
_ String
getSub -> do
restPath <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"restPath"
setPathInfoE <- mdsSetPathInfo
subDispatcherE <- mdsSubDispatcher
runHandlerE <- mdsRunHandler
sub <- newName "sub"
let allDyns = [Exp]
extraParams [Exp] -> [Exp] -> [Exp]
forall a. [a] -> [a] -> [a]
++ [Exp]
dyns
sroute <- newName "sroute"
let sub2 = [Pat] -> Exp -> Exp
LamE [Name -> Pat
VarP Name
sub]
((Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Exp
a Exp
b -> Exp
a Exp -> Exp -> Exp
`AppE` Exp
b) (Name -> Exp
VarE (String -> Name
mkName String
getSub) Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
sub) [Exp]
allDyns)
let reqExp' = Exp
setPathInfoE Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
restPath Exp -> Exp -> Exp
`AppE` Exp
reqExp
route' = (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Exp -> Exp -> Exp
AppE (Name -> Exp
ConE (String -> Name
mkName String
name)) [Exp]
dyns
route = [Pat] -> Exp -> Exp
LamE [Name -> Pat
VarP Name
sroute] (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE Exp
route' (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
sroute) [Exp]
extraCons
exp = Exp
subDispatcherE
Exp -> Exp -> Exp
`AppE` Exp
runHandlerE
Exp -> Exp -> Exp
`AppE` Exp
sub2
Exp -> Exp -> Exp
`AppE` Exp
route
Exp -> Exp -> Exp
`AppE` Exp
envExp
Exp -> Exp -> Exp
`AppE` Exp
reqExp'
return (exp, VarP restPath)
mkClause404 :: Exp -> Exp -> Q Clause
mkClause404 Exp
envE Exp
reqE = do
handler <- Q Exp
mds404
runHandler <- mdsRunHandler
let exp = Exp
runHandler Exp -> Exp -> Exp
`AppE` Exp
handler Exp -> Exp -> Exp
`AppE` Exp
envE Exp -> Exp -> Exp
`AppE` Name -> Exp
ConE 'Nothing Exp -> Exp -> Exp
`AppE` Exp
reqE
return $ Clause [WildP] (NormalB exp) []
defaultGetHandler :: Maybe String -> String -> Q Exp
defaultGetHandler :: Maybe String -> String -> Q Exp
defaultGetHandler Maybe String
Nothing String
s = Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"handle" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s
defaultGetHandler (Just String
method) String
s = Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
method String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s
conPCompat :: Name -> [Pat] -> Pat
conPCompat :: Name -> [Pat] -> Pat
conPCompat Name
n [Pat]
pats = Name -> [Type] -> [Pat] -> Pat
ConP Name
n
#if MIN_VERSION_template_haskell(2,18,0)
[]
#endif
[Pat]
pats