{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}

module Yesod.Routes.TH.RenderRoute
    ( -- ** RenderRoute
      mkRenderRouteInstanceOpts
    , mkRouteConsOpts
    , mkRenderRouteClauses
    , shouldCreateResources

    , RouteOpts
    , defaultOpts
    , setEqDerived
    , setShowDerived
    , setReadDerived
    , setCreateResources
    , setParameterizedSubroute
    ) where

import Yesod.Routes.TH.Types
import Language.Haskell.TH.Syntax
import Data.Maybe (maybeToList)
import Control.Monad (replicateM)
import Data.Text (pack)
import Web.PathPieces (PathPiece (..), PathMultiPiece (..))
import Yesod.Routes.Class
import Data.Foldable

-- | General opts data type for generating yesod.
--
-- Contains options for customizing code generation for the router in
-- 'mkYesodData', including what type class instances will be derived for
-- the route datatype, whether to parameterize subroutes,
-- and whether or not to create the @resources :: [ResourceTree String]@ value.
-- Use the setting functions on `defaultOpts` to set specific fields.
--
-- @since 1.6.25.0
data RouteOpts = MkRouteOpts
    { RouteOpts -> Bool
roDerivedEq   :: Bool
    , RouteOpts -> Bool
roDerivedShow :: Bool
    , RouteOpts -> Bool
roDerivedRead :: Bool
    , RouteOpts -> Bool
roCreateResources :: Bool
    , RouteOpts -> Bool
roParameterizedSubroute :: Bool
    }

-- | Default options for generating routes.
--
-- Defaults to all instances derived, subroutes being unparameterized, and to
-- create the @resourcesSite :: [ResourceTree String]@ term.
--
-- @since 1.6.25.0
defaultOpts :: RouteOpts
defaultOpts :: RouteOpts
defaultOpts = MkRouteOpts
    { roDerivedEq :: Bool
roDerivedEq = Bool
True
    , roDerivedShow :: Bool
roDerivedShow = Bool
True
    , roDerivedRead :: Bool
roDerivedRead = Bool
True
    , roCreateResources :: Bool
roCreateResources = Bool
True
    , roParameterizedSubroute :: Bool
roParameterizedSubroute = Bool
False
    }

-- |
--
-- @since 1.6.25.0
setEqDerived :: Bool -> RouteOpts -> RouteOpts
setEqDerived :: Bool -> RouteOpts -> RouteOpts
setEqDerived Bool
b RouteOpts
rdo = RouteOpts
rdo { roDerivedEq = b }

-- |
--
-- @since 1.6.25.0
setShowDerived :: Bool -> RouteOpts -> RouteOpts
setShowDerived :: Bool -> RouteOpts -> RouteOpts
setShowDerived Bool
b RouteOpts
rdo = RouteOpts
rdo { roDerivedShow = b }

-- |
--
-- @since 1.6.25.0
setReadDerived :: Bool -> RouteOpts -> RouteOpts
setReadDerived :: Bool -> RouteOpts -> RouteOpts
setReadDerived Bool
b RouteOpts
rdo = RouteOpts
rdo { roDerivedRead = b }

-- | Determine whether or not to generate the @resourcesApp@ value.
--
-- Disabling this can be useful if you are creating the @routes ::
-- [ResourceTree String]@ elsewhere in your module, and referring to it
-- here. The @resourcesApp@ can become very large in large applications,
-- and duplicating it can result in signifiacntly higher compile times.
--
-- @since 1.6.28.0
setCreateResources :: Bool -> RouteOpts -> RouteOpts
setCreateResources :: Bool -> RouteOpts -> RouteOpts
setCreateResources Bool
b RouteOpts
rdo = RouteOpts
rdo { roCreateResources = b }

-- | Returns whether or not we should create the @resourcesSite ::
-- [ResourceTree String]@ value during code generation.
--
-- @since 1.6.28.0
shouldCreateResources :: RouteOpts -> Bool
shouldCreateResources :: RouteOpts -> Bool
shouldCreateResources = RouteOpts -> Bool
roCreateResources

