{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
{-# LANGUAGE TypeFamilies #-}

module Yesod.Core.Internal.TH
    ( mkYesod
    , mkYesodOpts

    , mkYesodWith

    , mkYesodData
    , mkYesodDataOpts

    , mkYesodSubData
    , mkYesodSubDataOpts

    , mkYesodWithParser
    , mkYesodWithParserOpts

    , mkYesodDispatch
    , mkYesodDispatchOpts

    , masterTypeSyns

    , mkYesodGeneral
    , mkYesodGeneralOpts

    , mkMDS
    , mkDispatchInstance

    , mkYesodSubDispatch

    , subTopDispatch
    , instanceD

    , RouteOpts
    , defaultOpts
    , setEqDerived
    , setShowDerived
    , setReadDerived
    )
 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 :: String -> [ResourceTree String] -> Q [Dec]
mkYesod = RouteOpts -> String -> [ResourceTree String] -> Q [Dec]
mkYesodOpts RouteOpts
defaultOpts

-- | `mkYesod` but with custom options.
--
-- @since 1.6.25.0
mkYesodOpts :: RouteOpts
            -> String
            -> [ResourceTree String]
            -> Q [Dec]
mkYesodOpts :: RouteOpts -> String -> [ResourceTree String] -> Q [Dec]
mkYesodOpts RouteOpts
opts String
name = (([Dec], [Dec]) -> [Dec]) -> Q ([Dec], [Dec]) -> Q [Dec]
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([Dec] -> [Dec] -> [Dec]) -> ([Dec], [Dec]) -> [Dec]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
(++)) (Q ([Dec], [Dec]) -> Q [Dec])
-> ([ResourceTree String] -> Q ([Dec], [Dec]))
-> [ResourceTree String]
-> Q [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RouteOpts
-> String
-> Bool
-> (Exp -> Q Exp)
-> [ResourceTree String]
-> Q ([Dec], [Dec])
mkYesodWithParserOpts RouteOpts
opts String
name Bool
False Exp -> Q Exp
forall a. a -> Q a
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 :: [[String]]
-> String -> [String] -> [ResourceTree String] -> Q [Dec]
mkYesodWith [[String]]
cxts String
name [String]
args = (([Dec], [Dec]) -> [Dec]) -> Q ([Dec], [Dec]) -> Q [Dec]
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([Dec] -> [Dec] -> [Dec]) -> ([Dec], [Dec]) -> [Dec]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
(++)) (Q ([Dec], [Dec]) -> Q [Dec])
-> ([ResourceTree String] -> Q ([Dec], [Dec]))
-> [ResourceTree String]
-> Q [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[String]]
-> String
-> [String]
-> Bool
-> (Exp -> Q Exp)
-> [ResourceTree String]
-> Q ([Dec], [Dec])
mkYesodGeneral [[String]]
cxts String
name [String]
args Bool
False Exp -> Q Exp
forall a. a -> Q a
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 :: String -> [ResourceTree String] -> Q [Dec]
mkYesodData = RouteOpts -> String -> [ResourceTree String] -> Q [Dec]
mkYesodDataOpts RouteOpts
defaultOpts

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


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

-- |
--
-- @since 1.6.25.0
mkYesodSubDataOpts :: RouteOpts -> String -> [ResourceTree String] -> Q [Dec]
mkYesodSubDataOpts :: RouteOpts -> String -> [ResourceTree String] -> Q [Dec]
mkYesodSubDataOpts RouteOpts
opts String
name [ResourceTree String]
resS = ([Dec], [Dec]) -> [Dec]
forall a b. (a, b) -> a
fst (([Dec], [Dec]) -> [Dec]) -> Q ([Dec], [Dec]) -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RouteOpts
-> String
-> Bool
-> (Exp -> Q Exp)
-> [ResourceTree String]
-> Q ([Dec], [Dec])
mkYesodWithParserOpts RouteOpts
opts String
name Bool
True Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [ResourceTree String]
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 :: String
-> Bool
-> (Exp -> Q Exp)
-> [ResourceTree String]
-> Q ([Dec], [Dec])
mkYesodWithParser = RouteOpts
-> String
-> Bool
-> (Exp -> Q Exp)
-> [ResourceTree String]
-> 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
-> String
-> Bool
-> (Exp -> Q Exp)
-> [ResourceTree String]
-> Q ([Dec], [Dec])
mkYesodWithParserOpts RouteOpts
opts String
name Bool
isSub Exp -> Q Exp
f [ResourceTree String]
resS = do
    let (String
name', [String]
rest, [[String]]
cxt) = case Parsec String () (String, [String], [[String]])
-> String
-> String
-> Either ParseError (String, [String], [[String]])
forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parse Parsec String () (String, [String], [[String]])
parseName String
"" String
name of
            Left ParseError
err -> String -> (String, [String], [[String]])
forall a. HasCallStack => String -> a
error (String -> (String, [String], [[String]]))
-> String -> (String, [String], [[String]])
forall a b. (a -> b) -> a -> b
$ ParseError -> String
forall a. Show a => a -> String
show ParseError
err
            Right (String, [String], [[String]])
a -> (String, [String], [[String]])
a
    RouteOpts
-> [[String]]
-> String
-> [String]
-> Bool
-> (Exp -> Q Exp)
-> [ResourceTree String]
-> Q ([Dec], [Dec])
mkYesodGeneralOpts RouteOpts
opts [[String]]
cxt String
name' [String]
rest Bool
isSub Exp -> Q Exp
f [ResourceTree String]
resS

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

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

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

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

        parseContexts :: ParsecT String () Identity [[String]]
parseContexts =
            ParsecT String () Identity [String]
-> ParsecT String () Identity ()
-> ParsecT String () Identity [[String]]
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 (ParsecT String () Identity String
-> ParsecT String () Identity [String]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many1 ParsecT String () Identity String
forall {u}. ParsecT String u Identity String
parseWord) (ParsecT String () Identity ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces ParsecT String () Identity ()
-> ParsecT String () Identity Char
-> ParsecT String () Identity Char
forall a b.
ParsecT String () Identity a
-> ParsecT String () Identity b -> ParsecT String () Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
',' ParsecT String () Identity Char
-> ParsecT String () Identity () -> ParsecT String () Identity ()
forall a b.
ParsecT String () Identity a
-> ParsecT String () Identity b -> ParsecT String () Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> ParsecT String () Identity ()
forall a. a -> ParsecT String () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ())


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

-- | See 'mkYesodDataOpts'
--
-- @since 1.6.25.0
mkYesodDispatchOpts :: RouteOpts -> String -> [ResourceTree String] -> Q [Dec]
mkYesodDispatchOpts :: RouteOpts -> String -> [ResourceTree String] -> Q [Dec]
mkYesodDispatchOpts RouteOpts
opts String
name = (([Dec], [Dec]) -> [Dec]) -> Q ([Dec], [Dec]) -> Q [Dec]
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Dec], [Dec]) -> [Dec]
forall a b. (a, b) -> b
snd (Q ([Dec], [Dec]) -> Q [Dec])
-> ([ResourceTree String] -> Q ([Dec], [Dec]))
-> [ResourceTree String]
-> Q [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RouteOpts
-> String
-> Bool
-> (Exp -> Q Exp)
-> [ResourceTree String]
-> Q ([Dec], [Dec])
mkYesodWithParserOpts RouteOpts
opts String
name Bool
False Exp -> Q Exp
forall a. a -> Q a
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 BndrVis] -> Type -> Dec
TySynD (String -> Name
mkName String
"Handler") ((Name -> TyVarBndr BndrVis) -> [Name] -> [TyVarBndr BndrVis]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> TyVarBndr BndrVis
forall flag. DefaultBndrFlag flag => Name -> TyVarBndr flag
plainTV [Name]
vs)
      (Type -> Dec) -> Type -> Dec
