{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE RecordWildCards #-}
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
    [[Clause]]
clauses <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a. (Pat -> Pat) -> ResourceTree a -> Q [Clause]
goTree forall a. a -> a
id) [ResourceTree a]
ress
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Cxt -> Type -> [Dec] -> Dec
instanceD Cxt
cxt (Name -> Type
ConT ''RouteAttrs Type -> Type -> Type
`AppT` Type
typ)
        [ Name -> [Clause] -> Dec
FunD 'routeAttrs forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Clause]]
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) = forall (m :: * -> *) a. Monad m => a -> m a
return forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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) =
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a. (Pat -> Pat) -> ResourceTree a -> Q [Clause]
goTree Pat -> Pat
front') [ResourceTree a]
trees
  where
    ignored :: Pat -> [Pat]
ignored = (forall a. Int -> a -> [a]
replicate Int
toIgnore Pat
WildP forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => a -> m a
return
    toIgnore :: Int
toIgnore = forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ forall a. (a -> CheckOverlap) -> [a] -> [a]
filter 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 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
                   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
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
resourceCheck :: CheckOverlap
resourceAttrs :: [String]
resourceDispatch :: Dispatch a
resourcePieces :: [Piece a]
resourceName :: String
..} =
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Pat] -> Body -> [Dec] -> Clause
Clause
        [Pat -> Pat
front forall a b. (a -> b) -> a -> b
$ Name -> [FieldPat] -> Pat
RecP (String -> Name
mkName String
resourceName) []]
        (Exp -> Body
NormalB forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE 'fromList Exp -> Exp -> Exp
`AppE` [Exp] -> Exp
ListE (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 forall a. Maybe a
Nothing