{-# 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NestedBlock -> NestedBlock -> Bool
$c/= :: NestedBlock -> NestedBlock -> Bool
== :: NestedBlock -> NestedBlock -> Bool
$c== :: NestedBlock -> NestedBlock -> Bool
Eq, Int -> NestedBlock -> ShowS
[NestedBlock] -> ShowS
NestedBlock -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NestedBlock] -> ShowS
$cshowList :: [NestedBlock] -> ShowS
show :: NestedBlock -> String
$cshow :: NestedBlock -> String
showsPrec :: Int -> NestedBlock -> ShowS
$cshowsPrec :: Int -> NestedBlock -> ShowS
Show)

-- | The preferred parser, will capture media queries
parseNestedBlocks :: Text -> Either String [NestedBlock]
parseNestedBlocks :: Text -> Either String [NestedBlock]
parseNestedBlocks = 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 = forall a. Parser a -> Text -> Either String a
parseOnly Parser [CssBlock]
blocksParser

parseBlock :: Text -> Either String CssBlock
parseBlock :: Text -> Either String CssBlock
parseBlock = 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 = 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 = forall a. Parser a -> Text -> Either String a
parseOnly Parser (Text, Text)
attrParser


skipWS :: Parser ()
skipWS :: Parser ()
skipWS = (Text -> Parser Text
string Text
"/*" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser ()
endComment forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser ()
skipWS)
     forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ((Char -> Bool) -> Parser ()
skip Char -> Bool
isSpace forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char -> Bool) -> Parser ()
skipWhile Char -> Bool
isSpace forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser ()
skipWS)
     forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
    endComment :: Parser ()
endComment = do
        (Char -> Bool) -> Parser ()
skipWhile (forall a. Eq a => a -> a -> Bool
/= Char
'*')
        (do
            Char
_ <- Char -> Parser Char
char Char
'*'
            (Char -> Parser Char
char Char
'/' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ()) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ()
endComment
            ) forall (f :: * -> *) a. Alternative f => f a -> f a -> f 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 forall a. Eq a => a -> a -> Bool
/= Char
':' 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
'}')
    Char
_ <- Char -> Parser Char
char Char
':' forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Missing colon in attribute"
    Text
value <- Parser Text
valueParser
    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 forall a. Eq a => a -> a -> Bool
/= Char
';' Bool -> Bool -> Bool
&& Char
c 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
';' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser ()
skipWS forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (((Text, Text)
a forall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser [(Text, Text)]
attrsParser))
      forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) a. Monad m => a -> m a
return [(Text, Text)
a]
  ) forall (f :: * -> *) a. Alternative f => f a -> f a -> f 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 (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
'}'
    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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser Text
takeTill (forall a. Eq a => a -> a -> Bool
== Char
'{')
    Char
_ <- Char -> Parser Char
char Char
'{'
    Parser ()
skipWS

    Text
unknown <- Text -> Text
strip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser Text
takeTill (\Char
c -> Char
c forall a. Eq a => a -> a -> Bool
== Char
'{' 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
':')
    Maybe Char
mc <- Parser (Maybe Char)
peekChar
    NestedBlock
res <- case Maybe Char
mc of
      Maybe Char
Nothing -> 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
'}'
    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
'}' = forall (m :: * -> *) a. Monad m => a -> m a
return 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
';' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ()) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Parser ()
skipWS
        [(Text, Text)]
moreAttrs <- Parser [(Text, Text)]
attrsParser
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ CssBlock -> NestedBlock
LeafBlock (Text
sel, (Text
unknown, Text -> Text
strip Text
value) 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
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text -> [NestedBlock] -> NestedBlock
NestedBlock Text
sel forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map CssBlock -> NestedBlock
LeafBlock forall a b. (a -> b) -> a -> b
$ (Text
unknown, [(Text, Text)]
attrs) forall a. a -> [a] -> [a]
: [CssBlock]
blocks
    nestedParse Text
_ Text
_ Char
c = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"expected { or : but got " forall a. [a] -> [a] -> [a]
++ [Char
c]

blocksParser :: Parser [(Text, [(Text, Text)])]
blocksParser :: Parser [CssBlock]
blocksParser = forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser CssBlock
blockParser

nestedBlocksParser :: Parser [NestedBlock]
nestedBlocksParser :: Parser [NestedBlock]
nestedBlocksParser = forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser NestedBlock
nestedBlockParser