{-# LANGUAGE TemplateHaskellQuotes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
module Yesod.Core.Internal.TH
    ( mkYesod
    , mkYesodOpts

    , mkYesodWith

    , mkYesodData
    , mkYesodDataOpts

    , mkYesodSubData
    , mkYesodSubDataOpts

    , mkYesodWithParser
    , mkYesodWithParserOpts

    , mkYesodDispatch
    , mkYesodDispatchOpts

    , masterTypeSyns

    , mkYesodGeneral
    , mkYesodGeneralOpts

    , mkMDS
    , mkDispatchInstance

    , mkYesodSubDispatch
    
    , subTopDispatch
    , instanceD
    )
 where

import Prelude hiding (exp)
import Yesod.Core.Handler

import Language.Haskell.TH hiding (cxt, instanceD)
import Language.Haskell.TH.Syntax

import qualified Network.Wai as W

import Data.ByteString.Lazy.Char8 ()
import Data.List (foldl')
import Control.Monad (replicateM, void)
import Text.Parsec (parse, many1, many, eof, try, option, sepBy1)
import Text.ParserCombinators.Parsec.Char (alphaNum, spaces, string, char)

import Yesod.Routes.TH
import Yesod.Routes.Parse
import Yesod.Core.Content (ToTypedContent (..))
import Yesod.Core.Types
import Yesod.Core.Class.Dispatch
import Yesod.Core.Internal.Run

-- | Generates URL datatype and site function for the given 'Resource's. This
-- is used for creating sites, /not/ subsites. See 'mkYesodSubData' and 'mkYesodSubDispatch' for the latter.
-- Use 'parseRoutes' to create the 'Resource's.
--
-- Contexts and type variables in the name of the datatype are parsed. 
-- For example, a datatype @App a@ with typeclass constraint @MyClass a@ can be written as @\"(MyClass a) => App a\"@.
mkYesod :: String -- ^ name of the argument datatype
        -> [ResourceTree String]
        -> Q [Dec]
mkYesod :: [Char] -> [ResourceTree [Char]] -> Q [Dec]
mkYesod = RouteOpts -> [Char] -> [ResourceTree [Char]] -> Q [Dec]
mkYesodOpts RouteOpts
defaultOpts

-- | `mkYesod` but with custom options.
--
-- @since 1.6.25.0
mkYesodOpts :: RouteOpts
            -> String
            -> [ResourceTree String]
            -> Q [Dec]
mkYesodOpts :: RouteOpts -> [Char] -> [ResourceTree [Char]] -> Q [Dec]
mkYesodOpts RouteOpts
opts [Char]
name = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. [a] -> [a] -> [a]
(++)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. RouteOpts
-> [Char]
-> Bool
-> (Exp -> Q Exp)
-> [ResourceTree [Char]]
-> Q ([Dec], [Dec])
mkYesodWithParserOpts RouteOpts
opts [Char]
name Bool
False forall (m :: * -> *) a. Monad m => a -> m a
return


{-# DEPRECATED mkYesodWith "Contexts and type variables are now parsed from the name in `mkYesod`. <https://github.com/yesodweb/yesod/pull/1366>" #-}
-- | Similar to 'mkYesod', except contexts and type variables are not parsed. 
-- Instead, they are explicitly provided. 
-- You can write @(MyClass a) => App a@ with @mkYesodWith [[\"MyClass\",\"a\"]] \"App\" [\"a\"] ...@.
mkYesodWith :: [[String]] -- ^ list of contexts
            -> String -- ^ name of the argument datatype
            -> [String] -- ^ list of type variables
            -> [ResourceTree String]
            -> Q [Dec]
mkYesodWith :: [[[Char]]]
-> [Char] -> [[Char]] -> [ResourceTree [Char]] -> Q [Dec]
mkYesodWith [[[Char]]]
cxts [Char]
name [[Char]]
args = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. [a] -> [a] -> [a]
(++)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[[Char]]]
-> [Char]
-> [[Char]]
-> Bool
-> (Exp -> Q Exp)
-> [ResourceTree [Char]]
-> Q ([Dec], [Dec])
mkYesodGeneral [[[Char]]]
cxts [Char]
name [[Char]]
args Bool
False forall (m :: * -> *) a. Monad m => a -> m a
return


-- | Sometimes, you will want to declare your routes in one file and define
-- your handlers elsewhere. For example, this is the only way to break up a
-- monolithic file into smaller parts. Use this function, paired with
-- 'mkYesodDispatch', to do just that.
mkYesodData :: String -> [ResourceTree String] -> Q [Dec]
mkYesodData :: [Char] -> [ResourceTree [Char]] -> Q [Dec]
mkYesodData = RouteOpts -> [Char] -> [ResourceTree [Char]] -> Q [Dec]
mkYesodDataOpts RouteOpts
defaultOpts

-- | `mkYesodData` but with custom options.
--
-- @since 1.6.25.0
mkYesodDataOpts :: RouteOpts -> String -> [ResourceTree String] -> Q [Dec]
mkYesodDataOpts :: RouteOpts -> [Char] -> [ResourceTree [Char]] -> Q [Dec]
mkYesodDataOpts RouteOpts
opts [Char]
name [ResourceTree [Char]]
resS = forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RouteOpts
-> [Char]
-> Bool
-> (Exp -> Q Exp)
-> [ResourceTree [Char]]
-> Q ([Dec], [Dec])
mkYesodWithParserOpts RouteOpts
opts [Char]
name Bool
False forall (m :: * -> *) a. Monad m => a -> m a
return [ResourceTree [Char]]
resS


mkYesodSubData :: String -> [ResourceTree String] -> Q [Dec]
mkYesodSubData :: [Char] -> [ResourceTree [Char]] -> Q [Dec]
mkYesodSubData = RouteOpts -> [Char] -> [ResourceTree [Char]] -> Q [Dec]
mkYesodSubDataOpts RouteOpts
defaultOpts

-- |
--
-- @since 1.6.25.0
mkYesodSubDataOpts :: RouteOpts -> String -> [ResourceTree String] -> Q [Dec]
mkYesodSubDataOpts :: RouteOpts -> [Char] -> [ResourceTree [Char]] -> Q [Dec]
mkYesodSubDataOpts RouteOpts
opts [Char]
name [ResourceTree [Char]]
resS = forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RouteOpts
-> [Char]
-> Bool
-> (Exp -> Q Exp)
-> [ResourceTree [Char]]
-> Q ([Dec], [Dec])
mkYesodWithParserOpts RouteOpts
opts [Char]
name Bool
True forall (m :: * -> *) a. Monad m => a -> m a
return [ResourceTree [Char]]
resS


-- | Parses contexts and type arguments out of name before generating TH.
mkYesodWithParser :: String                    -- ^ foundation type
                  -> Bool                      -- ^ is this a subsite
                  -> (Exp -> Q Exp)            -- ^ unwrap handler
                  -> [ResourceTree String]
                  -> Q([Dec],[Dec])
mkYesodWithParser :: [Char]
-> Bool
-> (Exp -> Q Exp)
-> [ResourceTree [Char]]
-> Q ([Dec], [Dec])
mkYesodWithParser = RouteOpts
-> [Char]
-> Bool
-> (Exp -> Q Exp)
-> [ResourceTree [Char]]
-> Q ([Dec], [Dec])
mkYesodWithParserOpts RouteOpts
defaultOpts

-- | Parses contexts and type arguments out of name before generating TH.
--
-- @since 1.6.25.0
mkYesodWithParserOpts :: RouteOpts                 -- ^ Additional route options
                      -> String                    -- ^ foundation type
                      -> Bool                      -- ^ is this a subsite
                      -> (Exp -> Q Exp)            -- ^ unwrap handler
                      -> [ResourceTree String]
                      -> Q([Dec],[Dec])
mkYesodWithParserOpts :: RouteOpts
-> [Char]
-> Bool
-> (Exp -> Q Exp)
-> [ResourceTree [Char]]
-> Q ([Dec], [Dec])
mkYesodWithParserOpts RouteOpts
opts [Char]
name Bool
isSub Exp -> Q Exp
f [ResourceTree [Char]]
resS = do
    let ([Char]
name', [[Char]]
rest, [[[Char]]]
cxt) = case forall s t a.
Stream s Identity t =>
Parsec s () a -> [Char] -> s -> Either ParseError a
parse ParsecT [Char] () Identity ([Char], [[Char]], [[[Char]]])
parseName [Char]
"" [Char]
name of
            Left ParseError
err -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show ParseError
err
            Right ([Char], [[Char]], [[[Char]]])
a -> ([Char], [[Char]], [[[Char]]])
a
    RouteOpts
-> [[[Char]]]
-> [Char]
-> [[Char]]
-> Bool
-> (Exp -> Q Exp)
-> [ResourceTree [Char]]
-> Q ([Dec], [Dec])
mkYesodGeneralOpts RouteOpts
opts [[[Char]]]
cxt [Char]
name' [[Char]]
rest Bool
isSub Exp -> Q Exp
f [ResourceTree [Char]]
resS

    where
        parseName :: ParsecT [Char] () Identity ([Char], [[Char]], [[[Char]]])
parseName = do
            [[[Char]]]
cxt <- forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option [] ParsecT [Char] () Identity [[[Char]]]
parseContext
            [Char]
name' <- forall {u}. ParsecT [Char] u Identity [Char]
parseWord
            [[Char]]
args <- forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many forall {u}. ParsecT [Char] u Identity [Char]
parseWord
            forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces
            forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof
            forall (m :: * -> *) a. Monad m => a -> m a
return ( [Char]
name', [[Char]]
args, [[[Char]]]
cxt)

        parseWord :: ParsecT [Char] u Identity [Char]
parseWord = do
            forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces
            forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
alphaNum

        parseContext :: ParsecT [Char] () Identity [[[Char]]]
parseContext = forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try forall a b. (a -> b) -> a -> b
$ do
            [[[Char]]]
cxts <- forall {s} {m :: * -> *} {u} {b}.
Stream s m Char =>
ParsecT s u m b -> ParsecT s u m b
parseParen ParsecT [Char] () Identity [[[Char]]]
parseContexts
            forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces
            [Char]
_ <- forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string [Char]
"=>"
            forall (m :: * -> *) a. Monad m => a -> m a
return [[[Char]]]
cxts

        parseParen :: ParsecT s u m b -> ParsecT s u m b
parseParen ParsecT s u m b
p = do
            forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces
            Char
_ <- forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'('
            b
r <- ParsecT s u m b
p
            forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces
            Char
_ <- forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
')'
            forall (m :: * -> *) a. Monad m => a -> m a
return b
r

        parseContexts :: ParsecT [Char] () Identity [[[Char]]]
parseContexts = 
            forall s (m :: * -> *) t u a sep.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
sepBy1 (forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 forall {u}. ParsecT [Char] u Identity [Char]
parseWord) (forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
',' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ())


-- | See 'mkYesodData'.
mkYesodDispatch :: String -> [ResourceTree String] -> Q [Dec]
mkYesodDispatch :: [Char] -> [ResourceTree [Char]] -> Q [Dec]
mkYesodDispatch = RouteOpts -> [Char] -> [ResourceTree [Char]] -> Q [Dec]
mkYesodDispatchOpts RouteOpts
defaultOpts

-- | See 'mkYesodDataOpts'
--
-- @since 1.6.25.0
mkYesodDispatchOpts :: RouteOpts -> String -> [ResourceTree String] -> Q [Dec]
mkYesodDispatchOpts :: RouteOpts -> [Char] -> [ResourceTree [Char]] -> Q [Dec]
mkYesodDispatchOpts RouteOpts
opts [Char]
name = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. RouteOpts
-> [Char]
-> Bool
-> (Exp -> Q Exp)
-> [ResourceTree [Char]]
-> Q ([Dec], [Dec])
mkYesodWithParserOpts RouteOpts
opts [Char]
name Bool
False forall (m :: * -> *) a. Monad m => a -> m a
return


-- | Get the Handler and Widget type synonyms for the given site.
masterTypeSyns :: [Name] -> Type -> [Dec] -- FIXME remove from here, put into the scaffolding itself?
masterTypeSyns :: [Name] -> Type -> [Dec]
masterTypeSyns [Name]
vs Type
site =
    [ Name -> [TyVarBndr ()] -> Type -> Dec
TySynD ([Char] -> Name
mkName [Char]
"Handler") (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> TyVarBndr ()
plainTV [Name]
vs)
      forall a b. (a -> b) -> a -> b
$ Name -> Type
ConT ''HandlerFor Type -> Type -> Type
`AppT` Type
site
    , Name -> [TyVarBndr ()] -> Type -> Dec
TySynD ([Char] -> Name
mkName [Char]
"Widget")  (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> TyVarBndr ()
plainTV [Name]
vs)
      forall a b. (a -> b) -> a -> b
$ Name -> Type
ConT ''WidgetFor Type -> Type -> Type
`AppT` Type
site Type -> Type -> Type
`AppT` Name -> Type
ConT ''()
    ]


mkYesodGeneral :: [[String]]                -- ^ Appliction context. Used in RenderRoute, RouteAttrs, and ParseRoute instances.
               -> String                    -- ^ foundation type
               -> [String]                  -- ^ arguments for the type
               -> Bool                      -- ^ is this a subsite
               -> (Exp -> Q Exp)            -- ^ unwrap handler
               -> [ResourceTree String]
               -> Q([Dec],[Dec])
mkYesodGeneral :: [[[Char]]]
-> [Char]
-> [[Char]]
-> Bool
-> (Exp -> Q Exp)
-> [ResourceTree [Char]]
-> Q ([Dec], [Dec])
mkYesodGeneral = RouteOpts
-> [[[Char]]]
-> [Char]
-> [[Char]]
-> Bool
-> (Exp -> Q Exp)
-> [ResourceTree [Char]]
-> Q ([Dec], [Dec])
mkYesodGeneralOpts RouteOpts
defaultOpts

-- |
--
-- @since 1.6.25.0
mkYesodGeneralOpts :: RouteOpts                 -- ^ Options to adjust route creation
                   -> [[String]]                -- ^ Appliction context. Used in RenderRoute, RouteAttrs, and ParseRoute instances.
                   -> String                    -- ^ foundation type
                   -> [String]                  -- ^ arguments for the type
                   -> Bool                      -- ^ is this a subsite
                   -> (Exp -> Q Exp)            -- ^ unwrap handler
                   -> [ResourceTree String]
                   -> Q([Dec],[Dec])
mkYesodGeneralOpts :: RouteOpts
-> [[[Char]]]
-> [Char]
-> [[Char]]
-> Bool
-> (Exp -> Q Exp)
-> [ResourceTree [Char]]
-> Q ([Dec], [Dec])
mkYesodGeneralOpts RouteOpts
opts [[[Char]]]
appCxt' [Char]
namestr [[Char]]
mtys Bool
isSub Exp -> Q Exp
f [ResourceTree [Char]]
resS = do
    let appCxt :: [Type]
appCxt = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\([Char]
c:[[Char]]
rest) -> 
            forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Type
acc [Char]
v -> Type
acc Type -> Type -> Type
`AppT` [Char] -> Type
nameToType [Char]
v) (Name -> Type
ConT forall a b. (a -> b) -> a -> b
$ [Char] -> Name
mkName [Char]
c) [[Char]]
rest
          ) [[[Char]]]
appCxt'
    Maybe Name
mname <- [Char] -> Q (Maybe Name)
lookupTypeName [Char]
namestr
    Int
arity <- case Maybe Name
mname of
               Just Name
name -> do
                 Info
info <- Name -> Q Info
reify Name
name
                 forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
                   case Info
info of
                     TyConI Dec
dec ->
                       case Dec
dec of
                         DataD [Type]
_ Name
_ [TyVarBndr ()]
vs Maybe Type
_ [Con]
_ [DerivClause]
_ -> forall (t :: * -> *) a. Foldable t => t a -> Int
length [TyVarBndr ()]
vs
                         NewtypeD [Type]
_ Name
_ [TyVarBndr ()]
vs Maybe Type
_ Con
_ [DerivClause]
_ -> forall (t :: * -> *) a. Foldable t => t a -> Int
length [TyVarBndr ()]
vs
                         TySynD Name
_ [TyVarBndr ()]
vs Type
_ -> forall (t :: * -> *) a. Foldable t => t a -> Int
length [TyVarBndr ()]
vs
                         Dec
_ -> Int
0
                     Info
_ -> Int
0
               Maybe Name
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Int
0
    let name :: Name
name = [Char] -> Name
mkName [Char]
namestr
    -- Generate as many variable names as the arity indicates
    [Name]
vns <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (Int
arity forall a. Num a => a -> a -> a
- forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Char]]
mtys) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"t"
    -- types that you apply to get a concrete site name
    let argtypes :: [Type]
