e23c78f2ce
We now have the concept that either an entire route is overlap checked or not. This is essentially what we had before, except there was code littered everywhere on the mistaken assumption that just one component could be overlap checked. This also allows us to mark parent routes or multipiece components as non-overlapped checked. In addition, if you put a bang at the beginning of the pattern, the entire route is not overlap checked. The previous syntax is kept for backwards compatibility.
39 lines
1.2 KiB
Haskell
39 lines
1.2 KiB
Haskell
{-# 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 :: Type -> [ResourceTree a] -> Q Dec
|
|
mkRouteAttrsInstance typ ress = do
|
|
clauses <- mapM (goTree id) ress
|
|
return $ InstanceD [] (ConT ''RouteAttrs `AppT` typ)
|
|
[ FunD 'routeAttrs $ concat clauses
|
|
]
|
|
|
|
goTree :: (Pat -> Pat) -> ResourceTree a -> Q [Clause]
|
|
goTree front (ResourceLeaf res) = fmap return $ goRes front res
|
|
goTree front (ResourceParent name _check pieces trees) =
|
|
fmap concat $ mapM (goTree front') trees
|
|
where
|
|
ignored = ((replicate toIgnore WildP ++) . return)
|
|
toIgnore = length $ filter isDynamic pieces
|
|
isDynamic Dynamic{} = True
|
|
isDynamic Static{} = False
|
|
front' = front . ConP (mkName name) . ignored
|
|
|
|
goRes :: (Pat -> Pat) -> Resource a -> Q Clause
|
|
goRes front Resource {..} =
|
|
return $ Clause
|
|
[front $ RecP (mkName resourceName) []]
|
|
(NormalB $ VarE 'fromList `AppE` ListE (map toText resourceAttrs))
|
|
[]
|
|
where
|
|
toText s = VarE 'pack `AppE` LitE (StringL s)
|