HandsomeSoup-0.1: Text/CSS/Parser.hs

module Text.CSS.Parser where

import Text.Parsec
import qualified Data.Functor.Identity as I
import Data.List
import Text.CSS.Utils

-- if no tag name was given, sName will be set to '*'
-- attrs are (attr name, attr value).
-- if attr value is the empty string, we just check to
-- make sure that the element has that attribute.
-- if the attr value is prefixed with a '~', we treat
-- that attribute as a list of words separated by a space
-- and make sure that at least one of those words matches.
data Selector = Selector { sName :: String, sAttrs :: [(String,String)], spseudoSelectores :: [String] } | Space | ChildOf | FollowedBy deriving (Show)

-- pretty printers for debugging
pp Space = "<space>"
pp ChildOf = "<child of>"
pp FollowedBy = "<followed by>"
pp (Selector name attrs pseudo) = show name ++ ":" ++ showMap attrs ++ ", " ++ show pseudo
    where showMap m = ("{" ++ (foldl (\acc (k,v) -> acc ++ (show k) ++ ":" ++ (show v) ++ ", ") "" m)) ++ "}"

{- TYPE SELECTORS FOLLOW -}

-- | selects a tag name, like @ h1 @
typeSelector :: ParsecT [Char] u I.Identity [Char]
typeSelector = many1 alphaNum

-- | universal selector, selects @ * @
universalSelector :: ParsecT [Char] u I.Identity String
universalSelector = string "*"

{- SECONDARY SELECTORS FOLLOW -}

-- | selects a pseudo-element or pseudo-class, like @ :link @, @ :first-child @ etc.
pseudoSelector :: ParsecT [Char] u I.Identity [Char]
pseudoSelector = char ':' >> many1 (alphaNum <|> oneOf "-()")

-- | class selector, selects @ .foo @
classSelector :: ParsecT [Char] u I.Identity ([Char], [Char])
classSelector = do
    val <- char '.' >> many1 alphaNum
    return ("class", '~':val)

-- | id selector, selects @ #foo @
idSelector :: ParsecT [Char] u I.Identity ([Char], [Char])
idSelector = do
    val <- char '#' >> many1 alphaNum
    return ("id", val)

-- | selects attributes, like @ [id] @ (element must have id) or @ [id=foo] @ (element must have id foo).
attributeSelector :: ParsecT [Char] u I.Identity ([Char], [Char])
attributeSelector = do
      contents <- between (char '[') (char ']') (many1 (alphaNum <|> oneOf "~="))
      if "~=" `isInfixOf` contents 
          then return $ (\(a, b) -> (a, '~':b)) $ splitOn "~=" contents
          else if '=' `elem` contents
               then return $ splitOn "=" contents
               else return (contents, "")

-- | selector for everything after the type except pseudoSelectores
secondarySelector = many1 (classSelector <|> idSelector <|> attributeSelector)

{- COMBINATOR SELECTORS FOLLOW -}

space_ = do
    many1 $ string " "
    return Space

childOf = do
    spaces >> string ">" >> spaces
    return ChildOf

followedBy = do
    spaces >> string "+" >> spaces
    return FollowedBy

{- SIMPLE SELECTORS FOLLOW -}

-- | selects a tagname followed by one or more secondary selectors
-- example: @ a.foo @, @ *#hello @, @ h1 @ etc
simpleSelectorTag :: ParsecT [Char] u I.Identity Selector
simpleSelectorTag = do
    tagName <- typeSelector <|> universalSelector
    attrs <- secondarySelector <|> return []
    pseudo <- many1 pseudoSelector <|> return []
    return $ Selector tagName attrs pseudo

-- | selects one or more secondary selectors
-- and automatically prepends the universal selector to them.
-- example: @ .foo @, @ #hello @ etc
simpleSelectorNoTag = do
    attrs <- secondarySelector
    pseudo <- many1 pseudoSelector <|> return []
    return $ Selector "*" attrs pseudo

-- | A simple selector is either a type selector or universal selector followed immediately by zero or more attribute selectors, ID selectors, or pseudo-classes, in any order.
simpleSelector :: ParsecT [Char] u I.Identity Selector
simpleSelector = simpleSelectorTag <|> simpleSelectorNoTag <|> try childOf <|> try followedBy <|> space_

-- | One or more simple selectors separated by combinators. 
selector :: ParsecT [Char] u I.Identity [[Selector]]
selector = many1 simpleSelector `sepBy` (spaces >> string "," >> spaces)

css = parse selector ""