-- | If True, we will correctly pass parameters for subroutes around.
--
-- @since 1.6.28.0
setParameterizedSubroute :: Bool -> RouteOpts -> RouteOpts
setParameterizedSubroute :: Bool -> RouteOpts -> RouteOpts
setParameterizedSubroute Bool
b RouteOpts
rdo = RouteOpts
rdo { roParameterizedSubroute = b }

-- |
--
-- @since 1.6.25.0
instanceNamesFromOpts :: RouteOpts -> [Name]
instanceNamesFromOpts :: RouteOpts -> [Name]
instanceNamesFromOpts MkRouteOpts {Bool
roDerivedEq :: RouteOpts -> Bool
roDerivedShow :: RouteOpts -> Bool
roDerivedRead :: RouteOpts -> Bool
roCreateResources :: RouteOpts -> Bool
roParameterizedSubroute :: RouteOpts -> Bool
roDerivedEq :: Bool
roDerivedShow :: Bool
roDerivedRead :: Bool
roCreateResources :: Bool
roParameterizedSubroute :: Bool
..} = Bool -> Name -> [Name] -> [Name]
forall {a}. Bool -> a -> [a] -> [a]
prependIf Bool
roDerivedEq ''Eq ([Name] -> [Name]) -> [Name] -> [Name]
forall a b. (a -> b) -> a -> b
$ Bool -> Name -> [Name] -> [Name]
forall {a}. Bool -> a -> [a] -> [a]
prependIf Bool
roDerivedShow ''Show ([Name] -> [Name]) -> [Name] -> [Name]
forall a b. (a -> b) -> a -> b
$ Bool -> Name -> [Name] -> [Name]
forall {a}. Bool -> a -> [a] -> [a]
prependIf Bool
roDerivedRead ''Read []
    where prependIf :: Bool -> a -> [a] -> [a]
prependIf Bool
b = if Bool
b then (:) else ([a] -> [a]) -> a -> [a] -> [a]
forall a b. a -> b -> a
const [a] -> [a]
forall a. a -> a
id

-- | Nullify the list unless we are using parameterised subroutes.
nullifyWhenNoParam :: RouteOpts -> [a] -> [a]
nullifyWhenNoParam :: forall a. RouteOpts -> [a] -> [a]
nullifyWhenNoParam RouteOpts
opts = if RouteOpts -> Bool
roParameterizedSubroute RouteOpts
opts then [a] -> [a]
forall a. a -> a
id else [a] -> [a] -> [a]
forall a b. a -> b -> a
const []

-- | Generate the constructors of a route data type, with custom opts.
--
-- @since 1.6.25.0
mkRouteConsOpts :: RouteOpts -> Cxt -> [(Type, Name)] -> [ResourceTree Type] -> ([Con], [Dec])
mkRouteConsOpts :: RouteOpts
-> Cxt -> [(Type, Name)] -> [ResourceTree Type] -> ([Con], [Dec])
mkRouteConsOpts RouteOpts
opts Cxt
cxt (RouteOpts -> [(Type, Name)] -> [(Type, Name)]
forall a. RouteOpts -> [a] -> [a]
nullifyWhenNoParam RouteOpts
opts -> [(Type, Name)]
tyargs) =
    [ResourceTree Type] -> ([Con], [Dec])
mkRouteConsOpts'
  where
    -- th-abstraction does cover this but the version it was introduced in
    -- isn't always available
    tyvarbndr :: Name -> TyVarBndr BndrVis
tyvarbndr =
#if MIN_VERSION_template_haskell(2,21,0)
        (Name -> BndrVis -> TyVarBndr BndrVis
forall flag. Name -> flag -> TyVarBndr flag
`PlainTV` BndrVis
BndrReq) :: Name -> TyVarBndr BndrVis
#elif MIN_VERSION_template_haskell(2,17,0)
        (`PlainTV` ()) :: Name -> TyVarBndr ()
#else
        PlainTV :: Name -> TyVarBndr
#endif

    subrouteDecTypeArgs :: [TyVarBndr BndrVis]
