Merge pull request #1363 from jprider63/master

Adds curly brackets to route parser.
yesodweb · Mar 26, 2017 · 5b5e411 · 5b5e411
2 parents 52d4a32 + 6c7a40e
commit 5b5e411
Show file tree

Hide file tree

Showing 3 changed files with 41 additions and 8 deletions.
diff --git a/yesod-core/Yesod/Routes/Parse.hs b/yesod-core/Yesod/Routes/Parse.hs
@@ -13,7 +13,7 @@ module Yesod.Routes.Parse
     ) where
 
 import Language.Haskell.TH.Syntax
-import Data.Char (isUpper)
+import Data.Char (isUpper, isSpace)
 import Language.Haskell.TH.Quote
 import qualified System.IO as SIO
 import Yesod.Routes.TH
@@ -86,7 +86,7 @@ resourcesFromString =
         spaces = takeWhile (== ' ') thisLine
         (others, remainder) = parse indent otherLines'
         (this, otherLines') =
-            case takeWhile (not . isPrefixOf "--") $ words thisLine of
+            case takeWhile (not . isPrefixOf "--") $ splitSpaces thisLine of
                 (pattern:rest0)
                     | Just (constr:rest) <- stripColonLast rest0
                     , Just attrs <- mapM parseAttr rest ->
@@ -102,6 +102,26 @@ resourcesFromString =
                 [] -> (id, otherLines)
                 _ -> error $ "Invalid resource line: " ++ thisLine
 
+-- | Splits a string by spaces, as long as the spaces are not enclosed by curly brackets (not recursive).
+splitSpaces :: String -> [String]
+splitSpaces "" = []
+splitSpaces str = 
+    let (rest, piece) = parse $ dropWhile isSpace str in
+    piece:(splitSpaces rest)
+
+    where 
+        parse :: String -> ( String, String)
+        parse ('{':s) = fmap ('{':) $ parseBracket s
+        parse (c:s) | isSpace c = (s, [])
+        parse (c:s) = fmap (c:) $ parse s
+        parse "" = ("", "")
+
+        parseBracket :: String -> ( String, String)
+        parseBracket ('{':_) = error $ "Invalid resource line (nested curly bracket): " ++ str
+        parseBracket ('}':s) = fmap ('}':) $ parse s
+        parseBracket (c:s) = fmap (c:) $ parseBracket s
+        parseBracket "" = error $ "Invalid resource line (unclosed curly bracket): " ++ str
+
 piecesFromStringCheck :: String -> ([Piece String], Maybe String, Bool)
 piecesFromStringCheck s0 =
     (pieces, mmulti, check)
@@ -181,7 +201,7 @@ parseTypeTree :: String -> Maybe TypeTree
 parseTypeTree orig =
     toTypeTree pieces
   where
-    pieces = filter (not . null) $ splitOn '-' $ addDashes orig
+    pieces = filter (not . null) $ splitOn (\c -> c == '-' || c == ' ') $ addDashes orig
     addDashes [] = []
     addDashes (x:xs) =
         front $ addDashes xs
@@ -194,7 +214,7 @@ parseTypeTree orig =
             _:y -> x : splitOn c y
             [] -> [x]
       where
-        (x, y') = break (== c) s
+        (x, y') = break c s
 
 data TypeTree = TTTerm String
               | TTApp TypeTree TypeTree
@@ -237,9 +257,9 @@ ttToType (TTApp x y) = ttToType x `AppT` ttToType y
 ttToType (TTList t) = ListT `AppT` ttToType t
 
 pieceFromString :: String -> Either (CheckOverlap, String) (CheckOverlap, Piece String)
-pieceFromString ('#':'!':x) = Right $ (False, Dynamic x)
-pieceFromString ('!':'#':x) = Right $ (False, Dynamic x) -- https://github.com/yesodweb/yesod/issues/652
-pieceFromString ('#':x) = Right $ (True, Dynamic x)
+pieceFromString ('#':'!':x) = Right $ (False, dynamicPieceFromString x)
+pieceFromString ('!':'#':x) = Right $ (False, dynamicPieceFromString x) -- https://github.com/yesodweb/yesod/issues/652
+pieceFromString ('#':x) = Right $ (True, dynamicPieceFromString x)
 
 pieceFromString ('*':'!':x) = Left (False, x)
 pieceFromString ('+':'!':x) = Left (False, x)
@@ -252,3 +272,10 @@ pieceFromString ('+':x) = Left (True, x)
 
 pieceFromString ('!':x) = Right $ (False, Static x)
 pieceFromString x = Right $ (True, Static x)
+
+dynamicPieceFromString :: String -> Piece String
+dynamicPieceFromString str@('{':x) = case break (== '}') x of
+    (s, "}") -> Dynamic s
+    _ -> error $ "Invalid path piece: " ++ str
+dynamicPieceFromString x = Dynamic x
+-- JP: Should we check if there are curly brackets or other invalid characters?
diff --git a/yesod-core/test/RouteSpec.hs b/yesod-core/test/RouteSpec.hs
@@ -322,7 +322,7 @@ main = hspec $ do
         it "hierarchy" $ do
             routeAttrs (ParentR (pack "ignored") ChildR) @?= Set.singleton (pack "child")
     hierarchy
-    describe "parseRouteTyoe" $ do
+    describe "parseRouteType" $ do
         let success s t = it s $ parseTypeTree s @?= Just t
             failure s = it s $ parseTypeTree s @?= Nothing
         success "Int" $ TTTerm "Int"
@@ -334,6 +334,8 @@ main = hspec $ do
         success "[Int]" $ TTList $ TTTerm "Int"
         success "Foo-Bar" $ TTApp (TTTerm "Foo") (TTTerm "Bar")
         success "Foo-Bar-Baz" $ TTApp (TTTerm "Foo") (TTTerm "Bar") `TTApp` TTTerm "Baz"
+        success "Foo Bar" $ TTApp (TTTerm "Foo") (TTTerm "Bar")
+        success "Foo Bar Baz" $ TTApp (TTTerm "Foo") (TTTerm "Bar") `TTApp` TTTerm "Baz"
 
 getRootR :: Text
 getRootR = pack "this is the root"

diff --git a/yesod-core/test/YesodCoreTest/Links.hs b/yesod-core/test/YesodCoreTest/Links.hs
@@ -25,6 +25,7 @@ mkYesod "Y" [parseRoutes|
 /route-test-2/*Vector-String RT2 GET
 /route-test-3/*Vector-(Maybe-Int) RT3 GET
 /route-test-4/#(Foo-Int-Int) RT4 GET
+/route-test-4-spaces/#{Foo Int Int} RT4Spaces GET
 |]
 
 data Vector a = Vector
@@ -64,6 +65,9 @@ getRT3 _ = return ()
 getRT4 :: Foo Int Int -> Handler ()
 getRT4 _ = return ()
 
+getRT4Spaces :: Foo Int Int -> Handler ()
+getRT4Spaces _ = return ()
+
 linksTest :: Spec
 linksTest = describe "Test.Links" $ do
       it "linkToHome" case_linkToHome