{-# 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
_ <- Char -> Parser Char
char Char
'*'
(Char -> Parser Char
char Char
'/' Parser Char -> 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 ()
forall a. a -> Parser Text a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) 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 ()
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
Text
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
_ <- Char -> Parser Char
char Char
':' Parser Char -> Parser Char -> Parser Char
forall a. Parser Text a -> Parser Text a -> Parser Text a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> Parser Char
forall a. String -> Parser Text a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Missing colon in attribute"
Text
value <- Parser Text
valueParser
(Text, Text) -> Parser (Text, Text)
forall a. a -> Parser Text a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Text
strip Text
key, Text -> Text
strip Text
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
(Text, Text)
a <- Parser (Text, Text)
attrParser
(Char -> Parser Char
char Char
';' Parser Char -> 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 [(Text, Text)] -> Parser [(Text, Text)]
forall a b. Parser Text a -> Parser Text b -> Parser Text b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (((Text, Text)
a (Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. a -> [a] -> [a]
:) ([(Text, Text)] -> [(Text, Text)])
-> Parser [(Text, Text)] -> Parser [(Text, Text)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser [(Text, Text)]
attrsParser))
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 [(Text, Text)
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
Text
sel <- (Char -> Bool) -> Parser Text
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'{')
Char
_ <- Char -> Parser Char
char Char
'{'
[(Text, Text)]
attrs <- Parser [(Text, Text)]
attrsParser
Parser ()
skipWS
Char
_ <- Char -> Parser Char
char Char
'}'
CssBlock -> Parser CssBlock
forall a. a -> Parser Text a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Text
strip Text
sel, [(Text, Text)]
attrs)
nestedBlockParser :: Parser NestedBlock
nestedBlockParser :: Parser NestedBlock
nestedBlockParser = do
Parser ()
skipWS
Text
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
_ <- Char -> Parser Char
char Char
'{'
Parser ()
skipWS
Text
unknown <- 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
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
':')
Maybe Char
mc <- Parser (Maybe Char)
peekChar
NestedBlock
res <- case Maybe Char
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
Parser ()
skipWS
Char
_ <- Char -> Parser Char
char Char
'}'
NestedBlock -> Parser NestedBlock
forall a. a -> Parser Text a
forall (m :: * -> *) a. Monad m => a -> m a
return NestedBlock
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
_ <- Char -> Parser Char
char Char
':'
Text
value <- Parser Text
valueParser
(Char -> Parser Char
char Char
';' Parser Char -> 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 ()
forall a. a -> Parser Text a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) 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 ()
Parser ()
skipWS
[(Text, Text)]
moreAttrs <- Parser [(Text, Text)]
attrsParser
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, (Text
unknown, Text -> Text
strip Text
value) (Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. a -> [a] -> [a]
: [(Text, Text)]
moreAttrs)
nestedParse Text
sel Text
unknown Char
'{' = do
Char
_ <- Char -> Parser Char
char Char
'{'
[(Text, Text)]
attrs <- Parser [(Text, Text)]
attrsParser
Parser ()
skipWS
Char
_ <- Char -> Parser Char
char Char
'}'
[CssBlock]
blocks <- Parser [CssBlock]
blocksParser
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
$ Text -> [NestedBlock] -> NestedBlock
NestedBlock Text
sel ([NestedBlock] -> NestedBlock) -> [NestedBlock] -> NestedBlock
forall a b. (a -> b) -> a -> b
$ (CssBlock -> NestedBlock) -> [CssBlock] -> [NestedBlock]
forall a b. (a -> b) -> [a] -> [b]
map CssBlock -> NestedBlock
LeafBlock ([CssBlock] -> [NestedBlock]) -> [CssBlock] -> [NestedBlock]
forall a b. (a -> b) -> a -> b
$ (Text
unknown, [(Text, Text)]
attrs) CssBlock -> [CssBlock] -> [CssBlock]
forall a. a -> [a] -> [a]
: [CssBlock]
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