{-# LANGUAGE OverloadedStrings #-}
module Text.CSS.Parse
( NestedBlock(..)
, parseNestedBlocks
, parseBlocks
, parseBlock
, attrParser
, attrsParser
, blockParser
, blocksParser
, parseAttr
, parseAttrs
) where
import Prelude hiding (takeWhile, take)
import Data.Attoparsec.Text
import Data.Text (Text, strip)
import Control.Applicative ((<|>), many, (<$>))
import Data.Char (isSpace)
type CssBlock = (Text, [(Text, Text)])
data NestedBlock = NestedBlock Text [NestedBlock]
| LeafBlock CssBlock
deriving (NestedBlock -> NestedBlock -> Bool
(NestedBlock -> NestedBlock -> Bool)
-> (NestedBlock -> NestedBlock -> Bool) -> Eq NestedBlock
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NestedBlock -> NestedBlock -> Bool
== :: NestedBlock -> NestedBlock -> Bool
$c/= :: NestedBlock -> NestedBlock -> Bool
/= :: NestedBlock -> NestedBlock -> Bool
Eq, Int -> NestedBlock -> ShowS
[NestedBlock] -> ShowS
NestedBlock -> String
(Int -> NestedBlock -> ShowS)
-> (NestedBlock -> String)
-> ([NestedBlock] -> ShowS)
-> Show NestedBlock
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NestedBlock -> ShowS
showsPrec :: Int -> NestedBlock -> ShowS
$cshow :: NestedBlock -> String
show :: NestedBlock -> String
$cshowList :: [NestedBlock] -> ShowS
showList :: [NestedBlock] -> ShowS
Show)
parseNestedBlocks :: Text -> Either String [NestedBlock]
parseNestedBlocks :: Text -> Either String [NestedBlock]
parseNestedBlocks = Parser [NestedBlock] -> Text -> Either String [NestedBlock]
forall a. Parser a -> Text -> Either String a
parseOnly Parser [NestedBlock]
nestedBlocksParser
parseBlocks :: Text -> Either String [CssBlock]
parseBlocks :: Text -> Either String [CssBlock]
parseBlocks = Parser [CssBlock] -> Text -> Either String [CssBlock]
forall a. Parser a -> Text -> Either String a
parseOnly Parser [CssBlock]
blocksParser
parseBlock :: Text -> Either String CssBlock
parseBlock :: Text -> Either String CssBlock
parseBlock = Parser CssBlock -> Text -> Either String CssBlock
forall a. Parser a -> Text -> Either String a
parseOnly Parser CssBlock
blockParser
parseAttrs :: Text -> Either String [(Text, Text)]
parseAttrs :: Text -> Either String [(Text, Text)]
parseAttrs = Parser [(Text, Text)] -> Text -> Either String [(Text, Text)]
forall a. Parser a -> Text -> Either String a
parseOnly Parser [(Text, Text)]
attrsParser
parseAttr :: Text -> Either String (Text, Text)
parseAttr :: Text -> Either String (Text, Text)
parseAttr = Parser (Text, Text) -> Text -> Either String (Text, Text)
forall a. Parser a -> Text -> Either String a
parseOnly Parser (Text, Text)
attrParser
skipWS :: Parser ()
skipWS :: Parser ()
skipWS = (Text -> Parser Text
string Text
"/*" Parser Text -> Parser () -> Parser ()
forall a b. Parser Text a -> Parser Text b -> Parser Text b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser ()
endComment Parser () -> Parser () -> Parser ()
forall a b. Parser Text a -> Parser Text b -> Parser Text b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser ()
skipWS)
Parser () -> Parser () -> Parser ()
forall a. Parser Text a -> Parser Text a -> Parser Text a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ((Char -> Bool) -> Parser ()
skip Char -> Bool
isSpace Parser () -> Parser () -> Parser ()
forall a b. Parser Text a -> Parser Text b -> Parser Text b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char -> Bool) -> Parser ()
skipWhile Char -> Bool
isSpace Parser () -> Parser () -> Parser ()
forall a b. Parser Text a -> Parser Text b -> Parser Text b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser ()
skipWS)
Parser () -> Parser () -> Parser ()
forall a. Parser Text a -> Parser Text a -> Parser Text a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> () -> Parser ()
forall a. a -> Parser Text a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
where
endComment :: Parser ()
endComment = do
(Char -> Bool) -> Parser ()
skipWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'*')
(do
_ <- Char -> Parser Char
char Char
'*'
(char '/' >> return ()) <|> endComment
) Parser () -> Parser () -> Parser ()
forall a. Parser Text a -> Parser Text a -> Parser Text a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> Parser ()
forall a. String -> Parser Text a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Missing end comment"
attrParser :: Parser (Text, Text)
attrParser :: Parser (Text, Text)
attrParser = do
Parser ()
skipWS
key <- (Char -> Bool) -> Parser Text
takeWhile1 (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
':' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'{' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'}')
_ <- char ':' <|> fail "Missing colon in attribute"
value <- valueParser
return (strip key, strip value)
valueParser :: Parser Text
valueParser :: Parser Text
valueParser = (Char -> Bool) -> Parser Text
takeWhile (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
';' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'}')
attrsParser :: Parser [(Text, Text)]
attrsParser :: Parser [(Text, Text)]
attrsParser = (do
a <- Parser (Text, Text)
attrParser
(char ';' >> skipWS >> ((a :) <$> attrsParser))
<|> return [a]
) Parser [(Text, Text)]
-> Parser [(Text, Text)] -> Parser [(Text, Text)]
forall a. Parser Text a -> Parser Text a -> Parser Text a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [(Text, Text)] -> Parser [(Text, Text)]
forall a. a -> Parser Text a
forall (m :: * -> *) a. Monad m => a -> m a
return []
blockParser :: Parser (Text, [(Text, Text)])
blockParser :: Parser CssBlock
blockParser = do
Parser ()
skipWS
sel <- (Char -> Bool) -> Parser Text
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'{')
_ <- char '{'
attrs <- attrsParser
skipWS
_ <- char '}'
return (strip sel, attrs)
nestedBlockParser :: Parser NestedBlock
nestedBlockParser :: Parser NestedBlock
nestedBlockParser = do
Parser ()
skipWS
sel <- Text -> Text
strip (Text -> Text) -> Parser Text -> Parser Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser Text
takeTill (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'{')
_ <- char '{'
skipWS
unknown <- strip <$> takeTill (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'{' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'}' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':')
mc <- peekChar
res <- case mc of
Maybe Char
Nothing -> String -> Parser NestedBlock
forall a. String -> Parser Text a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"unexpected end of input"
Just Char
c -> Text -> Text -> Char -> Parser NestedBlock
nestedParse Text
sel Text
unknown Char
c
skipWS
_ <- char '}'
return res
where
nestedParse :: Text -> Text -> Char -> Parser NestedBlock
nestedParse Text
sel Text
_ Char
'}' = NestedBlock -> Parser NestedBlock
forall a. a -> Parser Text a
forall (m :: * -> *) a. Monad m => a -> m a
return (NestedBlock -> Parser NestedBlock)
-> NestedBlock -> Parser NestedBlock
forall a b. (a -> b) -> a -> b
$ CssBlock -> NestedBlock
LeafBlock (Text
sel, [])
nestedParse Text
sel Text
unknown Char
':' = do
_ <- Char -> Parser Char
char Char
':'
value <- valueParser
(char ';' >> return ()) <|> return ()
skipWS
moreAttrs <- attrsParser
return $ LeafBlock (sel, (unknown, strip value) : moreAttrs)
nestedParse Text
sel Text
unknown Char
'{' = do
_ <- Char -> Parser Char
char Char
'{'
attrs <- attrsParser
skipWS
_ <- char '}'
blocks <- blocksParser
return $ NestedBlock sel $ map LeafBlock $ (unknown, attrs) : blocks
nestedParse Text
_ Text
_ Char
c = String -> Parser NestedBlock
forall a. String -> Parser Text a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser NestedBlock) -> String -> Parser NestedBlock
forall a b. (a -> b) -> a -> b
$ String
"expected { or : but got " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char
c]
blocksParser :: Parser [(Text, [(Text, Text)])]
blocksParser :: Parser [CssBlock]
blocksParser = Parser CssBlock -> Parser [CssBlock]
forall a. Parser Text a -> Parser Text [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser CssBlock
blockParser
nestedBlocksParser :: Parser [NestedBlock]
nestedBlocksParser :: Parser [NestedBlock]
nestedBlocksParser = Parser NestedBlock -> Parser [NestedBlock]
forall a. Parser Text a -> Parser Text [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser NestedBlock
nestedBlockParser