From a3e27a3d57ee2bd33510377f27b567628d7eafb6 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 28 Mar 2012 08:03:47 +0200 Subject: [PATCH] Started yesod-test test suite (yo dawg...) --- yesod-test/Yesod/Test/CssQuery.hs | 103 +++++++++++++++++++++++ yesod-test/Yesod/Test/TransversingCSS.hs | 99 +--------------------- yesod-test/test/main.hs | 14 +++ yesod-test/yesod-test.cabal | 12 ++- 4 files changed, 130 insertions(+), 98 deletions(-) create mode 100644 yesod-test/Yesod/Test/CssQuery.hs create mode 100644 yesod-test/test/main.hs diff --git a/yesod-test/Yesod/Test/CssQuery.hs b/yesod-test/Yesod/Test/CssQuery.hs new file mode 100644 index 00000000..df59a47f --- /dev/null +++ b/yesod-test/Yesod/Test/CssQuery.hs @@ -0,0 +1,103 @@ +-- | Parsing CSS selectors into queries. +module Yesod.Test.CssQuery + ( SelectorGroup (..) + , Selector (..) + , parseQuery + ) where + +import Text.ParserCombinators.Parsec +import Text.Parsec.Prim (Parsec) + +data SelectorGroup + = DirectChildren [Selector] + | DeepChildren [Selector] + deriving (Show, Eq) + +data Selector + = ById String + | ByClass String + | ByTagName String + | ByAttrExists String + | ByAttrEquals String String + | ByAttrContains String String + | ByAttrStarts String String + | ByAttrEnds String String + deriving (Show, Eq) + +-- | Parses a query into an intermediate format which is easy to feed to HXT +-- +-- * The top-level lists represent the top level comma separated queries. +-- +-- * SelectorGroup is a group of qualifiers which are separated +-- with spaces or > like these three: /table.main.odd tr.even > td.big/ +-- +-- * A SelectorGroup as a list of Selector items, following the above example +-- the selectors in the group are: /table/, /.main/ and /.odd/ +parseQuery :: String -> Either ParseError [[SelectorGroup]] +parseQuery = parse cssQuery "" + +-- Below this line is the Parsec parser for css queries. +cssQuery :: Parsec String u [[SelectorGroup]] +cssQuery = sepBy rules (char ',' >> (optional (char ' '))) + +rules :: Parsec String u [SelectorGroup] +rules = many $ directChildren <|> deepChildren + +directChildren :: Parsec String u SelectorGroup +directChildren = do + _ <- char '>' + _ <- char ' ' + sels <- selectors + optional $ char ' ' + return $ DirectChildren sels + +deepChildren :: Parsec String u SelectorGroup +deepChildren = do + sels <- selectors + optional $ char ' ' + return $ DeepChildren sels + +selectors :: Parsec String u [Selector] +selectors = many1 $ parseId + <|> parseClass + <|> parseTag + <|> parseAttr + +parseId :: Parsec String u Selector +parseId = do + _ <- char '#' + x <- many $ noneOf ",#.[ >" + return $ ById x + +parseClass :: Parsec String u Selector +parseClass = do + _ <- char '.' + x <- many $ noneOf ",#.[ >" + return $ ByClass x + +parseTag :: Parsec String u Selector +parseTag = do + x <- many1 $ noneOf ",#.[ >" + return $ ByTagName x + +parseAttr :: Parsec String u Selector +parseAttr = do + _ <- char '[' + name <- many $ noneOf ",#.=$^*]" + (parseAttrExists name) + <|> (parseAttrWith "=" ByAttrEquals name) + <|> (parseAttrWith "*=" ByAttrContains name) + <|> (parseAttrWith "^=" ByAttrStarts name) + <|> (parseAttrWith "$=" ByAttrEnds name) + +parseAttrExists :: String -> Parsec String u Selector +parseAttrExists attrname = do + _ <- char ']' + return $ ByAttrExists attrname + +parseAttrWith :: String -> (String -> String -> Selector) -> String -> Parsec String u Selector +parseAttrWith sign constructor name = do + _ <- string sign + value <- many $ noneOf ",#.]" + _ <- char ']' + return $ constructor name value diff --git a/yesod-test/Yesod/Test/TransversingCSS.hs b/yesod-test/Yesod/Test/TransversingCSS.hs index 8d697bbc..1107b19d 100644 --- a/yesod-test/Yesod/Test/TransversingCSS.hs +++ b/yesod-test/Yesod/Test/TransversingCSS.hs @@ -40,8 +40,8 @@ where import Text.XML.HXT.Core import qualified Data.List as DL -import Text.ParserCombinators.Parsec -import Text.Parsec.Prim (Parsec) +import Yesod.Test.CssQuery +import Text.ParserCombinators.Parsec (ParseError) type Html = String type Query = String @@ -80,98 +80,3 @@ queryToArrow commaSeparated = ByAttrContains n v -> hasAttrValue n (DL.isInfixOf v) ByAttrStarts n v -> hasAttrValue n (DL.isPrefixOf v) ByAttrEnds n v -> hasAttrValue n (DL.isSuffixOf v) - --- | Parses a query into an intermediate format which is easy to feed to HXT --- --- * The top-level lists represent the top level comma separated queries. --- --- * SelectorGroup is a group of qualifiers which are separated --- with spaces or > like these three: /table.main.odd tr.even > td.big/ --- --- * A SelectorGroup as a list of Selector items, following the above example --- the selectors in the group are: /table/, /.main/ and /.odd/ -parseQuery :: String -> Either ParseError [[SelectorGroup]] -parseQuery = parse cssQuery "" - -data SelectorGroup - = DirectChildren [Selector] - | DeepChildren [Selector] - deriving Show - -data Selector - = ById String - | ByClass String - | ByTagName String - | ByAttrExists String - | ByAttrEquals String String - | ByAttrContains String String - | ByAttrStarts String String - | ByAttrEnds String String - deriving Show - --- Below this line is the Parsec parser for css queries. -cssQuery :: Parsec String u [[SelectorGroup]] -cssQuery = sepBy rules (char ',' >> (optional (char ' '))) - -rules :: Parsec String u [SelectorGroup] -rules = many $ directChildren <|> deepChildren - -directChildren :: Parsec String u SelectorGroup -directChildren = do - _ <- char '>' - _ <- char ' ' - sels <- selectors - optional $ char ' ' - return $ DirectChildren sels - -deepChildren :: Parsec String u SelectorGroup -deepChildren = do - sels <- selectors - optional $ char ' ' - return $ DeepChildren sels - -selectors :: Parsec String u [Selector] -selectors = many1 $ parseId - <|> parseClass - <|> parseTag - <|> parseAttr - -parseId :: Parsec String u Selector -parseId = do - _ <- char '#' - x <- many $ noneOf ",#.[ >" - return $ ById x - -parseClass :: Parsec String u Selector -parseClass = do - _ <- char '.' - x <- many $ noneOf ",#.[ >" - return $ ByClass x - -parseTag :: Parsec String u Selector -parseTag = do - x <- many1 $ noneOf ",#.[ >" - return $ ByTagName x - -parseAttr :: Parsec String u Selector -parseAttr = do - _ <- char '[' - name <- many $ noneOf ",#.=$^*]" - (parseAttrExists name) - <|> (parseAttrWith "=" ByAttrEquals name) - <|> (parseAttrWith "*=" ByAttrContains name) - <|> (parseAttrWith "^=" ByAttrStarts name) - <|> (parseAttrWith "$=" ByAttrEnds name) - -parseAttrExists :: String -> Parsec String u Selector -parseAttrExists attrname = do - _ <- char ']' - return $ ByAttrExists attrname - -parseAttrWith :: String -> (String -> String -> Selector) -> String -> Parsec String u Selector -parseAttrWith sign constructor name = do - _ <- string sign - value <- many $ noneOf ",#.]" - _ <- char ']' - return $ constructor name value - diff --git a/yesod-test/test/main.hs b/yesod-test/test/main.hs new file mode 100644 index 00000000..808fafd5 --- /dev/null +++ b/yesod-test/test/main.hs @@ -0,0 +1,14 @@ +import Test.HUnit hiding (Test) +import Test.Hspec.Monadic +import Test.Hspec.HUnit () + +import Yesod.Test.CssQuery + +parseQuery_ = either (error . show) id . parseQuery + +main :: IO () +main = hspecX $ do + describe "CSS selector parsing" $ do + it "elements" $ parseQuery_ "strong" @?= [[DeepChildren [ByTagName "strong"]]] + it "child elements" $ parseQuery_ "strong > i" @?= [[DeepChildren [ByTagName "strong"], DirectChildren [ByTagName "i"]]] + it "comma" $ parseQuery_ "strong.bar, #foo" @?= [[DeepChildren [ByTagName "strong", ByClass "bar"]], [DeepChildren [ById "foo"]]] diff --git a/yesod-test/yesod-test.cabal b/yesod-test/yesod-test.cabal index a0857ddf..9f4a0d2a 100644 --- a/yesod-test/yesod-test.cabal +++ b/yesod-test/yesod-test.cabal @@ -7,7 +7,7 @@ maintainer: Nubis synopsis: integration testing for WAI/Yesod Applications category: Web, Yesod, Testing stability: Experimental -cabal-version: >= 1.6 +cabal-version: >= 1.8 build-type: Simple homepage: http://www.yesodweb.com description: Behaviour Oriented integration Testing for Yesod Applications @@ -35,9 +35,19 @@ library , case-insensitive >= 0.2 , text exposed-modules: Yesod.Test + Yesod.Test.CssQuery other-modules: Yesod.Test.TransversingCSS ghc-options: -Wall +test-suite test + type: exitcode-stdio-1.0 + main-is: main.hs + hs-source-dirs: test + build-depends: base + , yesod-test + , hspec >= 0.9 && < 0.10 + , HUnit + source-repository head type: git location: git://github.com/yesodweb/yesod.git