argtypes = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Char] -> Type
nameToType [[Char]]
mtys forall a. [a] -> [a] -> [a]
++ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Type
VarT [Name]
vns
    -- typevars that should appear in synonym head
    let argvars :: [Name]
argvars = (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Char] -> Name
mkName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter [Char] -> Bool
isTvar) [[Char]]
mtys forall a. [a] -> [a] -> [a]
++ [Name]
vns
        -- Base type (site type with variables)
    let site :: Type
site = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Type -> Type -> Type
AppT (Name -> Type
ConT Name
name) [Type]
argtypes
        res :: [ResourceTree Type]
res = forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Char] -> Type
parseType forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
dropBracket)) [ResourceTree [Char]]
resS
    [Dec]
renderRouteDec <- RouteOpts -> [Type] -> Type -> [ResourceTree Type] -> Q [Dec]
mkRenderRouteInstanceOpts RouteOpts
opts [Type]
appCxt Type
site [ResourceTree Type]
res
    Dec
routeAttrsDec  <- forall a. [Type] -> Type -> [ResourceTree a] -> Q Dec
mkRouteAttrsInstance [Type]
appCxt Type
site [ResourceTree Type]
res
    [Dec]
dispatchDec    <- forall c.
Type -> [Type] -> (Exp -> Q Exp) -> [ResourceTree c] -> Q [Dec]
mkDispatchInstance Type
site [Type]
appCxt Exp -> Q Exp
f [ResourceTree Type]
res
    Dec
