Started yesod-test test suite (yo dawg...)

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

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 Yesod.Test.CssQuery
-import Text.Parsec.Prim (Parsec)
+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
-

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"]]]

yesod-test/yesod-test.cabal

@@ -7,7 +7,7 @@ maintainer:         Nubis <nubis@woobiz.com.ar>
 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