{-# LANGUAGE OverloadedStrings #-}
module Yesod.Test.CssQuery
( SelectorGroup (..)
, Selector (..)
, parseQuery
) where
import Prelude hiding (takeWhile)
import Data.Text (Text)
import Data.Attoparsec.Text
import Control.Applicative
import Data.Char
import qualified Data.Text as T
data SelectorGroup
= DirectChildren [Selector]
| DeepChildren [Selector]
deriving (Show, Eq)
data Selector
= ById Text
| ByClass Text
| ByTagName Text
| ByAttrExists Text
| ByAttrEquals Text Text
| ByAttrContains Text Text
| ByAttrStarts Text Text
| ByAttrEnds Text Text
deriving (Show, Eq)
parseQuery :: Text -> Either String [[SelectorGroup]]
parseQuery = parseOnly cssQuery
cssQuery :: Parser [[SelectorGroup]]
cssQuery = many (char ' ') >> sepBy rules (char ',' >> many (char ' '))
rules :: Parser [SelectorGroup]
rules = many $ directChildren <|> deepChildren
directChildren :: Parser SelectorGroup
directChildren =
string "> " >> (many (char ' ')) >> DirectChildren <$> pOptionalTrailingSpace parseSelectors
deepChildren :: Parser SelectorGroup
deepChildren = pOptionalTrailingSpace $ DeepChildren <$> parseSelectors
parseSelectors :: Parser [Selector]
parseSelectors = many1 $
parseId <|> parseClass <|> parseTag <|> parseAttr
parseId :: Parser Selector
parseId = char '#' >> ById <$> pIdent
parseClass :: Parser Selector
parseClass = char '.' >> ByClass <$> pIdent
parseTag :: Parser Selector
parseTag = ByTagName <$> pIdent
parseAttr :: Parser Selector
parseAttr = pSquare $ choice
[ ByAttrEquals <$> pIdent <*> (string "=" *> pAttrValue)
, ByAttrContains <$> pIdent <*> (string "*=" *> pAttrValue)
, ByAttrStarts <$> pIdent <*> (string "^=" *> pAttrValue)
, ByAttrEnds <$> pIdent <*> (string "$=" *> pAttrValue)
, ByAttrExists <$> pIdent
]
pIdent :: Parser Text
pIdent = do
leadingMinus <- string "-" <|> pure ""
nmstart <- T.singleton <$> satisfy (\c -> isAlpha c || c == '_')
nmchar <- takeWhile (\c -> isAlphaNum c || c == '_' || c == '-')
return $ T.concat [ leadingMinus, nmstart, nmchar ]
pAttrValue :: Parser Text
pAttrValue = takeWhile (/= ']')
pSquare :: Parser a -> Parser a
pSquare p = char '[' *> p <* char ']'
pOptionalTrailingSpace :: Parser a -> Parser a
pOptionalTrailingSpace p = p <* many (char ' ')