{-# 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
    , 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
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