forall a b. (a -> b) -> a -> b
$ Name -> Type
ConT ''HandlerFor Type -> Type -> Type
`AppT` Type
site
    , Name -> [TyVarBndr BndrVis] -> Type -> Dec
TySynD (String -> Name
mkName String
"Widget")  ((Name -> TyVarBndr BndrVis) -> [Name] -> [TyVarBndr BndrVis]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> TyVarBndr BndrVis
forall flag. DefaultBndrFlag flag => Name -> TyVarBndr flag
plainTV [Name]
vs)
      (Type -> Dec) -> Type -> Dec
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 :: [[String]]
-> String
-> [String]
-> Bool
-> (Exp -> Q Exp)
-> [ResourceTree String]
-> Q ([Dec], [Dec])
mkYesodGeneral = RouteOpts
-> [[String]]
-> String
-> [String]
-> Bool
-> (Exp -> Q Exp)
-> [ResourceTree String]
-> 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
-> [[String]]
-> String
-> [String]
-> Bool
-> (Exp -> Q Exp)
-> [ResourceTree String]
-> Q ([Dec], [Dec])
mkYesodGeneralOpts RouteOpts
opts [[String]]
appCxt' String
namestr [String]
mtys Bool
isSub Exp -> Q Exp
f [ResourceTree String]
resS = do
    let appCxt :: [Type]
