{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards, TemplateHaskell, 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
    , SDC -> [Exp]
extraParams :: [Exp]
    , SDC -> [Exp]
extraCons :: [Exp]
    , SDC -> Exp
envExp :: Exp
    , SDC -> Exp
reqExp :: Exp
    }

-- | A simpler version of Yesod.Routes.TH.Dispatch.mkDispatchClause, based on
-- view patterns.
--
-- Since 1.4.0
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
mdsUnwrapper :: Exp -> Q Exp
mdsGetHandler :: Maybe String -> String -> Q Exp
mds405 :: Q Exp
mds404 :: Q Exp
mdsMethod :: Q Exp
mdsSetPathInfo :: Q Exp
mdsGetPathInfo :: Q Exp
mdsSubDispatcher :: Q Exp
mdsRunHandler :: Q Exp
mdsUnwrapper :: forall b site c. MkDispatchSettings b site c -> Exp -> Q Exp
mdsGetHandler :: forall b site c.
MkDispatchSettings b site c -> Maybe String -> String -> Q Exp
mds405 :: forall b site c. MkDispatchSettings b site c -> Q Exp
mds404 :: forall b site c. MkDispatchSettings b site c -> Q Exp
mdsMethod :: forall b site c. MkDispatchSettings b site c -> Q Exp
mdsSetPathInfo :: forall b site c. MkDispatchSettings b site c -> Q Exp
mdsGetPathInfo :: forall b site c. MkDispatchSettings b site c -> Q Exp
mdsSubDispatcher :: forall b site c. MkDispatchSettings b site c -> Q Exp
mdsRunHandler :: forall b site c. MkDispatchSettings b site c -> Q Exp
..} [ResourceTree a]
resources = do
    Int
suffix <- forall (m :: * -> *) a. Quasi m => IO a -> m a
qRunIO forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *). (Random a, MonadIO m) => (a, a) -> m a
randomRIO (Int
1000, Int
9999 :: Int)
    Name
envName <- forall (m :: * -> *). Quote m => String -> m Name
newName forall a b. (a -> b) -> a -> b
$ String
"env" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
suffix
    Name
reqName <- forall (m :: * -> *). Quote m => String -> m Name
newName forall a b. (a -> b) -> a -> b
$ String
"req" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
suffix
    Name
helperName <- forall (m :: * -> *). Quote m => String -> m Name
newName forall a b. (a -> b) -> a -> b
$ String
"helper" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
suffix

    let envE :: Exp
envE = Name -> Exp
VarE Name
envName
        reqE :: Exp
reqE = Name -> Exp
VarE Name
reqName
        helperE :: Exp
helperE = Name -> Exp
VarE Name
helperName

    Clause
clause404' <- Exp -> Exp -> Q Clause
mkClause404 Exp
envE Exp
reqE
    Exp
getPathInfo <- Q Exp
mdsGetPathInfo
    let pathInfo :: Exp
pathInfo = Exp
getPathInfo Exp -> Exp -> Exp
`AppE` Exp
reqE

    let sdc :: SDC
sdc = SDC
            { clause404 :: Clause
clause404 = Clause
clause404'
            , extraParams :: [Exp]
extraParams = []
            , extraCons :: [Exp]
extraCons = []
            , envExp :: Exp
envExp = Exp
envE
            , reqExp :: Exp
reqExp = Exp
reqE
            }
    [Clause]
clauses <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a. SDC -> ResourceTree a -> Q Clause
go SDC
sdc) [ResourceTree a]
resources

    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Pat] -> Body -> [Dec] -> Clause
Clause
        [Name -> Pat
VarP Name
envName, Name -> Pat
VarP Name
reqName]
        (Exp -> Body
NormalB forall a b. (a -> b) -> a -> b
$ Exp
helperE Exp -> Exp -> Exp
`AppE` Exp
pathInfo)
        [Name -> [Clause] -> Dec
FunD Name
helperName forall a b. (a -> b) -> a -> b
$ [Clause]
clauses forall a. [a] -> [a] -> [a]
++ [Clause
clause404']]
  where
    handlePiece :: Piece a -> Q (Pat, Maybe Exp)
    handlePiece :: forall a. Piece a -> Q (Pat, Maybe Exp)
handlePiece (Static String
str) = forall (m :: * -> *) a. Monad m => a -> m a
return (Lit -> Pat
LitP forall a b. (a -> b) -> a -> b
$ String -> Lit
StringL String
str, forall a. Maybe a
Nothing)
    handlePiece (Dynamic a
_) = do
        Name
x <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"dyn"
        let pat :: Pat
pat = Exp -> Pat -> Pat
ViewP (Name -> Exp
VarE 'fromPathPiece) (Name -> [Pat] -> Pat
conPCompat 'Just [Name -> Pat
VarP Name
x])
        forall (m :: * -> *) a. Monad m => a -> m a
return (Pat
pat, forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
x)

    handlePieces :: [Piece a] -> Q ([Pat], [Exp])
    handlePieces :: forall a. [Piece a] -> Q ([Pat], [Exp])
handlePieces = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second forall a. [Maybe a] -> [a]
catMaybes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [(a, b)] -> ([a], [b])
unzip) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall a. Piece a -> Q (Pat, Maybe Exp)
handlePiece

    mkCon :: String -> [Exp] -> Exp
    mkCon :: String -> [Exp] -> Exp
