yesod-routes 1.2.0.6 → 1.2.0.7
raw patch · 3 files changed
+56/−7 lines, 3 files
Files
- Yesod/Routes/Parse.hs +44/−2
- test/Hierarchy.hs +11/−4
- yesod-routes.cabal +1/−1
Yesod/Routes/Parse.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE PatternGuards #-} {-# OPTIONS_GHC -fno-warn-missing-fields #-} -- QuasiQuoter module Yesod.Routes.Parse ( parseRoutes@@ -18,6 +19,8 @@ import Yesod.Routes.TH import Yesod.Routes.Overlap (findOverlapNames) import Data.List (foldl')+import Data.Maybe (mapMaybe)+import qualified Data.Set as Set -- | A quasi-quoter to parse a string into a list of 'Resource's. Checks for -- overlapping routes, failing if present; use 'parseRoutesNoCheck' to skip the@@ -67,14 +70,30 @@ | 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@@ -82,6 +101,29 @@ in ((ResourceLeaf (Resource constr pieces disp attrs):), otherLines) [] -> (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 = noDupes ++ resourceAttrs res }+ where+ usedKeys = Set.fromList $ map fst $ mapMaybe toPair $ resourceAttrs res+ used attr =+ case toPair attr of+ Nothing -> False+ Just (key, _) -> key `Set.member` usedKeys+ noDupes = filter (not . used) attrs++ toPair s =+ case break (== '=') s of+ (x, '=':y) -> Just (x, y)+ _ -> Nothing+ -- | Take attributes out of the list and put them in the first slot in the -- result tuple.
test/Hierarchy.hs view
@@ -27,6 +27,7 @@ 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 @@ /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@@ -98,8 +99,8 @@ /post Post3 POST -- /#Int Delete3 DELETE -/afterwards AfterR:- / After GET+/afterwards AfterR !parent !key=value1:+ / After GET !child !key=value2 -- /trailing-nest TrailingNestR: -- /foo TrailingFooR GET@@ -107,6 +108,7 @@ |] 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 @@ `AppT` ConT ''Hierarchy) [FunD (mkName "dispatcher") [dispatch]] : prinst+ : rainst : rrinst getSpacedR :: Handler site String@@ -199,3 +202,7 @@ 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"]+ it "pair attributes" $+ routeAttrs (AfterR After) @?= Set.fromList ["parent", "child", "key=value2"]
yesod-routes.cabal view
@@ -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>