appCxt = ([String] -> Type) -> [[String]] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\[String]
ctxs ->
            case [String]
ctxs of
                String
c:[String]
rest ->
                    (Type -> String -> Type) -> Type -> [String] -> Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Type
acc String
v -> Type
acc Type -> Type -> Type
`AppT` String -> Type
nameToType String
v) (Name -> Type
ConT (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
c) [String]
rest
                [] -> String -> Type
forall a. HasCallStack => String -> a
error (String -> Type) -> String -> Type
forall a b. (a -> b) -> a -> b
$ String
"Bad context: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. Show a => a -> String
show [String]
ctxs
          ) [[String]]
appCxt'
    mname <- String -> Q (Maybe Name)
lookupTypeName String
namestr
    arity <- case mname of
               Just Name
name -> do
                 info <- Name -> Q Info
reify Name
name
                 return $
                   case info of
                     TyConI Dec
dec ->
                       case Dec
dec of
                         DataD [Type]
_ Name
_ [TyVarBndr BndrVis]
vs Maybe Type
_ [Con]
_ [DerivClause]
_ -> [TyVarBndr BndrVis] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TyVarBndr BndrVis]
vs
                         NewtypeD [Type]
_ Name
_ [TyVarBndr BndrVis]
vs Maybe Type
_ Con
_ [DerivClause]
_ -> [TyVarBndr BndrVis] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TyVarBndr BndrVis]
vs
                         TySynD Name
_ [TyVarBndr BndrVis]
vs Type
_ -> [TyVarBndr BndrVis] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TyVarBndr BndrVis]
vs
                         Dec
_ -> Int
0
                     Info
_ -> Int
0
               Maybe Name
_ -> Int -> Q Int
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
0
    let name = String -> Name
mkName String
namestr
    -- Generate as many variable names as the arity indicates
    vns <- replicateM (arity - length mtys) $ newName "t"
    -- types that you apply to get a concrete site name
    let argtypes = (String -> Type) -> [String] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Type
nameToType [String]
mtys [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ (Name -> Type) -> [Name] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
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 = ((String -> Name) -> [String] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Name
mkName ([String] -> [Name])
-> ([String] -> [String]) -> [String] -> [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter String -> Bool
isTvar) [String]
mtys [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name]
vns
        -- Base type (site type with variables)
    let site = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall b a. (b -> a -> b) -> b -> [a] -> b
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 String -> ResourceTree Type)
-> [ResourceTree String] -> [ResourceTree Type]
forall a b. (a -> b) -> [a] -> [b]
map ((String -> Type) -> ResourceTree String -> ResourceTree Type
forall a b. (a -> b) -> ResourceTree a -> ResourceTree b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> Type
parseType (String -> Type) -> (String -> String) -> String -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
dropBracket)) [ResourceTree String]
resS
    renderRouteDec <- mkRenderRouteInstanceOpts opts appCxt site res
    routeAttrsDec  <- mkRouteAttrsInstance appCxt site res
    dispatchDec    <- mkDispatchInstance site appCxt f res
    parseRoute <- mkParseRouteInstance appCxt site res
    let rname = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"resources" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
