RouteAttrs (fixes #531)

yesod-core/Yesod/Core.hs

@@ -11,6 +11,7 @@ module Yesod.Core
     , YesodSubDispatch (..)
     , RenderRoute (..)
     , ParseRoute (..)
+    , RouteAttrs (..)
       -- ** Breadcrumbs
     , YesodBreadcrumbs (..)
     , breadcrumbs

yesod-core/Yesod/Core/Internal/TH.hs

@@ -66,6 +66,7 @@ mkYesodGeneral :: String                   -- ^ foundation type
                -> Q([Dec],[Dec])
 mkYesodGeneral name args isSub resS = do
     renderRouteDec <- mkRenderRouteInstance site res
+    routeAttrsDec  <- mkRouteAttrsInstance site res
     dispatchDec    <- mkDispatchInstance site res
     parse <- mkParseRouteInstance site res
     let rname = mkName $ "resources" ++ name
@@ -77,6 +78,7 @@ mkYesodGeneral name args isSub resS = do
     let dataDec = concat
             [ [parse]
             , renderRouteDec
+            , [routeAttrsDec]
             , resourcesDec
             , if isSub then [] else masterTypeSyns site
             ]

yesod-core/test/YesodCoreTest/Reps.hs

@@ -12,12 +12,15 @@ import Data.Text (Text)
 import Data.Maybe (fromJust)
 import Data.Monoid (Endo (..))
 import qualified Control.Monad.Trans.Writer    as Writer
+import qualified Data.Set as Set
 
 data App = App
 
 mkYesod "App" [parseRoutes|
-/     HomeR GET
+/     HomeR GET !home
 /json JsonR GET
+/parent/#Int ParentR:
+    /#Text/child ChildR !child
 |]
 
 instance Yesod App
@@ -40,6 +43,9 @@ getJsonR = selectRep $ do
   rep typeHtml "HTML"
   provideRep $ return $ object ["message" .= ("Invalid Login" :: Text)]
 
+handleChildR :: Int -> Text -> Handler ()
+handleChildR _ _ = return ()
+
 testRequest :: Int -- ^ http status code
             -> Request
             -> ByteString -- ^ expected body
@@ -63,7 +69,8 @@ acceptRequest accept = defaultRequest
             }
 
 specs :: Spec
-specs = describe "selectRep" $ do
+specs = do
+  describe "selectRep" $ do
     test "application/json" "JSON"
     test (S8.unpack typeJson) "JSON"
     test "text/xml" "XML"
@@ -77,3 +84,7 @@ specs = describe "selectRep" $ do
     testRequest 406 (acceptRequest "text/foo") "no match found for accept header"
     test "text/*" "HTML"
     test "*/*" "HTML"
+  describe "routeAttrs" $ do
+    it "HomeR" $ routeAttrs HomeR `shouldBe` Set.singleton "home"
+    it "JsonR" $ routeAttrs JsonR `shouldBe` Set.empty
+    it "ChildR" $ routeAttrs (ParentR 5 $ ChildR "ignored") `shouldBe` Set.singleton "child"

yesod-routes/Yesod/Routes/Class.hs

@@ -3,9 +3,11 @@
 module Yesod.Routes.Class
     ( RenderRoute (..)
     , ParseRoute (..)
+    , RouteAttrs (..)
     ) where
 
 import Data.Text (Text)
+import Data.Set (Set)
 
 class Eq (Route a) => RenderRoute a where
     -- | The type-safe URLs associated with a site argument.
@@ -14,3 +16,6 @@ class Eq (Route a) => RenderRoute a where
 
 class RenderRoute a => ParseRoute a where
     parseRoute :: ([Text], [(Text, Text)]) -> Maybe (Route a)
+
+class RenderRoute a => RouteAttrs a where
+    routeAttrs :: Route a -> Set Text

yesod-routes/Yesod/Routes/TH.hs

@@ -4,6 +4,7 @@ module Yesod.Routes.TH
       -- * Functions
     , module Yesod.Routes.TH.RenderRoute
     , module Yesod.Routes.TH.ParseRoute
+    , module Yesod.Routes.TH.RouteAttrs
       -- ** Dispatch
     , module Yesod.Routes.TH.Dispatch
     ) where
