module Text.CSS3.Selectors.Parser (
parseSelectorGroup,
parseSelector,
sel,
selectorGroup,
selector,
simpleSelectorSequence,
headSimpleSelector,
tailSimpleSelector,
attributeSelector,
attributeOperator,
combinator,
pseudoClass,
pseudoClassParameter,
whitespace,
identifier,
name,
nameStartLetter,
nameCharLetter
) where
import Control.Applicative
import Control.Monad
import Data.Char
import Data.Maybe
import Numeric
import Text.CSS3.Selectors.Syntax
import Text.Parsec hiding ((<|>), optional, newline, many, Empty)
import qualified Text.Parsec as Parsec ((<|>), optional, newline, many)
import Text.Parsec.String
parseSelectorGroup :: String -> Either ParseError SelectorGroup
parseSelectorGroup = parse (selectorGroup <* eof) ""
parseSelector :: String -> Either ParseError Selector
parseSelector = parse (selector <* eof) ""
sel :: String -> Selector
sel = either (error . show) id . parse (selector <* eof) ""
selectorGroup :: Parser SelectorGroup
selectorGroup = SelectorGroup <$> selector
<*> many (many whitespace *> char ',' *> many whitespace *> selector)
selector :: Parser Selector
selector = Selector <$> simpleSelectorSequence
<*> optional (try $ (,) <$> combinator <*> selector)
simpleSelectorSequence :: Parser SimpleSelectorSequence
simpleSelectorSequence = SimpleSelectorSequence <$> headSimpleSelector <*> many tailSimpleSelector
<|> SimpleSelectorSequence UniversalSelector <$> many1 tailSimpleSelector
headSimpleSelector :: Parser HeadSimpleSelector
headSimpleSelector = TypeSelector <$> identifier
<|> UniversalSelector <$ char '*'
tailSimpleSelector :: Parser TailSimpleSelector
tailSimpleSelector = attributeSelector
<|> ClassSelector <$> (char '.' *> identifier)
<|> IDSelector <$> (char '#' *> name)
<|> PseudoClass <$> (char ':' *> pseudoClass)
attributeSelector :: Parser TailSimpleSelector
attributeSelector = AttributeSelector
<$> (char '[' *> many whitespace *> identifier <* many whitespace)
<*> optional ((,) <$> attributeOperator <* many whitespace
<*> (identifier <|> quotedString) <* many whitespace)
<* char ']'
attributeOperator :: Parser AttributeOperator
attributeOperator = ExactMatch <$ string "="
<|> IncludesMatch <$ string "~="
<|> DashMatch <$ string "|="
<|> PrefixMatch <$ string "^="
<|> SuffixMatch <$ string "$="
<|> InfixMatch <$ string "*="
combinator :: Parser Combinator
combinator = try (Child <$ (many whitespace *> char '>' <* many whitespace))
<|> try (AdjacentSibling <$ (many whitespace *> char '+' <* many whitespace))
<|> try (GeneralSibling <$ (many whitespace *> char '~' <* many whitespace))
<|> Descendant <$ many1 whitespace
pseudoClass :: Parser PseudoClass
pseudoClass = Root <$ try (string "root")
<|> NthChild <$> (try (string "nth-child") *> parameter pseudoClassParameter)
<|> NthLastChild <$> (try (string "nth-last-child") *> parameter pseudoClassParameter)
<|> NthOfType <$> (try (string "nth-of-type") *> parameter pseudoClassParameter)
<|> NthLastOfType <$> (try (string "nth-last-of-type") *> parameter pseudoClassParameter)
<|> FirstChild <$ try (string "first-child")
<|> LastChild <$ try (string "last-child")
<|> FirstOfType <$ try (string "first-of-type")
<|> LastOfType <$ try (string "last-of-type")
<|> OnlyChild <$ try (string "only-child")
<|> OnlyOfType <$ try (string "only-of-type")
<|> Empty <$ try (string "empty")
<|> Not <$> (try kwNot *> parameter (Left <$> headSimpleSelector
<|> Right <$> tailSimpleSelector))
where parameter p = char '(' *> many whitespace *> p <* many whitespace <* char ')'
pseudoClassParameter :: Parser PseudoClassParameter
pseudoClassParameter = PseudoClassParameter <$> (try $ option id sign <*> option 1 integer <* oneOf "nN")
<*> (option 0 $ many whitespace *> sign <* many whitespace <*> integer)
<|> PseudoClassParameter 0 <$> (option id sign <*> integer)
<|> PseudoClassParameter 2 1 <$ kwOdd
<|> PseudoClassParameter 2 0 <$ kwEven
sign :: Parser (Integer -> Integer)
sign = negate <$ char '-' <|> id <$ char '+'
integer :: Parser Integer
integer = foldl (\a c -> 10*a + toInteger (ord c) 48) 0 <$> many1 digit
identifier :: Parser String
identifier = (\d c cs -> (maybe id (:) d) $ c : cs)
<$> optional (char '-') <*> nameStartLetter <*> many nameCharLetter
name :: Parser String
name = many1 nameCharLetter
nameStartLetter :: Parser Char
nameStartLetter = asciiLetter <|> char '_' <|> nonAsciiLetter <|> escapedLetter
nameCharLetter :: Parser Char
nameCharLetter = char '_' <|> asciiLetter <|> digit <|> char '-' <|> nonAsciiLetter <|> escapedLetter
asciiLetter :: Parser Char
asciiLetter = satisfy $ \c -> c >= 'a' && c <= 'z' || c >='A' && c <= 'Z'
nonAsciiLetter :: Parser Char
nonAsciiLetter = satisfy (\c -> ord c > 127)
unicodeLetter :: Parser Char
unicodeLetter = char '\\' *> (chr . fst . head . readHex <$> countFromTo 1 6 (satisfy isHexDigit))
<* optional (try (string "\r\n") <|> pure <$> whitespace)
escapedLetter :: Parser Char
escapedLetter = try unicodeLetter
<|> char '\\' *> satisfy (\c -> not (isHexDigit c) && c `notElem` "\n\r\f")
quotedString :: Parser String
quotedString = char '\"' *> (concat <$> many (stringChar '\"')) <* char '\"'
<|> char '\'' *> (concat <$> many (stringChar '\'')) <* char '\''
where
stringChar :: Char -> Parser String
stringChar delim = pure <$> satisfy (`notElem` (delim : "\n\r\f\\"))
<|> try (char '\\' *> newline)
<|> pure <$> escapedLetter
newline :: Parser String
newline = try (string "\r\n") <|> pure <$> oneOf "\n\r\f"
whitespace :: Parser Char
whitespace = oneOf " \t\n\r\f"
kwNot, kwOdd, kwEven :: Parser String
kwNot = sequence [oneOf "nN", oneOf "oO", oneOf "tT"]
kwOdd = sequence [oneOf "oO", oneOf "dD", oneOf "dD"]
kwEven = sequence [oneOf "eE", oneOf "vV", oneOf "eE", oneOf "nN"]
countFromTo :: Stream s m t => Int -> Int -> ParsecT s u m a -> ParsecT s u m [a]
countFromTo n m p
| m < n = pure []
| otherwise = (++) <$> count n p <*> (catMaybes <$> replicateM (m n) (optional p))