parseRoute <- forall a. [Type] -> Type -> [ResourceTree a] -> Q Dec
mkParseRouteInstance [Type]
appCxt Type
site [ResourceTree Type]
res
    let rname :: Name
rname = [Char] -> Name
mkName forall a b. (a -> b) -> a -> b
$ [Char]
"resources" forall a. [a] -> [a] -> [a]
++ [Char]
namestr
    Exp
eres <- forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
lift [ResourceTree [Char]]
resS
    let resourcesDec :: [Dec]
resourcesDec =
            [ Name -> Type -> Dec
SigD Name
rname forall a b. (a -> b) -> a -> b
$ Type
ListT Type -> Type -> Type
`AppT` (Name -> Type
ConT ''ResourceTree Type -> Type -> Type
`AppT` Name -> Type
ConT ''String)
            , Name -> [Clause] -> Dec
FunD Name
rname [[Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB Exp
eres) []]
            ]
    let dataDec :: [Dec]
dataDec = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ [Dec
parseRoute]
            , [Dec]
renderRouteDec
            , [Dec
routeAttrsDec]
            , [Dec]
resourcesDec
            , if Bool
isSub then [] else [Name] -> Type -> [Dec]
masterTypeSyns [Name]
argvars Type
site
            ]
    forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec]
dataDec, [Dec]
dispatchDec)


