{-# LANGUAGE OverloadedStrings #-}
-- | Parse CSS with parseNestedBlocks and render it with renderNestedBlock
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] -- ^ for example a media query
                 | 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)

-- | The preferred parser, will capture media queries
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

-- | The original parser of basic CSS, but throws out media queries
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
    -- no colon means no content
    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)

    -- TODO: handle infinite nesting
    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