    {-# LANGUAGE CPP #-}
    {-# LANGUAGE RecordWildCards #-}
    {-# LANGUAGE TemplateHaskell #-}

    module Yesod.Routes.TH.RouteAttrs
        ( mkRouteAttrsInstance
        ) where

    import Yesod.Routes.TH.Types
    import Yesod.Routes.Class
    import Language.Haskell.TH.Syntax
    import Data.Set (fromList)
    import Data.Text (pack)

    mkRouteAttrsInstance :: Cxt -> Type -> [ResourceTree a] -> Q Dec
    mkRouteAttrsInstance :: forall a. Cxt -> Type -> [ResourceTree a] -> Q Dec
    mkRouteAttrsInstance Cxt
    cxt Type
    typ [ResourceTree a]
    ress = do
        clauses <- (ResourceTree a -> Q [Clause]) -> [ResourceTree a] -> 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 ((Pat -> Pat) -> ResourceTree a -> Q [Clause]
    forall a. (Pat -> Pat) -> ResourceTree a -> Q [Clause]
    goTree Pat -> Pat
    forall a. a -> a
    id) [ResourceTree a]
    ress
        return $ instanceD cxt (ConT ''RouteAttrs `AppT` typ)
            [ FunD 'routeAttrs $ concat clauses
            ]

    goTree :: (Pat -> Pat) -> ResourceTree a -> Q [Clause]
    goTree :: forall a. (Pat -> Pat) -> ResourceTree a -> Q [Clause]
    goTree Pat -> Pat
    front (ResourceLeaf Resource a
    res) = Clause -> [Clause]
    forall a. a -> [a]
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Clause -> [Clause]) -> Q Clause -> Q [Clause]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> (Pat -> Pat) -> Resource a -> Q Clause
    forall a. (Pat -> Pat) -> Resource a -> Q Clause
    goRes Pat -> Pat
    front Resource a
    res
    goTree Pat -> Pat
    front (ResourceParent String
    name CheckOverlap
    _check [Piece a]
    pieces [ResourceTree a]
    trees) =
        [[Clause]] -> [Clause]
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat ([[Clause]] -> [Clause]) -> Q [[Clause]] -> Q [Clause]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> (ResourceTree a -> Q [Clause]) -> [ResourceTree a] -> 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 ((Pat -> Pat) -> ResourceTree a -> Q [Clause]
    forall a. (Pat -> Pat) -> ResourceTree a -> Q [Clause]
    goTree Pat -> Pat
    front') [ResourceTree a]
    trees
      where
        ignored :: Pat -> [Pat]
    ignored = (Int -> Pat -> [Pat]
    forall a. Int -> a -> [a]
    replicate Int
    toIgnore Pat
    WildP [Pat] -> [Pat] -> [Pat]
    forall a. [a] -> [a] -> [a]
    ++) ([Pat] -> [Pat]) -> (Pat -> [Pat]) -> Pat -> [Pat]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Pat -> [Pat]
    forall a. a -> [a]
    forall (m :: * -> *) a. Monad m => a -> m a
    return
        toIgnore :: Int
    toIgnore = [Piece a] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length ([Piece a] -> Int) -> [Piece a] -> Int
    forall a b. (a -> b) -> a -> b
    $ (Piece a -> CheckOverlap) -> [Piece a] -> [Piece a]
    forall a. (a -> CheckOverlap) -> [a] -> [a]
    filter Piece a -> CheckOverlap
    forall {typ}. Piece typ -> CheckOverlap
    isDynamic [Piece a]
    pieces
        isDynamic :: Piece typ -> CheckOverlap
    isDynamic Dynamic{} = CheckOverlap
    True
        isDynamic Static{} = CheckOverlap
    False
        front' :: Pat -> Pat
    front' = Pat -> Pat
    front (Pat -> Pat) -> (Pat -> Pat) -> Pat -> Pat
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Name -> Cxt -> [Pat] -> Pat
    ConP (String -> Name
    mkName String
    name)
    #if MIN_VERSION_template_haskell(2,18,0)
                              []
    #endif
                       ([Pat] -> Pat) -> (Pat -> [Pat]) -> Pat -> Pat
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Pat -> [Pat]
    ignored

    goRes :: (Pat -> Pat) -> Resource a -> Q Clause
    goRes :: forall a. (Pat -> Pat) -> Resource a -> Q Clause
    goRes Pat -> Pat
    front Resource {CheckOverlap
    String
    [String]
    [Piece a]
    Dispatch a
    resourceName :: String
    resourcePieces :: [Piece a]
    resourceDispatch :: Dispatch a
    resourceAttrs :: [String]
    resourceCheck :: CheckOverlap
    resourceCheck :: forall typ. Resource typ -> CheckOverlap
    resourceAttrs :: forall typ. Resource typ -> [String]
    resourceDispatch :: forall typ. Resource typ -> Dispatch typ
    resourcePieces :: forall typ. Resource typ -> [Piece typ]
    resourceName :: forall typ. Resource typ -> String
    ..} =
        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
    front (Pat -> Pat) -> Pat -> Pat
    forall a b. (a -> b) -> a -> b
    $ Name -> [FieldPat] -> Pat
    RecP (String -> Name
    mkName String
    resourceName) []]
            (Exp -> Body
    NormalB (Exp -> Body) -> Exp -> Body
    forall a b. (a -> b) -> a -> b
    $ Name -> Exp
    VarE 'fromList Exp -> Exp -> Exp
    `AppE` [Exp] -> Exp
    ListE ((String -> Exp) -> [String] -> [Exp]
    forall a b. (a -> b) -> [a] -> [b]
    map String -> Exp
    toText [String]
    resourceAttrs))
            []
      where
        toText :: String -> Exp
    toText String
    s = Name -> Exp
    VarE 'pack Exp -> Exp -> Exp
    `AppE` Lit -> Exp
    LitE (String -> Lit
    StringL String
    s)

    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