Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Jump to bottom

Adds curly brackets to route parser. #1363

Merged
merged 1 commit into from Mar 26, 2017
Merged

Adds curly brackets to route parser. #1363

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Jump to
Jump to file
Failed to load files.
Diff view
Diff view
41 changes: 34 additions & 7 deletions yesod-core/Yesod/Routes/Parse.hs
View file
Open in desktop
Expand Up @@ -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
Expand Down Expand Up @@ -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 ->
Expand All @@ -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
Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Is there an advantage to retaining the surrounding braces? What about simply dropping them, and then removing the need for the dynamicPieceFromString below?

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I think that would be too permissive. Otherwise, lines could contain arbitrary braces in routes. For example, the following would probably parse:

/m{}y/{route with}/{spaces} RouteR GET

I prefer the current stricter grammar that requires the braces follow '#' so that braces can only surround types in the route.

Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Fair enough, that makes sense.

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)
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand Down Expand Up @@ -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)
Expand All @@ -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?
4 changes: 3 additions & 1 deletion yesod-core/test/RouteSpec.hs
View file
Open in desktop
Expand Up @@ -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"
Expand All @@ -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"
Expand Down
4 changes: 4 additions & 0 deletions yesod-core/test/YesodCoreTest/Links.hs
View file
Open in desktop
Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down