mkCon String
name = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Exp -> Exp -> Exp
AppE (Name -> Exp
ConE forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
name)

    mkPathPat :: Pat -> [Pat] -> Pat
    mkPathPat :: Pat -> [Pat] -> Pat
mkPathPat Pat
final =
        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
        ([Pat]
pats, [Exp]
dyns) <- forall a. [Piece a] -> Q ([Pat], [Exp])
handlePieces [Piece a]
pieces
        let sdc' :: SDC
sdc' = SDC
sdc
                { extraParams :: [Exp]
extraParams = SDC -> [Exp]
extraParams SDC
sdc forall a. [a] -> [a] -> [a]
++ [Exp]
dyns
                , extraCons :: [Exp]
extraCons = SDC -> [Exp]
extraCons SDC
sdc forall a. [a] -> [a] -> [a]
++ [String -> [Exp] -> Exp
mkCon String
name [Exp]
dyns]
                }
        [Clause]
childClauses <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a. SDC -> ResourceTree a -> Q Clause
go SDC
sdc') [ResourceTree a]
children

        Name
restName <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"rest"
        let restE :: Exp
restE = Name -> Exp
VarE Name
restName
            restP :: Pat
restP = Name -> Pat
VarP Name
restName

        Name
helperName <- forall (m :: * -> *). Quote m => String -> m Name
newName forall a b. (a -> b) -> a -> b
$ String
"helper" forall a. [a] -> [a] -> [a]
++ String
name
        let helperE :: Exp
helperE = Name -> Exp
VarE Name
helperName

        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Pat] -> Body -> [Dec] -> Clause
Clause
            [Pat -> [Pat] -> Pat
mkPathPat Pat
restP [Pat]
pats]
            (Exp -> Body
NormalB forall a b. (a -> b) -> a -> b
$ Exp
helperE Exp -> Exp -> Exp
`AppE` Exp
restE)
            [Name -> [Clause] -> Dec
FunD Name
helperName forall a b. (a -> b) -> a -> b
$ [Clause]
childClauses forall a. [a] -> [a] -> [a]
++ [SDC -> Clause
clause404 SDC
sdc]]
    go SDC {[Exp]
Exp
Clause
reqExp :: Exp
envExp :: Exp
extraCons :: [Exp]
extraParams :: [Exp]
clause404 :: Clause
reqExp :: SDC -> Exp
envExp :: SDC -> Exp
extraCons :: SDC -> [Exp]
extraParams :: SDC -> [Exp]
clause404 :: SDC -> Clause
..} (ResourceLeaf (Resource String
name [Piece a]
pieces Dispatch a
dispatch [String]
_ CheckOverlap
_check)) = do
        ([Pat]
pats, [Exp]
dyns) <- forall a. [Piece a] -> Q ([Pat], [Exp])
handlePieces [Piece a]
pieces

        (Exp
chooseMethod, Pat
finalPat) <- forall a. Dispatch a -> [Exp] -> Q (Exp, Pat)
handleDispatch Dispatch a
dispatch [Exp]
dyns

        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Pat] -> Body -> [Dec] -> Clause
Clause
            [Pat -> [Pat] -> Pat
mkPathPat Pat
finalPat [Pat]
pats]
            (Exp -> Body
NormalB Exp
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
                    (Pat
finalPat, Maybe Exp
mfinalE) <-
                        case Maybe a
multi of
                            Maybe a
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> [Pat] -> Pat
conPCompat '[] [], forall a. Maybe a
Nothing)
                            Just a
_ -> do
                                Name
multiName <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"multi"
                                let pat :: Pat
pat = Exp -> Pat -> Pat
ViewP (Name -> Exp
VarE 'fromPathMultiPiece)
                                                (Name -> [Pat] -> Pat
conPCompat 'Just [Name -> Pat
VarP Name
multiName])
                                forall (m :: * -> *) a. Monad m => a -> m a
return (Pat
pat, forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
multiName)

                    let dynsMulti :: [Exp]
dynsMulti =
                            case Maybe Exp
mfinalE of
                                Maybe Exp
