From 4858f0837bf0bbe8ea71fb1da19a94122493bddf Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Wed, 18 Jun 2014 19:51:27 +0300
Subject: [PATCH] Attributes can be set on parent routes #762

---
 yesod-routes/Yesod/Routes/Parse.hs | 30 ++++++++++++++++++++++++++++--
 yesod-routes/test/Hierarchy.hs     |  9 +++++++--
 yesod-routes/yesod-routes.cabal    |  2 +-
 3 files changed, 36 insertions(+), 5 deletions(-)

diff --git a/yesod-routes/Yesod/Routes/Parse.hs b/yesod-routes/Yesod/Routes/Parse.hs
index 361ec8a5..f230e7ff 100644
--- a/yesod-routes/Yesod/Routes/Parse.hs
+++ b/yesod-routes/Yesod/Routes/Parse.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE PatternGuards #-}
 {-# OPTIONS_GHC -fno-warn-missing-fields #-} -- QuasiQuoter
 module Yesod.Routes.Parse
     ( parseRoutes
@@ -67,14 +68,30 @@ resourcesFromString =
         | length spaces < indent = ([], thisLine : otherLines)
         | otherwise = (this others, remainder)
       where
+        parseAttr ('!':x) = Just x
+        parseAttr _ = Nothing
+
+        stripColonLast =
+            go id
+          where
+            go _ [] = Nothing
+            go front [x]
+                | null x = Nothing
+                | last x == ':' = Just $ front [init x]
+                | otherwise = Nothing
+            go front (x:xs) = go (front . (x:)) xs
+
         spaces = takeWhile (== ' ') thisLine
         (others, remainder) = parse indent otherLines'
         (this, otherLines') =
             case takeWhile (/= "--") $ words thisLine of
-                [pattern, constr] | last constr == ':' ->
+                (pattern:rest0)
+                    | Just (constr:rest) <- stripColonLast rest0
+                    , Just attrs <- mapM parseAttr rest ->
                     let (children, otherLines'') = parse (length spaces + 1) otherLines
+                        children' = addAttrs attrs children
                         (pieces, Nothing) = piecesFromString $ drop1Slash pattern
-                     in ((ResourceParent (init constr) pieces children :), otherLines'')
+                     in ((ResourceParent constr pieces children' :), otherLines'')
                 (pattern:constr:rest) ->
                     let (pieces, mmulti) = piecesFromString $ drop1Slash pattern
                         (attrs, rest') = takeAttrs rest
@@ -83,6 +100,15 @@ resourcesFromString =
                 [] -> (id, otherLines)
                 _ -> error $ "Invalid resource line: " ++ thisLine
 
+addAttrs :: [String] -> [ResourceTree String] -> [ResourceTree String]
+addAttrs attrs =
+    map goTree
+  where
+    goTree (ResourceLeaf res) = ResourceLeaf (goRes res)
+    goTree (ResourceParent x y z) = ResourceParent x y (map goTree z)
+
+    goRes res = res { resourceAttrs = attrs ++ resourceAttrs res }
+
 -- | Take attributes out of the list and put them in the first slot in the
 -- result tuple.
 takeAttrs :: [String] -> ([String], [String])
diff --git a/yesod-routes/test/Hierarchy.hs b/yesod-routes/test/Hierarchy.hs
index c3c786c8..9bcd796a 100644
--- a/yesod-routes/test/Hierarchy.hs
+++ b/yesod-routes/test/Hierarchy.hs
@@ -27,6 +27,7 @@ import qualified Yesod.Routes.Class as YRC
 import Data.Text (Text, pack, unpack, append)
 import Data.ByteString (ByteString)
 import qualified Data.ByteString.Char8 as S8
+import qualified Data.Set as Set
 
 class ToText a where
     toText :: a -> Text
@@ -84,9 +85,9 @@ do
     /login       LoginR     GET POST
     /table/#Text TableR     GET
 
-/nest/ NestR:
+/nest/ NestR !NestingAttr:
 
-  /spaces      SpacedR   GET
+  /spaces      SpacedR   GET !NonNested
 
   /nest2 Nest2:
     /           GetPostR  GET POST
@@ -107,6 +108,7 @@ do
 |]
 
     rrinst <- mkRenderRouteInstance (ConT ''Hierarchy) $ map (fmap parseType) resources
+    rainst <- mkRouteAttrsInstance (ConT ''Hierarchy) $ map (fmap parseType) resources
     prinst <- mkParseRouteInstance (ConT ''Hierarchy) $ map (fmap parseType) resources
     dispatch <- mkDispatchClause MkDispatchSettings
         { mdsRunHandler = [|runHandler|]
@@ -126,6 +128,7 @@ do
                 `AppT` ConT ''Hierarchy)
             [FunD (mkName "dispatcher") [dispatch]]
         : prinst
+        : rainst
         : rrinst
 
 getSpacedR :: Handler site String
@@ -199,3 +202,5 @@ hierarchy = describe "hierarchy" $ do
         parseRoute ([], [("foo", "bar")]) @?= Just HomeR
         parseRoute (["admin", "5"], []) @?= Just (AdminR 5 AdminRootR)
         parseRoute (["admin!", "5"], []) @?= (Nothing :: Maybe (Route Hierarchy))
+    it "inherited attributes" $ do
+        routeAttrs (NestR SpacedR) @?= Set.fromList ["NestingAttr", "NonNested"]
diff --git a/yesod-routes/yesod-routes.cabal b/yesod-routes/yesod-routes.cabal
index 65b1511a..878a4f11 100644
--- a/yesod-routes/yesod-routes.cabal
+++ b/yesod-routes/yesod-routes.cabal
@@ -1,5 +1,5 @@
 name:            yesod-routes
-version:         1.2.0.6
+version:         1.2.0.7
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>