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