{-# LANGUAGE OverloadedStrings #-}
-- | Parsing CSS selectors into queries.
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 (Int -> SelectorGroup -> ShowS
[SelectorGroup] -> ShowS
SelectorGroup -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SelectorGroup] -> ShowS
$cshowList :: [SelectorGroup] -> ShowS
show :: SelectorGroup -> String
$cshow :: SelectorGroup -> String
showsPrec :: Int -> SelectorGroup -> ShowS
$cshowsPrec :: Int -> SelectorGroup -> ShowS
Show, SelectorGroup -> SelectorGroup -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SelectorGroup -> SelectorGroup -> Bool
$c/= :: SelectorGroup -> SelectorGroup -> Bool
== :: SelectorGroup -> SelectorGroup -> Bool
$c== :: SelectorGroup -> SelectorGroup -> Bool
Eq)

data Selector
  = ById Text
  | ByClass Text
  | ByTagName Text
  | ByAttrExists Text
  | ByAttrEquals Text Text
  | ByAttrContains Text Text
  | ByAttrStarts Text Text
  | ByAttrEnds Text Text
  deriving (Int -> Selector -> ShowS
[Selector] -> ShowS
Selector -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Selector] -> ShowS
$cshowList :: [Selector] -> ShowS
show :: Selector -> String
$cshow :: Selector -> String
showsPrec :: Int -> Selector -> ShowS
$cshowsPrec :: Int -> Selector -> ShowS
Show, Selector -> Selector -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Selector -> Selector -> Bool
$c/= :: Selector -> Selector -> Bool
== :: Selector -> Selector -> Bool
$c== :: Selector -> Selector -> Bool
Eq)


-- The official syntax specification for CSS2 can be found here:
--      http://www.w3.org/TR/CSS2/syndata.html
-- but that spec is tricky to fully support. Instead we do the minimal and we
-- can extend it as needed.


-- | 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 :: Text -> Either String [[SelectorGroup]]
parseQuery :: Text -> Either String [[SelectorGroup]]
parseQuery = forall a. Parser a -> Text -> Either String a
parseOnly Parser [[SelectorGroup]]
cssQuery

-- Below this line is the Parsec parser for css queries.
cssQuery :: Parser [[SelectorGroup]]
cssQuery :: Parser [[SelectorGroup]]
cssQuery = forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Char -> Parser Char
char Char
' ') forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
sepBy Parser [SelectorGroup]
rules (Char -> Parser Char
char Char
',' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Char -> Parser Char
char Char
' '))

rules :: Parser [SelectorGroup]
rules :: Parser [SelectorGroup]
rules = forall (f :: * -> *) a. Alternative f => f a -> f [a]
many forall a b. (a -> b) -> a -> b
$ Parser Text SelectorGroup
directChildren forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text SelectorGroup
deepChildren

directChildren :: Parser SelectorGroup
directChildren :: Parser Text SelectorGroup
directChildren =
    Text -> Parser Text
string Text
"> " forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Char -> Parser Char
char Char
' ')) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Selector] -> SelectorGroup
DirectChildren forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Parser a -> Parser a
pOptionalTrailingSpace Parser [Selector]
parseSelectors

deepChildren :: Parser SelectorGroup
deepChildren :: Parser Text SelectorGroup
deepChildren = forall a. Parser a -> Parser a
pOptionalTrailingSpace forall a b. (a -> b) -> a -> b
$ [Selector] -> SelectorGroup
DeepChildren forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser [Selector]
parseSelectors

parseSelectors :: Parser [Selector]
parseSelectors :: Parser [Selector]
parseSelectors = forall (f :: * -> *) a. Alternative f => f a -> f [a]
many1 forall a b. (a -> b) -> a -> b
$
    Parser Text Selector
parseId forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text Selector
parseClass forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text Selector
parseTag forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text Selector
parseAttr

parseId :: Parser Selector
parseId :: Parser Text Selector
parseId = Char -> Parser Char
char Char
'#' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Text -> Selector
ById forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
pIdent

parseClass :: Parser Selector
parseClass :: Parser Text Selector
parseClass = Char -> Parser Char
char Char
'.' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Text -> Selector
ByClass forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
pIdent

parseTag :: Parser Selector
parseTag :: Parser Text Selector
parseTag = Text -> Selector
ByTagName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
pIdent

parseAttr :: Parser Selector
parseAttr :: Parser Text Selector
parseAttr = forall a. Parser a -> Parser a
pSquare forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Alternative f => [f a] -> f a
choice
    [ Text -> Text -> Selector
ByAttrEquals forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
pIdent forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Text -> Parser Text
string Text
"=" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text
pAttrValue)
    , Text -> Text -> Selector
ByAttrContains forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
pIdent forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Text -> Parser Text
string Text
"*=" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text
pAttrValue)
    , Text -> Text -> Selector
ByAttrStarts forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
pIdent forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Text -> Parser Text
string Text
"^=" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text
pAttrValue)
    , Text -> Text -> Selector
ByAttrEnds forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
pIdent forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Text -> Parser Text
string Text
"$=" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text
pAttrValue)
    , Text -> Selector
ByAttrExists forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
pIdent
    ]

-- | pIdent : Parse an identifier (not yet supporting escapes and unicode as
-- part of the identifier). Basically the regex: [-]?[_a-zA-Z][_a-zA-Z0-9]*
pIdent :: Parser Text
pIdent :: Parser Text
pIdent = do
    Text
leadingMinus <- Text -> Parser Text
string Text
"-" forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
""
    Text
nmstart <- Char -> Text
T.singleton forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser Char
satisfy (\Char
c -> Char -> Bool
isAlpha Char
c Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'_')
    Text
nmchar <- (Char -> Bool) -> Parser Text
takeWhile (\Char
c -> Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'-')
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat [ Text
leadingMinus, Text
nmstart, Text
nmchar ]


pAttrValue :: Parser Text
pAttrValue :: Parser Text
pAttrValue = (Char -> Bool) -> Parser Text
takeWhile (forall a. Eq a => a -> a -> Bool
/= Char
']')

pSquare :: Parser a -> Parser a
pSquare :: forall a. Parser a -> Parser a
pSquare Parser a
p = Char -> Parser Char
char Char
'[' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser a
p forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Char
char Char
']'

pOptionalTrailingSpace :: Parser a -> Parser a
pOptionalTrailingSpace :: forall a. Parser a -> Parser a
pOptionalTrailingSpace Parser a
p = Parser a
p forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Char -> Parser Char
char Char
' ')