diff --git a/yesod-test/Yesod/Test.hs b/yesod-test/Yesod/Test.hs index 6d5ba66f..ab7430af 100644 --- a/yesod-test/Yesod/Test.hs +++ b/yesod-test/Yesod/Test.hs @@ -85,6 +85,7 @@ import Control.Monad.IO.Class import System.IO import Yesod.Test.TransversingCSS import Database.Persist.GenericSql +import Data.Monoid (mappend) -- | The state used in 'describe' to build a list of specs data SpecsData = SpecsData Application ConnectionPool [Core.Spec] @@ -167,7 +168,7 @@ parseHTML html p = runLA (hread >>> p ) html htmlQuery :: HoldsResponse a => Query -> ST.StateT a IO [Html] htmlQuery query = withResponse $ \ res -> case findBySelector (BSL8.unpack $ simpleBody res) query of - Left err -> failure $ query ++ " did not parse: " ++ (show err) + Left err -> failure $ T.unpack query ++ " did not parse: " ++ (show err) Right matches -> return matches -- | Asserts that the two given values are equal. @@ -237,8 +238,8 @@ htmlAllContain :: HoldsResponse a => Query -> String -> ST.StateT a IO () htmlAllContain query search = do matches <- htmlQuery query case matches of - [] -> failure $ "Nothing matched css query: "++query - _ -> liftIO $ HUnit.assertBool ("Not all "++query++" contain "++search) $ + [] -> failure $ "Nothing matched css query: "++T.unpack query + _ -> liftIO $ HUnit.assertBool ("Not all "++T.unpack query++" contain "++search) $ DL.all (DL.isInfixOf search) matches -- | Performs a css query on the last response and asserts the matched elements @@ -247,7 +248,7 @@ htmlCount :: HoldsResponse a => Query -> Int -> ST.StateT a IO () htmlCount query count = do matches <- fmap DL.length $ htmlQuery query liftIO $ flip HUnit.assertBool (matches == count) - ("Expected "++(show count)++" elements to match "++query++", found "++(show matches)) + ("Expected "++(show count)++" elements to match "++T.unpack query++", found "++(show matches)) -- | Outputs the last response body to stderr (So it doesn't get captured by HSpec) printBody :: HoldsResponse a => ST.StateT a IO () @@ -319,9 +320,9 @@ fileByLabel label path mime = do -- | Lookup a _nonce form field and add it's value to the params. -- Receives a CSS selector that should resolve to the form element containing the nonce. -addNonce_ :: String -> RequestBuilder () +addNonce_ :: Query -> RequestBuilder () addNonce_ scope = do - matches <- htmlQuery $ scope ++ "input[name=_nonce][type=hidden][value]" + matches <- htmlQuery $ scope `mappend` "input[name=_nonce][type=hidden][value]" case matches of [] -> failure $ "No nonce found in the current page" element:[] -> byName "_nonce" $ head $ parseHTML element $ getAttrValue "value" diff --git a/yesod-test/Yesod/Test/CssQuery.hs b/yesod-test/Yesod/Test/CssQuery.hs index df59a47f..83b8a504 100644 --- a/yesod-test/Yesod/Test/CssQuery.hs +++ b/yesod-test/Yesod/Test/CssQuery.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} -- | Parsing CSS selectors into queries. module Yesod.Test.CssQuery ( SelectorGroup (..) @@ -5,8 +6,10 @@ module Yesod.Test.CssQuery , parseQuery ) where -import Text.ParserCombinators.Parsec -import Text.Parsec.Prim (Parsec) +import Prelude hiding (takeWhile) +import Data.Text (Text) +import Data.Attoparsec.Text +import Control.Applicative (many, (<|>), optional) data SelectorGroup = DirectChildren [Selector] @@ -14,14 +17,14 @@ data SelectorGroup 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 + = ById Text + | ByClass Text + | ByTagName Text + | ByAttrExists Text + | ByAttrEquals Text Text + | ByAttrContains Text Text + | ByAttrStarts Text Text + | ByAttrEnds Text Text deriving (Show, Eq) -- | Parses a query into an intermediate format which is easy to feed to HXT @@ -32,18 +35,18 @@ data Selector -- 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 "" +-- the selectors in the group are: /table/, /.main/ and /.odd/ +parseQuery :: Text -> Either String [[SelectorGroup]] +parseQuery = parseOnly cssQuery -- Below this line is the Parsec parser for css queries. -cssQuery :: Parsec String u [[SelectorGroup]] +cssQuery :: Parser [[SelectorGroup]] cssQuery = sepBy rules (char ',' >> (optional (char ' '))) -rules :: Parsec String u [SelectorGroup] +rules :: Parser [SelectorGroup] rules = many $ directChildren <|> deepChildren -directChildren :: Parsec String u SelectorGroup +directChildren :: Parser SelectorGroup directChildren = do _ <- char '>' _ <- char ' ' @@ -51,53 +54,53 @@ directChildren = do optional $ char ' ' return $ DirectChildren sels -deepChildren :: Parsec String u SelectorGroup +deepChildren :: Parser SelectorGroup deepChildren = do sels <- selectors optional $ char ' ' return $ DeepChildren sels -selectors :: Parsec String u [Selector] +selectors :: Parser [Selector] selectors = many1 $ parseId <|> parseClass <|> parseTag <|> parseAttr -parseId :: Parsec String u Selector +parseId :: Parser Selector parseId = do _ <- char '#' - x <- many $ noneOf ",#.[ >" + x <- takeWhile $ flip notElem ",#.[ >" return $ ById x -parseClass :: Parsec String u Selector +parseClass :: Parser Selector parseClass = do _ <- char '.' - x <- many $ noneOf ",#.[ >" + x <- takeWhile $ flip notElem ",#.[ >" return $ ByClass x -parseTag :: Parsec String u Selector +parseTag :: Parser Selector parseTag = do - x <- many1 $ noneOf ",#.[ >" + x <- takeWhile1 $ flip notElem ",#.[ >" return $ ByTagName x -parseAttr :: Parsec String u Selector +parseAttr :: Parser Selector parseAttr = do _ <- char '[' - name <- many $ noneOf ",#.=$^*]" + name <- takeWhile $ flip notElem ",#.=$^*]" (parseAttrExists name) <|> (parseAttrWith "=" ByAttrEquals name) <|> (parseAttrWith "*=" ByAttrContains name) <|> (parseAttrWith "^=" ByAttrStarts name) <|> (parseAttrWith "$=" ByAttrEnds name) -parseAttrExists :: String -> Parsec String u Selector +parseAttrExists :: Text -> Parser Selector parseAttrExists attrname = do _ <- char ']' return $ ByAttrExists attrname -parseAttrWith :: String -> (String -> String -> Selector) -> String -> Parsec String u Selector +parseAttrWith :: Text -> (Text -> Text -> Selector) -> Text -> Parser Selector parseAttrWith sign constructor name = do _ <- string sign - value <- many $ noneOf ",#.]" + value <- takeWhile $ flip notElem ",#.]" _ <- char ']' return $ constructor name value diff --git a/yesod-test/Yesod/Test/TransversingCSS.hs b/yesod-test/Yesod/Test/TransversingCSS.hs index 1107b19d..bb40b42c 100644 --- a/yesod-test/Yesod/Test/TransversingCSS.hs +++ b/yesod-test/Yesod/Test/TransversingCSS.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} {- | This module uses HXT to transverse an HTML document using CSS selectors. @@ -41,17 +42,18 @@ where import Text.XML.HXT.Core import qualified Data.List as DL import Yesod.Test.CssQuery -import Text.ParserCombinators.Parsec (ParseError) +import Data.Text (unpack) +import qualified Data.Text as T type Html = String -type Query = String +type Query = T.Text -- | Perform a css 'Query' on 'Html'. Returns Either -- -- * Left: Query parse error. -- -- * Right: List of matching Html fragments. -findBySelector :: Html-> Query -> Either ParseError [Html] +findBySelector :: Html-> Query -> Either String [Html] findBySelector html query = fmap (runQuery html) (parseQuery query) -- Run a compiled query on Html, returning a list of matching Html fragments. @@ -72,11 +74,11 @@ queryToArrow commaSeparated = accum >>> getChildren >>> multi (DL.foldl applySelectors this $ sels) applySelectors accum selector = accum >>> (toArrow selector) toArrow selector = case selector of - ById v -> hasAttrValue "id" (==v) - ByClass v -> hasAttrValue "class" ((DL.elem v) . words) - ByTagName v -> hasName v - ByAttrExists n -> hasAttr n - ByAttrEquals n v -> hasAttrValue n (==v) - ByAttrContains n v -> hasAttrValue n (DL.isInfixOf v) - ByAttrStarts n v -> hasAttrValue n (DL.isPrefixOf v) - ByAttrEnds n v -> hasAttrValue n (DL.isSuffixOf v) + ById v -> hasAttrValue "id" (== unpack v) + ByClass v -> hasAttrValue "class" ((DL.elem $ unpack v) . words) + ByTagName v -> hasName $ unpack v + ByAttrExists n -> hasAttr $ unpack n + ByAttrEquals n v -> hasAttrValue (unpack n) (== unpack v) + ByAttrContains n v -> hasAttrValue (unpack n) (DL.isInfixOf $ unpack v) + ByAttrStarts n v -> hasAttrValue (unpack n) (DL.isPrefixOf $ unpack v) + ByAttrEnds n v -> hasAttrValue (unpack n) (DL.isSuffixOf $ unpack v) diff --git a/yesod-test/test/main.hs b/yesod-test/test/main.hs index 808fafd5..9e3a62ff 100644 --- a/yesod-test/test/main.hs +++ b/yesod-test/test/main.hs @@ -1,10 +1,11 @@ +{-# LANGUAGE OverloadedStrings #-} import Test.HUnit hiding (Test) import Test.Hspec.Monadic import Test.Hspec.HUnit () import Yesod.Test.CssQuery -parseQuery_ = either (error . show) id . parseQuery +parseQuery_ = either error id . parseQuery main :: IO () main = hspecX $ do diff --git a/yesod-test/yesod-test.cabal b/yesod-test/yesod-test.cabal index 9f4a0d2a..5894713e 100644 --- a/yesod-test/yesod-test.cabal +++ b/yesod-test/yesod-test.cabal @@ -22,7 +22,7 @@ library else build-depends: base >= 4 && < 4.3 build-depends: hxt >= 9.1.6 - , parsec >= 2.1 && < 4 + , attoparsec >= 0.10 && < 0.11 , persistent >= 0.9 && < 0.10 , transformers >= 0.2.2 && < 0.3 , wai >= 1.2 && < 1.3