subrouteDecTypeArgs = ((Type, Name) -> TyVarBndr BndrVis)
-> [(Type, 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
tyvarbndr (Name -> TyVarBndr BndrVis)
-> ((Type, Name) -> Name) -> (Type, Name) -> TyVarBndr BndrVis
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type, Name) -> Name
forall a b. (a, b) -> b
snd) [(Type, Name)]
tyargs

    ([DerivClause]
inlineDerives, Type -> [Dec]
mkSds) = RouteOpts -> Cxt -> ([DerivClause], Type -> [Dec])
getDerivesFor RouteOpts
opts (RouteOpts -> Cxt -> Cxt
forall a. RouteOpts -> [a] -> [a]
nullifyWhenNoParam RouteOpts
opts Cxt
cxt)

    mkRouteConsOpts' :: [ResourceTree Type] -> ([Con], [Dec])
    mkRouteConsOpts' :: [ResourceTree Type] -> ([Con], [Dec])
mkRouteConsOpts' = (ResourceTree Type -> ([Con], [Dec]))
-> [ResourceTree Type] -> ([Con], [Dec])
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ResourceTree Type -> ([Con], [Dec])
mkRouteCon

    mkRouteCon :: ResourceTree Type -> ([Con], [Dec])
mkRouteCon (ResourceLeaf Resource Type
res) =
        ([Con
con], [])
      where
        con :: Con
con = Name -> [BangType] -> Con
NormalC (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Resource Type -> String
forall typ. Resource typ -> String
resourceName Resource Type
res)
            ([BangType] -> Con) -> [BangType] -> Con
forall a b. (a -> b) -> a -> b
$ (Type -> BangType) -> Cxt -> [BangType]
forall a b. (a -> b) -> [a] -> [b]
map (Bang
notStrict,)
            (Cxt -> [BangType]) -> Cxt -> [BangType]
forall a b. (a -> b) -> a -> b
$ [Cxt] -> Cxt
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [Cxt
singles, Cxt
multi, Cxt
sub]
        singles :: Cxt
singles = (Piece Type -> Cxt) -> [Piece Type] -> Cxt
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Piece Type -> Cxt
forall {a}. Piece a -> [a]
toSingle ([Piece Type] -> Cxt) -> [Piece Type] -> Cxt
forall a b. (a -> b) -> a -> b
$ Resource Type -> [Piece Type]
forall typ. Resource typ -> [Piece typ]
resourcePieces Resource Type
res
        toSingle :: Piece a -> [a]
toSingle Static{} = []
        toSingle (Dynamic a
typ) = [a
typ]

        multi :: Cxt
multi = Maybe Type -> Cxt
forall a. Maybe a -> [a]
maybeToList (Maybe Type -> Cxt) -> Maybe Type -> Cxt
forall a b. (a -> b) -> a -> b
$ Resource Type -> Maybe Type
forall typ. Resource typ -> Maybe typ
resourceMulti Resource Type
res

        sub :: Cxt
sub =
            case Resource Type -> Dispatch Type
forall typ. Resource typ -> Dispatch typ
resourceDispatch Resource Type
res of
                Subsite { subsiteType :: forall typ. Dispatch typ -> typ
subsiteType = Type
typ } -> [Name -> Type
ConT ''Route Type -> Type -> Type
`AppT` Type
typ]
                Dispatch Type
_ -> []

    mkRouteCon (ResourceParent String
name Bool
_check [Piece Type]
pieces [ResourceTree Type]
children) =
        let ([Con]
cons, [Dec]
decs) = [ResourceTree Type] -> ([Con], [Dec])
mkRouteConsOpts' [ResourceTree Type]
children
            dec :: Dec