mkMDS :: (Exp -> Q Exp) -> Q Exp -> Q Exp -> MkDispatchSettings a site b
mkMDS :: forall a site b.
(Exp -> Q Exp) -> Q Exp -> Q Exp -> MkDispatchSettings a site b
mkMDS Exp -> Q Exp
f Q Exp
rh Q Exp
sd = MkDispatchSettings
    { mdsRunHandler :: Q Exp
mdsRunHandler = Q Exp
rh
    , mdsSubDispatcher :: Q Exp
mdsSubDispatcher = Q Exp
sd
    , mdsGetPathInfo :: Q Exp
mdsGetPathInfo = [|W.pathInfo|]
    , mdsSetPathInfo :: Q Exp
mdsSetPathInfo = [|\p r -> r { W.pathInfo = p }|]
    , mdsMethod :: Q Exp
mdsMethod = [|W.requestMethod|]
    , mds404 :: Q Exp
mds404 = [|void notFound|]
    , mds405 :: Q Exp
mds405 = [|void badMethod|]
    , mdsGetHandler :: Maybe [Char] -> [Char] -> Q Exp
mdsGetHandler = Maybe [Char] -> [Char] -> Q Exp
defaultGetHandler
    , mdsUnwrapper :: Exp -> Q Exp
mdsUnwrapper = Exp -> Q Exp
f
    }

