{-
  -Copyright (c) 2015 Edward Langley
  -All rights reserved.
  -
  -Redistribution and use in source and binary forms, with or without
  -modification, are permitted provided that the following conditions
  -are met:
  -
  -Redistributions of source code must retain the above copyright notice,
  -this list of conditions and the following disclaimer.
  -
  -Redistributions in binary form must reproduce the above copyright
  -notice, this list of conditions and the following disclaimer in the
  -documentation and/or other materials provided with the distribution.
  -
  -Neither the name of the project's author nor the names of its
  -contributors may be used to endorse or promote products derived from
  -this software without specific prior written permission.
  -
  -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
  -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
  -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
  -FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
  -HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
  -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
  -TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
  -PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
  -LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
  -NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
  -SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  -}
 
 {-# LANGUAGE RankNTypes,KindSignatures #-}
 
 module CssParser
   where
 

 import Prelude hiding (init,fst,length)

 import Control.Monad
 import qualified Text.Parsec as NP
 import Text.ParserCombinators.Parsec
 import Data.Functor.Identity()
 import Text.Parsec.Prim()
 import Data.Map hiding (foldr,null,map)
 import Data.Maybe
 
 data URL = URLFunc String |
            URLString String |
            URLMedia [String] URL
   deriving (Show, Eq)
 
 
 type Query = [String]
 data CSSDeclaration = CSSDeclaration CSSSelector CSSBody |
                       PageDeclaration (Maybe String) CSSBody |
                       Charset String |
                       Import URL |
                       MediaQuery Query CSSDeclaration |
                       DeclarationList [CSSDeclaration]
   deriving (Show,Eq)
 
 
 type CSSBody = Map String String
 
 data CSSSelector =
   Ident String |
   TagName String |
   Pseudo String |
   Attribute String String |
   Id String |
   Class String |
   Sibling CSSSelector CSSSelector | -- These are all XRelation Head Tail
   DirectChild CSSSelector CSSSelector |
   Child CSSSelector CSSSelector |
   SelectorList [CSSSelector]
   deriving (Show,Eq)
 
 matchUpToX :: (Eq a,Num a) => GenParser Char st Char -> a -> GenParser Char st String

 matchUpToX p = scan id

   where
     scan f x = if x == 0
       then return (f [])
       else do {
         nxt <- p;
         scan (\tail_ -> f (nxt:tail_)) (x-1)
       } <|> return (f [])
 
 match1ToX :: (Eq a,Num a) => GenParser Char st Char -> a -> GenParser Char st String
 match1ToX p n = do
   result <- p
   tail_ <- matchUpToX p (n-1)
   return (result:tail_)
 
 -- Char classes
 h :: GenParser Char st Char
 h = hexDigit
 
 nonascii  :: GenParser Char st Char
 nonascii  = satisfy isNonAscii
   where
     isNonAscii a = '\240' <= a && a <= '\1114111'
 
 unicode :: GenParser Char st String
 unicode = do

   _ <- char '\\'

   result <- match1ToX h (6 :: Integer)
   spaces
   return result
 
 escape :: GenParser Char st String

 escape = liftM ('\\':) (try unicode) <|> char '\\' <:> many1 (noneOf "\r\n\f0123456789abcdef")

 
 nmstart :: GenParser Char st Char
 nmstart = oneOf "-" <|> letter
 
 nmchar :: GenParser Char st Char
 nmchar = oneOf "_-" <|> alphaNum
 
 
 space_ :: GenParser Char st Char
 space_ = oneOf " \t\r\n\f"
 
 s :: GenParser Char st String
 s = many1 space_
 
 w :: GenParser Char st String
 w = many space_
 
 nl :: GenParser Char st String

 nl = (string "\n" <|> try (string "\r\n") <|> string "\r" <|> string "\f") >> return "\n"

 
 genBadString :: Char -> GenParser Char st String
 genBadString c = do

   _ <- char c
   result <- liftM concat $
     many $ many1 (noneOf (c:"\n\r\f")) <|> (char '\\' >> nl) <|> escape
   _ <- char '\\'
   _ <- anyChar

   return result
 
 badstring :: GenParser Char st String
 badstring = genBadString '"' <|> genBadString '\''
 
 string_ :: GenParser Char st String
 string_ = do
   a <- char '"' <|> char '\''

   result <- liftM concat $ many $
     try (char '\\' <:> nl) <|> try escape <|> liftM (:[]) (noneOf (a:"\n\r\f"))
   _ <- char a

   return result
 
 -- badcomment, baduri, comment undefined
 
 -- tested
 ident :: GenParser Char st String
 ident = do
   head_ <- optionMaybe $ string "-"
   result <- nmstart
   tail_ <- many nmchar

   return $ fromMaybe "" head_ ++ (result:tail_)

 
 --tested
 name :: GenParser Char st String
 name = many1 nmchar
 
 -- tested
 num :: GenParser Char st String
 num = floating <|> many1 digit
   where
     floating = try $ do
       radix <- many digit
       mantissa <- char '.' <:> many1 digit
       return $ radix ++ mantissa
 
 cdo :: GenParser Char st String
 cdo = string "<!--"
 
 cdc :: GenParser Char st String
 cdc = string "-->"
 
 -- TODO: figger out if / should be here
 url :: GenParser Char st String

 url = liftM concat $ many $ many1 (oneOf "!#$%&*-~" <|> nonascii) <|> escape

 
 atEnd :: forall b s u (m :: * -> *) t. (Show t, NP.Stream s m t) => NP.ParsecT s u m b -> NP.ParsecT s u m b
 atEnd p = p >>= ((eof >>) . return)
 
 -- partially tested
 urlParse :: GenParser Char st URL
 urlParse = do

   result <- between (string "url(" >> spaces) (char ')') urlChars

   return $ URLFunc result

   where
     urlChars = withSpace $ string_ <|> many1 (oneOf "=?.,:/" <|> alphaNum) <|> url

 stylesheet :: GenParser Char st CSSDeclaration
 stylesheet = do -- TODO: allow the letters to be escaped in these strings
   chrset <- charset
   let cset  = case chrset of
               Nothing -> [];
               Just x -> [x]

   _ <- many $ s <|> cdo <|> cdc

   imports <- liftM concat $ many $ do
     imports <- many1 import_
     _ <- many ((cdo >> spaces) <|> (cdc >> spaces))
     return imports

 
   result <- many $ ruleset  <|> media <|> page

   _ <- many $ (cdo >> many s) <|> (cdc >> many s)

 
   return $ DeclarationList $ cset ++ imports ++ result
 
 page :: GenParser Char st CSSDeclaration
 page = do

   _ <- string "@page"

   spaces

   pseudo_ <- optionMaybe pseudoPage

 
   body <- rulebody
   return $ PageDeclaration pseudo_ $ fromList body
 

 pseudoPage :: GenParser Char st String
 pseudoPage = char ':' >> ident >>= (spaces >>) . return 

 
 
 charset :: GenParser Char st (Maybe CSSDeclaration)
 charset = optionMaybe $ do

   _ <- try $ string "@charset "

   result <- string_

   _ <- char ';'

   return $ Charset result
 
 medium :: GenParser Char st String
 medium = ident >>= (\q -> spaces >> return q)
 
 mediaList :: GenParser Char st [String]
 mediaList = sepBy medium (char ',' >> spaces)
 
 media :: GenParser Char st CSSDeclaration
 media =  do

   _ <- try $ string "@media"

   spaces
   query <- mediaList
   body <- between (char '{') (char '}') $ do
     spaces
     rules <- many ruleset
     spaces
     return rules
   return $ MediaQuery query $ DeclarationList body
 
 import_ :: GenParser Char st CSSDeclaration
 import_ = do

   _ <- try $ string "@import "

   spaces

   result <- liftM URLString string_ <|> urlParse

   spaces

   tail_ <- optionMaybe mediaList
   _ <- char ';'

   spaces
   return $ Import $ case tail_ of
     Nothing -> result
     Just x -> URLMedia x result
 
 
 
 cssRule :: GenParser Char st CSSSelector

 cssRule = liftM SelectorList (sepBy1 selector $ char ',' >> spaces)

 
 selector :: GenParser Char st CSSSelector
 selector = do
   result <- simpleSelector
   tail_ <- optionMaybe $ parseCombinator result <|> try (parseOCombinator result)
   spaces
   return $ fromMaybe result tail_
 
 -- This returns the value of a combinator, ignoring trailing spaces
 withSpace :: GenParser Char u b -> GenParser Char u b
 withSpace = (>>= ((spaces >>) . return))
 
 oneOfWithSpace :: String -> GenParser Char st Char
 oneOfWithSpace ss = foldr1 (<|>) parsers
   where
     parsers = map (withSpace . char) ss
 
 operator :: GenParser Char st Char
 operator = oneOfWithSpace "/,"
 
 combinator :: GenParser Char st Char
 combinator = oneOfWithSpace "+>"
 

 unaryOperator :: GenParser Char st Char
 unaryOperator = oneOf "-+"

 
 -- parse an optional combinator
 parseOCombinator :: CSSSelector -> GenParser Char st CSSSelector
 parseOCombinator head_ = do
   spaces

   combine <- optionMaybe combinator

   sel <- selector
   return $ case combine of
     Nothing -> Child head_ sel
     (Just x) -> case x of
       '+' -> Sibling head_ sel
       '>' -> DirectChild head_ sel

       _ -> undefined

 
 -- parse a combinator
 parseCombinator :: CSSSelector -> GenParser Char st CSSSelector
 parseCombinator head_ = do
   combine <- combinator
   sel <- selector
   return $ case combine of
     '+' -> Sibling head_ sel
     '>' -> DirectChild head_ sel

     _ -> undefined

 
 simpleSelector :: GenParser Char st CSSSelector
 simpleSelector = do
   result <- (try elementName <:> many modifier) <|> many1 modifier
   return $ if null $ tail result
     then head result
     else SelectorList result
 
 modifier :: GenParser Char st CSSSelector
 modifier = hash <|> class_ <|> attrib <|> pseudo
 
 elementName :: GenParser Char st CSSSelector
 elementName = liftM TagName $ ident <|> string "*"
 
 hash :: GenParser Char st CSSSelector
 hash = char '#' >> liftM Id ident
 
 class_ :: GenParser Char st CSSSelector
 class_ = char '.' >> liftM Class ident
 
 attrib :: GenParser Char st CSSSelector
 attrib = between (char '[') (char ']') $ do
   spaces
   key <- ident
   spaces

   value <- char '=' >> ident

   spaces
   return $ Attribute key value
 
 pseudo :: GenParser Char st CSSSelector
 pseudo = char ':' >> liftM Pseudo selectorIdent
   where
     selectorIdent = do
       init <- optionMaybe $ string ":"
       idnt <- ident

       return $ fromMaybe "" init ++ idnt

 
 
 {-# ANN (<++>) "HLint: ignore" #-}
 (<++>) :: Monad m => m [a] -> m [a] -> m [a]
 a <++> b = liftM2 (++) a b
 
 (<:>) :: Monad m => m a -> m [a] -> m [a]
 a <:> b = liftM2 (:) a b
 
 
 ruleset :: GenParser Char st CSSDeclaration
 ruleset = do
   selector_ <- cssRule
   spaces
   result <- rulebody
   return $ CSSDeclaration selector_ $ fromList result
   
 rulebody :: GenParser Char st [(String, String)]
 rulebody = between (withSpace $ char '{') (withSpace $ char '}') $ do
     head_ <- declaration
     tail_ <- many $ do

       char ';' >> spaces

       optionMaybe declaration

     _ <- spaces
     return (head_:catMaybes tail_)

 
 declaration :: GenParser Char st (String,String)
 declaration = do
   prop <- property

   value <- withSpace (char ':') >> expr

   optional prio
   return (prop,value)
 
 prio :: GenParser Char st String
 prio = char '!' >> spaces >> string "important"
 
 -- TODO: Still need to implement comments . . . 
 
 expr :: GenParser Char st String
 expr = do
   fst <- term
   rst <- many $ do
     op <- optionMaybe $ liftM (:[]) operator
     trm <- term
     return $ case op of
       Nothing -> trm
       Just x -> x ++ (' ':trm)
   return $ fst ++ foldr (\x y -> (' ':x++(' ':y))) [] rst
 
 term :: GenParser Char st String

 term = withSpace numerical <|> withSpace uri <|> withSpace string_ <|> withSpace ident <|> hexcolor <|> function

 
 numerical :: GenParser Char st String
 numerical = do

   unop <- optionMaybe unaryOperator

   value <- withSpace (try percentage) <|> withSpace (try length) <|> withSpace (try ems) <|> withSpace (try exs)
            <|> withSpace (try angle) <|> withSpace (try time) <|> withSpace (try freq) <|> withSpace number 
   return $ case unop of
     Just '-' -> '-':value
     _ -> value
   where
     number  :: GenParser Char st String
     number = num
 
     percentage :: GenParser Char st String
     percentage = num <++> string "%"
 
     length :: GenParser Char st String

     length = num <++> foldr1 (<|>) (map string ["px", "cm", "mm", "in", "pt", "pc", "rem", "vw", "vh"])

 
     ems  :: GenParser Char st String
     ems = num <++> string "em"
 
     exs  :: GenParser Char st String
     exs = num <++> string "ex"
 
     angle  :: GenParser Char st String
     angle = num <++> (string "deg" <|> string "rad" <|> string "grad")
 
     time  :: GenParser Char st String
     time = num <++> (string "ms" <|> string "s")
 
     freq  :: GenParser Char st String
     freq = num <++> (string "hz" <|> string "khz")
       
 
 function :: GenParser Char st String
 function = do
   _ <- ident
   _ <- string "("
   spaces
   d <- expr
   _ <- string ")"
   spaces

   return d

 
 hexcolor :: GenParser Char st String
 hexcolor = char '#' <:> many1 hexDigit
   
 uri :: GenParser Char st String
 uri = do
   a <- string "url("

   result <- w >> (try string_ <|> url)
   d <- w >> string ")"

   return $ a ++ result ++ d
 
 
 property :: GenParser Char st String
 property = do
   result <- ident
   spaces
   return result
 
 parseCSS :: String -> Either ParseError CSSDeclaration
 parseCSS = parse stylesheet  "(unknown)"