diff --git a/yesod-core/Yesod/Routes/Parse.hs b/yesod-core/Yesod/Routes/Parse.hs index 580f23d6..0a7428f7 100644 --- 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 index f746a2de..283119e2 100644 --- 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 index 2089026f..f195368d 100644 --- 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