{-# 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 :: Cxt -> Type -> [ResourceTree a] -> Q Dec
mkRouteAttrsInstance Cxt
cxt Type
typ [ResourceTree a]
ress = do
    [[Clause]]
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)
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
    Dec -> Q Dec
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 ''RouteAttrs Type -> Type -> Type
`AppT` Type
typ)
        [ Name -> [Clause] -> Dec
FunD 'routeAttrs ([Clause] -> Dec) -> [Clause] -> Dec
forall a b. (a -> b) -> a -> b
$ [[Clause]] -> [Clause]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Clause]]
clauses
        ]

goTree :: (Pat -> Pat) -> ResourceTree a -> Q [Clause]
goTree :: (Pat -> Pat) -> ResourceTree a -> Q [Clause]
goTree Pat -> Pat
front (ResourceLeaf Resource a
res) = Clause -> [Clause]
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)
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 (m :: * -> *) a. Monad m => a -> m a
return
    toIgnore :: Int
toIgnore = [Piece 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 -> [Pat] -> Pat
ConP (String -> Name
mkName String
name) ([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 :: (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
..} =
    Clause -> Q Clause
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