-- | If the generation of @'YesodDispatch'@ instance require finer
-- control of the types, contexts etc. using this combinator. You will
-- hardly need this generality. However, in certain situations, like
-- when writing library/plugin for yesod, this combinator becomes
-- handy.
mkDispatchInstance :: Type                      -- ^ The master site type
                   -> Cxt                       -- ^ Context of the instance
                   -> (Exp -> Q Exp)            -- ^ Unwrap handler
                   -> [ResourceTree c]          -- ^ The resource
                   -> DecsQ
mkDispatchInstance :: forall c.
Type -> [Type] -> (Exp -> Q Exp) -> [ResourceTree c] -> Q [Dec]
mkDispatchInstance Type
master [Type]
cxt Exp -> Q Exp
f [ResourceTree c]
res = do
    Clause
clause' <- 
        forall b site c a.
MkDispatchSettings b site c -> [ResourceTree a] -> Q Clause
mkDispatchClause 
            (forall a site b.
(Exp -> Q Exp) -> Q Exp -> Q Exp -> MkDispatchSettings a site b
mkMDS 
                Exp -> Q Exp
f 
                [|yesodRunner|] 
                [|\parentRunner getSub toParent env -> yesodSubDispatch
                    YesodSubRunnerEnv
                    { ysreParentRunner = parentRunner
                    , ysreGetSub = getSub
                    , ysreToParentRoute = toParent
                    , ysreParentEnv = env
                    }
                |])
            [ResourceTree c]
