Migrated yesod-test to attoparsec

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"

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

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)

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

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