Nothing -> [Exp]
dyns
                                Just Exp
e -> [Exp]
dyns forall a. [a] -> [a] -> [a]
++ [Exp
e]
                        route' :: Exp
route' = 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
route = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Exp -> Exp -> Exp
AppE Exp
route' [Exp]
extraCons
                        jroute :: Exp
jroute = Name -> Exp
ConE 'Just Exp -> Exp -> Exp
`AppE` Exp
route
                        allDyns :: [Exp]
allDyns = [Exp]
extraParams forall a. [a] -> [a] -> [a]
++ [Exp]
dynsMulti
                        mkRunExp :: Maybe String -> Q Exp
mkRunExp Maybe String
mmethod = do
                            Exp
runHandlerE <- Q Exp
mdsRunHandler
                            Exp
handlerE' <- Maybe String -> String -> Q Exp
mdsGetHandler Maybe String
mmethod String
name
                            Exp
handlerE <- Exp -> Q Exp
mdsUnwrapper forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Exp -> Exp -> Exp
AppE Exp
handlerE' [Exp]
allDyns
                            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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

                    Exp
func <-
                        case [String]
methods of
                            [] -> Maybe String -> Q Exp
mkRunExp forall a. Maybe a
Nothing
                            [String]
_ -> do
                                Exp
getMethod <- Q Exp
mdsMethod
                                let methodE :: Exp
methodE = Exp
getMethod Exp -> Exp -> Exp
`AppE` Exp
reqExp
                                [Match]
matches <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [String]
methods forall a b. (a -> b) -> a -> b
$ \String
method -> do
                                    Exp
exp <- Maybe String -> Q Exp
mkRunExp (forall a. a -> Maybe a
Just String
method)
                                    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Pat -> Body -> [Dec] -> Match
Match (Lit -> Pat
LitP forall a b. (a -> b) -> a -> b
$ String -> Lit
StringL String
method) (Exp -> Body
NormalB Exp
exp) []
                                Match
match405 <- do
                                    Exp
runHandlerE <- Q Exp
mdsRunHandler
                                    Exp
handlerE <- Q Exp
mds405
                                    let exp :: Exp
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
                                    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Pat -> Body -> [Dec] -> Match
Match Pat
WildP (Exp -> Body
NormalB Exp
exp) []
                                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Exp -> [Match] -> Exp
CaseE Exp
methodE forall a b. (a -> b) -> a -> b
$ [Match]
matches forall a. [a] -> [a] -> [a]
++ [Match
match405]

                    forall (m :: * -> *) a. Monad m => a -> m a
return (Exp
func, Pat
finalPat)
                Subsite a
_ String
getSub -> do
                    Name
restPath <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"restPath"
                    Exp
setPathInfoE <- Q Exp
mdsSetPathInfo
                    Exp
subDispatcherE <- Q Exp
mdsSubDispatcher
                    Exp
runHandlerE <- Q Exp
mdsRunHandler
                    Name
sub <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"sub"
                    let allDyns :: [Exp]
allDyns = [Exp]
extraParams forall a. [a] -> [a] -> [a]
++ [Exp]
dyns
                    Name
sroute <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"sroute"
                    let sub2 :: Exp
sub2 = [Pat] -> Exp -> Exp
LamE [Name -> Pat
VarP Name
sub]
                            (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
reqExp' = Exp
setPathInfoE Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
restPath Exp -> Exp -> Exp
`AppE` Exp
reqExp
                        route' :: Exp
route' = 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 :: Exp
route = [Pat] -> Exp -> Exp
LamE [Name -> Pat
VarP Name
sroute] forall a b. (a -> 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' forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
sroute) [Exp]
extraCons
                        exp :: Exp
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'
                    forall (m :: * -> *) a. Monad m => a -> m a
return (Exp
exp, Name -> Pat
VarP Name
restPath)

    mkClause404 :: Exp -> Exp -> Q Clause
mkClause404 Exp
envE Exp
reqE = do
        Exp
handler <- Q Exp
mds404
        Exp
runHandler <- Q Exp
mdsRunHandler
        let exp :: Exp
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
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Pat] -> Body -> [Dec] -> Clause
Clause [Pat
WildP] (Exp -> Body
NormalB Exp
exp) []

defaultGetHandler :: Maybe String -> String -> Q Exp
defaultGetHandler :: Maybe String -> String -> Q Exp
defaultGetHandler Maybe String
Nothing String
s = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE forall a b. (a -> b) -> a -> b
$ String -> Name
mkName forall a b. (a -> b) -> a -> b
$ String
"handle" forall a. [a] -> [a] -> [a]
++ String
s
defaultGetHandler (Just String
method) String
s = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE forall a b. (a -> b) -> a -> b
$ String -> Name
mkName forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
method 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