res
    let thisDispatch :: Dec
thisDispatch = Name -> [Clause] -> Dec
FunD 'yesodDispatch [Clause
clause']
    forall (m :: * -> *) a. Monad m => a -> m a
return [[Type] -> Type -> [Dec] -> Dec
instanceD [Type]
cxt Type
yDispatch [Dec
thisDispatch]]
  where
    yDispatch :: Type
yDispatch = Name -> Type
ConT ''YesodDispatch Type -> Type -> Type
`AppT` Type
master


mkYesodSubDispatch :: [ResourceTree a] -> Q Exp
mkYesodSubDispatch :: forall a. [ResourceTree a] -> Q Exp
mkYesodSubDispatch [ResourceTree a]
res = do
    Clause
clause' <- 
        forall b site c a.
MkDispatchSettings b site c -> [ResourceTree a] -> Q Clause
mkDispatchClause
            (forall a site b.
(Exp -> Q Exp) -> Q Exp -> Q Exp -> MkDispatchSettings a site b
mkMDS 
                forall (m :: * -> *) a. Monad m => a -> m a
return 
                [|subHelper|] 
                [|subTopDispatch|]) 
        [ResourceTree a]
res
    Name
inner <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"inner"
    let innerFun :: Dec
innerFun = Name -> [Clause] -> Dec
FunD Name
inner [Clause
clause']
    Name
helper <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"helper"
    let fun :: Dec
fun = Name -> [Clause] -> Dec
FunD Name
helper
                [ [Pat] -> Body -> [Dec] -> Clause
Clause
                    []
                    (Exp -> Body
NormalB forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
inner)
                    [Dec
innerFun]
                ]
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Dec] -> Exp -> Exp
LetE [Dec
fun] (Name -> Exp
VarE Name
helper)