dec = Cxt
-> Name
-> [TyVarBndr BndrVis]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataD [] Name
dataName [TyVarBndr BndrVis]
subrouteDecTypeArgs Maybe Type
forall a. Maybe a
Nothing [Con]
cons [DerivClause]
inlineDerives
        in ([Con
con], Dec
dec Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: [Dec]
decs [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ Type -> [Dec]
mkSds Type
consDataType)
      where
        con :: Con
con = Name -> [BangType] -> Con
NormalC Name
dataName
            ([BangType] -> Con) -> [BangType] -> Con
forall a b. (a -> b) -> a -> b
$ (Type -> BangType) -> Cxt -> [BangType]
forall a b. (a -> b) -> [a] -> [b]
map (Bang
notStrict,)
            (Cxt -> [BangType]) -> Cxt -> [BangType]
forall a b. (a -> b) -> a -> b
$ Cxt
singles Cxt -> Cxt -> Cxt
forall a. [a] -> [a] -> [a]
++ [Type
consDataType]

        singles :: Cxt
singles = (Piece Type -> Cxt) -> [Piece Type] -> Cxt
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Piece Type -> Cxt
forall {a}. Piece a -> [a]
toSingle [Piece Type]
pieces
        toSingle :: Piece a -> [a]
toSingle Static{} = []
        toSingle (Dynamic a
typ) = [a
typ]

        dataName :: Name
dataName = String -> Name
mkName String
name
        consDataType :: Type
consDataType = (Type -> (Type, Name) -> Type) -> Type -> [(Type, Name)] -> 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
b (Type, Name)
a -> Type
b Type -> Type -> Type
`AppT` (Type, Name) -> Type
forall a b. (a, b) -> a
fst (Type, Name)
a) (Name -> Type
ConT Name
dataName) [(Type, Name)]
tyargs

-- | Clauses for the 'renderRoute' method.
mkRenderRouteClauses :: [ResourceTree Type] -> Q [Clause]
mkRenderRouteClauses :: [ResourceTree Type] -> Q [Clause]
mkRenderRouteClauses =
    (ResourceTree Type -> Q Clause)
-> [ResourceTree Type] -> Q [Clause]
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 ResourceTree Type -> Q Clause
go
  where
    isDynamic :: Piece typ -> Bool
isDynamic Dynamic{} = Bool
True
    isDynamic Piece typ
_ = Bool
False

    go :: ResourceTree Type -> Q Clause
go (ResourceParent String
name Bool
_check [Piece Type]
pieces [ResourceTree Type]
children) = do
        let cnt :: Int
cnt = [Piece Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Piece Type] -> Int) -> [Piece Type] -> Int
forall a b. (a -> b) -> a -> b
$ (Piece Type -> Bool) -> [Piece Type] -> [Piece Type]
forall a. (a -> Bool) -> [a] -> [a]
filter Piece Type -> Bool
forall {typ}. Piece typ -> Bool
isDynamic [Piece Type]
pieces
        [Name]
dyns <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
cnt (Q Name -> Q [Name]) -> Q Name -> Q [Name]
forall a b. (a -> b) -> a -> b
$ String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"dyn"
        Name
child <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"child"
        let pat :: Pat
pat = Name -> [Pat] -> Pat
conPCompat (String -> Name
mkName String
name) ([Pat] -> Pat) -> [Pat] -> Pat
forall a b. (a -> b) -> a -> b
$ (Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP ([Name] -> [Pat]) -> [Name] -> [Pat]
forall a b. (a -> b) -> a -> b
$ [Name]
dyns [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name
child]

        Exp
pack' <- [|pack|]
        Exp
tsp <- [|toPathPiece|]
        let piecesSingle :: [Exp]
piecesSingle = (String -> Exp) -> Exp -> [Piece Type] -> [Name] -> [Exp]
forall {typ}.
(String -> Exp) -> Exp -> [Piece typ] -> [Name] -> [Exp]
mkPieces (Exp -> Exp -> Exp
AppE Exp
pack' (Exp -> Exp) -> (String -> Exp) -> String -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lit -> Exp
LitE (Lit -> Exp) -> (String -> Lit) -> String -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Lit
StringL) Exp
tsp [Piece Type]
pieces [Name]
dyns

        Name
childRender <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"childRender"
        let rr :: Exp
rr = Name -> Exp
VarE Name
childRender
        [Clause]
childClauses <- [ResourceTree Type] -> Q [Clause]
mkRenderRouteClauses [ResourceTree Type]
children

        Name
a <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"a"
        Name
b <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"b"

        Exp
colon <- [|(:)|]
        let cons :: Exp -> Exp -> Exp
cons Exp
y Exp
ys = Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE (Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
y) Exp
colon (Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
ys)
        let pieces' :: Exp
pieces' = (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
cons (Name -> Exp
VarE Name
a) [Exp]
piecesSingle

        let body :: Exp
body = [Pat] -> Exp -> Exp
LamE [[Pat] -> Pat
TupP [Name -> Pat
VarP Name
a, Name -> Pat
VarP Name
b]] ([Maybe Exp] -> Exp
TupE
#if MIN_VERSION_template_haskell(2,16,0)
                                                  ([Maybe Exp] -> Exp) -> [Maybe Exp] -> Exp
forall a b. (a -> b) -> a -> b
$ (Exp -> Maybe Exp) -> [Exp] -> [Maybe Exp]
forall a b. (a -> b) -> [a] -> [b]
map Exp -> Maybe Exp
forall a. a -> Maybe a
Just
#endif
                                                  [Exp
pieces', Name -> Exp
VarE Name
b]
                                                ) Exp -> Exp -> Exp
`AppE` (Exp
rr Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
child)

        Clause -> Q Clause
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Clause -> Q Clause) -> Clause -> Q Clause
forall a b. (a -> b) -> a -> b
$ [Pat] -> Body -> [Dec] -> Clause
Clause [Pat
pat] (Exp -> Body
NormalB Exp
body) [Name -> [Clause] -> Dec
FunD Name
childRender [Clause]
childClauses]

    go (ResourceLeaf Resource Type
res) = do
        let cnt :: Int