@@ -11,4 +12,5 @@ module Yesod.Routes.TH
 import Yesod.Routes.TH.Types
 import Yesod.Routes.TH.RenderRoute
 import Yesod.Routes.TH.ParseRoute
+import Yesod.Routes.TH.RouteAttrs
 import Yesod.Routes.TH.Dispatch

yesod-routes/Yesod/Routes/TH/RouteAttrs.hs

@@ -0,0 +1,38 @@
+{-# 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 pieces trees) =
+    fmap concat $ mapM (goTree front') trees
+  where
+    ignored = ((replicate toIgnore WildP ++) . return)
+    toIgnore = length $ filter (isDynamic . snd) 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)

yesod-routes/test/main.hs

@@ -23,6 +23,7 @@ import Yesod.Routes.TH hiding (Dispatch)
 import Language.Haskell.TH.Syntax
 import Hierarchy
 import qualified Data.ByteString.Char8 as S8
+import qualified Data.Set as Set
 
 result :: ([Text] -> Maybe Int) -> Dispatch Int
 result f ts = f ts
@@ -105,15 +106,24 @@ getMySubParam _ = MySubParam
 
 do
     texts <- [t|[Text]|]
-    let ress = map ResourceLeaf
-            [ Resource "RootR" [] (Methods Nothing ["GET"]) []
+    let resLeaves = map ResourceLeaf
+            [ Resource "RootR" [] (Methods Nothing ["GET"]) ["foo", "bar"]
             , Resource "BlogPostR" (addCheck [Static "blog", Dynamic $ ConT ''Text]) (Methods Nothing ["GET", "POST"]) []
             , Resource "WikiR" (addCheck [Static "wiki"]) (Methods (Just texts) []) []
             , Resource "SubsiteR" (addCheck [Static "subsite"]) (Subsite (ConT ''MySub) "getMySub") []
             , Resource "SubparamR" (addCheck [Static "subparam", Dynamic $ ConT ''Int]) (Subsite (ConT ''MySubParam) "getMySubParam") []
             ]
+        resParent = ResourceParent
+            "ParentR"
+            [ (True, Static "foo")
+            , (True, Dynamic $ ConT ''Text)
+            ]
+            [ ResourceLeaf $ Resource "ChildR" [] (Methods Nothing ["GET"]) ["child"]
+            ]
+        ress = resParent : resLeaves
         addCheck = map ((,) True)
     rrinst <- mkRenderRouteInstance (ConT ''MyApp) ress
+    rainst <- mkRouteAttrsInstance (ConT ''MyApp) ress
     prinst <- mkParseRouteInstance (ConT ''MyApp) ress
     dispatch <- mkDispatchClause MkDispatchSettings
         { mdsRunHandler = [|runHandler|]
@@ -133,6 +143,7 @@ do
                 `AppT` ConT ''MyApp)
             [FunD (mkName "dispatcher") [dispatch]]
         : prinst
+        : rainst
         : rrinst
 
 instance Dispatcher MySub master where
@@ -336,6 +347,11 @@ main = hspec $ do
 /bar/baz Foo3
 |]
             findOverlapNames routes @?= []
+    describe "routeAttrs" $ do
+        it "works" $ do
+            routeAttrs RootR @?= Set.fromList [pack "foo", pack "bar"]
+        it "hierarchy" $ do
+            routeAttrs (ParentR (pack "ignored") ChildR) @?= Set.singleton (pack "child")
     hierarchy
 
 getRootR :: Text
@@ -349,3 +365,6 @@ postBlogPostR t = pack $ "POST some blog post: " ++ unpack t
 
 handleWikiR :: [Text] -> String
 handleWikiR ts = "the wiki: " ++ show ts
+
+getChildR :: Text -> Text
+getChildR = id

yesod-routes/yesod-routes.cabal

@@ -30,6 +30,7 @@ library
     other-modules:   Yesod.Routes.TH.Dispatch
                      Yesod.Routes.TH.RenderRoute
                      Yesod.Routes.TH.ParseRoute
+                     Yesod.Routes.TH.RouteAttrs
                      Yesod.Routes.TH.Types
     ghc-options:     -Wall