subTopDispatch :: 
    (YesodSubDispatch sub master) =>
        (forall content. ToTypedContent content =>
            SubHandlerFor child master content ->
            YesodSubRunnerEnv child master ->
            Maybe (Route child) ->
            W.Application
        ) ->
        (mid -> sub) ->
        (Route sub -> Route mid) ->
        YesodSubRunnerEnv mid master ->
        W.Application
subTopDispatch :: forall sub master child mid.
YesodSubDispatch sub master =>
(forall content.
 ToTypedContent content =>
 SubHandlerFor child master content
 -> YesodSubRunnerEnv child master
 -> Maybe (Route child)
 -> Application)
-> (mid -> sub)
-> (Route sub -> Route mid)
-> YesodSubRunnerEnv mid master
-> Application
subTopDispatch forall content.
ToTypedContent content =>
SubHandlerFor child master content
-> YesodSubRunnerEnv child master
-> Maybe (Route child)
-> Application
_ mid -> sub
getSub Route sub -> Route mid
toParent YesodSubRunnerEnv mid master
env = forall sub master.
YesodSubDispatch sub master =>
YesodSubRunnerEnv sub master -> Application
yesodSubDispatch
            (YesodSubRunnerEnv
            { ysreParentRunner :: ParentRunner master
ysreParentRunner = forall sub parent.
YesodSubRunnerEnv sub parent -> ParentRunner parent
ysreParentRunner YesodSubRunnerEnv mid master
env
            , ysreGetSub :: master -> sub
ysreGetSub = mid -> sub
getSub forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall sub parent. YesodSubRunnerEnv sub parent -> parent -> sub
ysreGetSub YesodSubRunnerEnv mid master
env
            , ysreToParentRoute :: Route sub -> Route master
ysreToParentRoute = forall sub parent.
YesodSubRunnerEnv sub parent -> Route sub -> Route parent
ysreToParentRoute YesodSubRunnerEnv mid master
env forall b c a. (b -> c) -> (a -> b) -> a -> c
. Route sub -> Route mid
toParent
            , ysreParentEnv :: YesodRunnerEnv master
ysreParentEnv = forall sub parent.
YesodSubRunnerEnv sub parent -> YesodRunnerEnv parent
ysreParentEnv YesodSubRunnerEnv mid master
env
            })

instanceD :: Cxt -> Type -> [Dec] -> Dec
instanceD :: [Type] -> Type -> [Dec] -> Dec
instanceD = Maybe Overlap -> [Type] -> Type -> [Dec] -> Dec
InstanceD forall a. Maybe a
Nothing