cnt = [Piece Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((Piece Type -> Bool) -> [Piece Type] -> [Piece Type]
forall a. (a -> Bool) -> [a] -> [a]
filter Piece Type -> Bool
forall {typ}. Piece typ -> Bool
isDynamic ([Piece Type] -> [Piece Type]) -> [Piece Type] -> [Piece Type]
forall a b. (a -> b) -> a -> b
$ Resource Type -> [Piece Type]
forall typ. Resource typ -> [Piece typ]
resourcePieces Resource Type
res) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int -> (Type -> Int) -> Maybe Type -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 (Int -> Type -> Int
forall a b. a -> b -> a
const Int
1) (Resource Type -> Maybe Type
forall typ. Resource typ -> Maybe typ
resourceMulti Resource Type
res)
        [Name]
dyns <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
cnt (Q Name -> Q [Name]) -> Q Name -> Q [Name]
forall a b. (a -> b) -> a -> b
$ String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"dyn"
        [Name]
sub <-
            case Resource Type -> Dispatch Type
forall typ. Resource typ -> Dispatch typ
resourceDispatch Resource Type
res of
                Subsite{} -> Name -> [Name]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> [Name]) -> Q Name -> Q [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"sub"
                Dispatch Type
_ -> [Name] -> Q [Name]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return []
        let pat :: Pat
pat = Name -> [Pat] -> Pat
conPCompat (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Resource Type -> String
forall typ. Resource typ -> String
resourceName Resource Type
res) ([Pat] -> Pat) -> [Pat] -> Pat
forall a b. (a -> b) -> a -> b
$ (Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP ([Name] -> [Pat]) -> [Name] -> [Pat]
forall a b. (a -> b) -> a -> b
$ [Name]
dyns [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name]
sub

        Exp
pack' <- [|pack|]
        Exp
tsp <- [|toPathPiece|]
        let piecesSingle :: [Exp]
piecesSingle = (String -> Exp) -> Exp -> [Piece Type] -> [Name] -> [Exp]
forall {typ}.
(String -> Exp) -> Exp -> [Piece typ] -> [Name] -> [Exp]
mkPieces (Exp -> Exp -> Exp
AppE Exp
pack' (Exp -> Exp) -> (String -> Exp) -> String -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lit -> Exp
LitE (Lit -> Exp) -> (String -> Lit) -> String -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Lit
StringL) Exp
tsp (Resource Type -> [Piece Type]
forall typ. Resource typ -> [Piece typ]
resourcePieces Resource Type
res) [Name]
dyns

        Exp
piecesMulti <-
            case Resource Type -> Maybe Type
forall typ. Resource typ -> Maybe typ
resourceMulti Resource Type
res of
                Maybe Type
Nothing -> 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
$ [Exp] -> Exp
ListE []
                Just{} -> do
                    Exp
tmp <- [|toPathMultiPiece|]
                    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
$ Exp
tmp Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE ([Name] -> Name
forall a. HasCallStack => [a] -> a
last [Name]
dyns)

        Exp
body <-
            case [Name]
sub of
                [Name
x] -> do
                    Exp
rr <- [|renderRoute|]
                    Name
a <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"a"
                    Name
b <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"b"

                    Exp
colon <- [|(:)|]
                    let cons :: Exp -> Exp -> Exp
cons Exp
y Exp
ys = Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE (Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
y) Exp
colon (Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
ys)
                    let pieces :: Exp
pieces = (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
cons (Name -> Exp
VarE Name
a) [Exp]
piecesSingle

                    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
$ [Pat] -> Exp -> Exp
LamE [[Pat] -> Pat
TupP [Name -> Pat
VarP Name
a, Name -> Pat
VarP Name
b]] ([Maybe Exp] -> Exp
TupE
#if MIN_VERSION_template_haskell(2,16,0)
                                                            ([Maybe Exp] -> Exp) -> [Maybe Exp] -> Exp
forall a b. (a -> b) -> a -> b
$ (Exp -> Maybe Exp) -> [Exp] -> [Maybe Exp]
forall a b. (a -> b) -> [a] -> [b]
map Exp -> Maybe Exp
forall a. a -> Maybe a
Just
#endif
                                                            [Exp
pieces, Name -> Exp
VarE Name
b]
                                                          ) Exp -> Exp -> Exp
`AppE` (Exp
rr Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
x)
                [Name]
_ -> do
                    Exp
colon <- [|(:)|]
                    let cons :: Exp -> Exp -> Exp
cons Exp
a Exp
b = Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE (Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
a) Exp
colon (Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
b)
                    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
$ [Maybe Exp] -> Exp
TupE
#if MIN_VERSION_template_haskell(2,16,0)
                      ([Maybe Exp] -> Exp) -> [Maybe Exp] -> Exp
forall a b. (a -> b) -> a -> b
$ (Exp -> Maybe Exp) -> [Exp] -> [Maybe Exp]
forall a b. (a -> b) -> [a] -> [b]
map Exp -> Maybe Exp
forall a. a -> Maybe a
Just
#endif
                      [(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
cons Exp
piecesMulti [Exp]
piecesSingle, [Exp] -> Exp
ListE []]

        Clause -> Q Clause
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Clause -> Q Clause) -> Clause -> Q Clause
forall a b. (a -> b) -> a -> b
$ [Pat] -> Body -> [Dec] -> Clause
Clause [Pat
pat] (Exp -> Body
NormalB Exp
body) []

    mkPieces :: (String -> Exp) -> Exp -> [Piece typ] -> [Name] -> [Exp]
mkPieces String -> Exp
_ Exp
_ [] [Name]
_ = []
    mkPieces String -> Exp
toText Exp
tsp (Static String
s:[Piece typ]
ps) [Name]
dyns = String -> Exp
toText String
s Exp -> [Exp] -> [Exp]
forall a. a -> [a] -> [a]
: (String -> Exp) -> Exp -> [Piece typ] -> [Name] -> [Exp]
mkPieces String -> Exp
toText Exp
tsp [Piece typ]
ps [Name]
dyns
    mkPieces String -> Exp
toText Exp
tsp (Dynamic{}:[Piece typ]
ps) (Name
d:[Name]
dyns) = Exp
tsp Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
d Exp -> [Exp] -> [Exp]
forall a. a -> [a] -> [a]
: (String -> Exp) -> Exp -> [Piece typ] -> [Name] -> [Exp]
mkPieces String -> Exp
toText Exp
tsp [Piece typ]
ps [Name]
dyns
    mkPieces String -> Exp
_ Exp
_ (Dynamic typ
_ : [Piece typ]
_) [] = String -> [Exp]
forall a. HasCallStack => String -> a
error String
"mkPieces 120"

-- | Generate the 'RenderRoute' instance.
--
-- This includes both the 'Route' associated type and the
-- 'renderRoute' method.  This function uses both 'mkRouteConsOpts' and
-- 'mkRenderRouteClauses'.
--
-- @since 1.6.25.0
mkRenderRouteInstanceOpts :: RouteOpts -> Cxt -> [(Type, Name)] -> Type -> [ResourceTree Type] -> Q [Dec]
mkRenderRouteInstanceOpts :: RouteOpts
-> Cxt -> [(Type, Name)] -> Type -> [ResourceTree Type] -> Q [Dec]
mkRenderRouteInstanceOpts RouteOpts
opts Cxt
cxt [(Type, Name)]
tyargs Type
typ [ResourceTree Type]
ress = do
    [Clause]
cls <- [ResourceTree Type] -> Q [Clause]
mkRenderRouteClauses [ResourceTree Type]
ress
    let ([Con]
cons, [Dec]
decs) = RouteOpts
-> Cxt -> [(Type, Name)] -> [ResourceTree Type] -> ([Con], [Dec])
mkRouteConsOpts RouteOpts
opts Cxt
cxt [(Type, Name)]
tyargs [ResourceTree Type]
ress
    let did :: Dec
did = Cxt
-> Maybe [TyVarBndr ()]
-> Type
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataInstD []
#if MIN_VERSION_template_haskell(2,15,0)
            Maybe [TyVarBndr ()]
forall a. Maybe a
Nothing Type
routeDataName
#else
            ''Route [typ]
#endif
            Maybe Type
forall a. Maybe a
Nothing [Con]
cons [DerivClause]
inlineDerives
    [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ Cxt -> Type -> [Dec] -> Dec
instanceD Cxt
cxt (Name -> Type
ConT ''RenderRoute Type -> Type -> Type
`AppT` Type
typ)
        [ Dec
did
        , Name -> [Clause] -> Dec
FunD (String -> Name
mkName String
"renderRoute") [Clause]
cls
        ]
        Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: Type -> [Dec]
mkSds Type
routeDataName [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
decs
  where
    routeDataName :: Type
routeDataName = Name -> Type
ConT ''Route Type -> Type -> Type
`AppT` Type
typ
    ([DerivClause]
inlineDerives, Type -> [Dec]
mkSds) = RouteOpts -> Cxt -> ([DerivClause], Type -> [Dec])
getDerivesFor RouteOpts
opts Cxt
cxt

-- | Get the simple derivation clauses and the standalone derivation clauses
-- for a given type and context.
--
-- If there are any additional classes needed for context, we just produce standalone
-- clauses. Else, we produce basic deriving clauses for a declaration.
getDerivesFor :: RouteOpts -> Cxt -> ([DerivClause], Type ->  [Dec])
getDerivesFor :: RouteOpts -> Cxt -> ([DerivClause], Type -> [Dec])
getDerivesFor RouteOpts
opts Cxt
cxt
    | Cxt -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Cxt
cxt = ([Maybe DerivStrategy -> Cxt -> DerivClause
DerivClause Maybe DerivStrategy
forall a. Maybe a
Nothing Cxt
clazzes'], [Dec] -> Type -> [Dec]
forall a b. a -> b -> a
const [])
    | Bool
otherwise = ([], \Type
typ -> (Type -> Dec) -> Cxt -> [Dec]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe DerivStrategy -> Cxt -> Type -> Dec
StandaloneDerivD Maybe DerivStrategy
forall a. Maybe a
Nothing Cxt
cxt (Type -> Dec) -> (Type -> Type) -> Type -> Dec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type -> Type -> Type
`AppT` Type
typ)) Cxt
clazzes')
    where
    clazzes' :: Cxt
clazzes' = Name -> Type
ConT (Name -> Type) -> [Name] -> Cxt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RouteOpts -> [Name]
instanceNamesFromOpts RouteOpts
opts

notStrict :: Bang
notStrict :: Bang
notStrict = SourceUnpackedness -> SourceStrictness -> Bang
Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
NoSourceStrictness

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

conPCompat :: Name -> [Pat] -> Pat
conPCompat :: Name -> [Pat] -> Pat
conPCompat Name
n [Pat]
pats = Name -> Cxt -> [Pat] -> Pat
ConP Name
n
#if MIN_VERSION_template_haskell(2,18,0)
                         []
#endif
                         [Pat]
pats