{-# 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 (Eq, Show)

-- | The preferred parser, will capture media queries
parseNestedBlocks :: Text -> Either String [NestedBlock]
parseNestedBlocks = parseOnly nestedBlocksParser

-- | The original parser of basic CSS, but throws out media queries
parseBlocks :: Text -> Either String [CssBlock]
parseBlocks = parseOnly blocksParser

parseBlock :: Text -> Either String CssBlock
parseBlock = parseOnly blockParser

parseAttrs :: Text -> Either String [(Text, Text)]
parseAttrs = parseOnly attrsParser

parseAttr :: Text -> Either String (Text, Text)
parseAttr = parseOnly attrParser


skipWS :: Parser ()
skipWS = (string "/*" >> endComment >> skipWS)
     <|> (skip isSpace >> skipWhile isSpace >> skipWS)
     <|> return ()
  where
    endComment = do
        skipWhile (/= '*')
        (do
            _ <- char '*'
            (char '/' >> return ()) <|> endComment
            ) <|> fail "Missing end comment"

attrParser :: Parser (Text, Text)
attrParser = do
    skipWS
    key <- takeWhile1 (\c -> c /= ':' && c /= '{' && c /= '}')
    _ <- char ':' <|> fail "Missing colon in attribute"
    value <- valueParser
    return (strip key, strip value)

valueParser :: Parser Text
valueParser = takeWhile (\c -> c /= ';' && c /= '}')

attrsParser :: Parser [(Text, Text)]
attrsParser = (do
    a <- attrParser
    (char ';' >> skipWS >> ((a :) <$> attrsParser))
      <|> return [a]
  ) <|> return []

blockParser :: Parser (Text, [(Text, Text)])
blockParser = do
    skipWS
    sel <- takeWhile (/= '{')
    _ <- char '{'
    attrs <- attrsParser
    skipWS
    _ <- char '}'
    return (strip sel, attrs)

nestedBlockParser :: Parser NestedBlock
nestedBlockParser = do
    skipWS
    sel <- strip <$> takeTill (== '{')
    _ <- char '{'
    skipWS

    unknown <- strip <$> takeTill (\c -> c == '{' || c == '}' || c == ':')
    mc <- peekChar
    res <- case mc of
      Nothing -> fail "unexpected end of input"
      Just c -> nestedParse sel unknown c

    skipWS
    _ <- char '}'
    return res
  where
    -- no colon means no content
    nestedParse sel _ '}' = return $ LeafBlock (sel, [])

    nestedParse sel unknown ':' = do
        _ <- char ':'
        value <- valueParser
        (char ';' >> return ()) <|> return ()
        skipWS
        moreAttrs <- attrsParser
        return $ LeafBlock (sel, (unknown, strip value) : moreAttrs)

    -- TODO: handle infinite nesting
    nestedParse sel unknown '{' = do
        _ <- char '{'
        attrs <- attrsParser
        skipWS
        _ <- char '}'
        blocks <- blocksParser
        return $ NestedBlock sel $ map LeafBlock $ (unknown, attrs) : blocks
    nestedParse _ _ c = fail $ "expected { or : but got " ++ [c]

blocksParser :: Parser [(Text, [(Text, Text)])]
blocksParser = many blockParser

nestedBlocksParser :: Parser [NestedBlock]
nestedBlocksParser = many nestedBlockParser