namestr
    eres <- lift resS
    let resourcesDec =
            [ Name -> Type -> Dec
SigD Name
rname (Type -> Dec) -> Type -> Dec
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]] -> [Dec]
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
            ]
    return (dataDec, 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 String -> String -> Q Exp
mdsGetHandler = Maybe String -> String -> 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' <-
        MkDispatchSettings (ZonkAny 2) (ZonkAny 1) (ZonkAny 0)
-> [ResourceTree c] -> Q Clause
forall b site c a.
MkDispatchSettings b site c -> [ResourceTree a] -> Q Clause
mkDispatchClause
            ((Exp -> Q Exp)
-> Q Exp
-> Q Exp
-> MkDispatchSettings (ZonkAny 2) (ZonkAny 1) (ZonkAny 0)
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 = Name -> [Clause] -> Dec
FunD 'yesodDispatch [Clause
clause']
    return [instanceD cxt yDispatch [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' <-
        MkDispatchSettings (ZonkAny 5) (ZonkAny 4) (ZonkAny 3)
-> [ResourceTree a] -> Q Clause
forall b site c a.
MkDispatchSettings b site c -> [ResourceTree a] -> Q Clause
mkDispatchClause
            ((Exp -> Q Exp)
-> Q Exp
-> Q Exp
-> MkDispatchSettings (ZonkAny 5) (ZonkAny 4) (ZonkAny 3)
forall a site b.
(Exp -> Q Exp) -> Q Exp -> Q Exp -> MkDispatchSettings a site b
mkMDS
                Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return
                [|subHelper|]
                [|subTopDispatch|])
        [ResourceTree a]
res
    inner <- newName "inner"
    let innerFun = Name -> [Clause] -> Dec
FunD Name
inner [Clause
clause']
    helper <- newName "helper"
    let fun = Name -> [Clause] -> Dec
FunD Name
helper
                [ [Pat] -> Body -> [Dec] -> Clause
Clause
                    []
                    (Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
inner)
                    [Dec
innerFun]
                ]
    return $ LetE [fun] (VarE 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 = YesodSubRunnerEnv sub master -> Application
forall sub master.
YesodSubDispatch sub master =>
YesodSubRunnerEnv sub master -> Application
yesodSubDispatch
            (YesodSubRunnerEnv
            { ysreParentRunner :: ParentRunner master
ysreParentRunner = YesodSubRunnerEnv mid master -> ParentRunner master
forall sub parent.
YesodSubRunnerEnv sub parent -> ParentRunner parent
ysreParentRunner YesodSubRunnerEnv mid master
env
            , ysreGetSub :: master -> sub
ysreGetSub = mid -> sub
getSub (mid -> sub) -> (master -> mid) -> master -> sub
forall b c a. (b -> c) -> (a -> b) -> a -> c
. YesodSubRunnerEnv mid master -> master -> mid
forall sub parent. YesodSubRunnerEnv sub parent -> parent -> sub
ysreGetSub YesodSubRunnerEnv mid master
env
            , ysreToParentRoute :: Route sub -> Route master
ysreToParentRoute = YesodSubRunnerEnv mid master -> Route mid -> Route master
forall sub parent.
YesodSubRunnerEnv sub parent -> Route sub -> Route parent
ysreToParentRoute YesodSubRunnerEnv mid master
env (Route mid -> Route master)
-> (Route sub -> Route mid) -> Route sub -> Route master
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Route sub -> Route mid
toParent
            , ysreParentEnv :: YesodRunnerEnv master
ysreParentEnv = YesodSubRunnerEnv mid master -> YesodRunnerEnv master
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 Maybe Overlap
forall a. Maybe a
Nothing