{-# LANGUAGE OverloadedStrings #-}
-- | Bindings from `xml-conduit` to `haskell-stylist`.
module Data.HTML2CSS(
        html2css, cssPriorityAgent, cssPriorityUser, cssPriorityAuthor, -- parsing
        el2stylist, stylize' -- application
    ) where

import qualified Data.List as L
import qualified Data.Map as M
import qualified Data.HashMap.Strict as HM
import qualified Data.Text as Txt
import Data.Maybe (fromMaybe, listToMaybe)

import qualified Text.XML as XML
import Data.CSS.Syntax.StyleSheet
import Data.CSS.Style
import Data.CSS.StyleTree
import Data.CSS.Syntax.Tokens
import Data.CSS.Preprocessor.Conditions
import qualified Data.CSS.Preprocessor.Conditions.Expr as Query
import Network.URI

---- Constants
-- | Set the priority for a CSS stylesheet being parsed.
cssPriorityAgent, cssPriorityUser, cssPriorityAuthor :: StyleSheet s => s -> s
cssPriorityAgent = setPriority 1
cssPriorityUser = setPriority 2
cssPriorityAuthor = setPriority 3

---- Parsing
-- | Converts a parsed XML or HTML file to a `ConditionalStyles` `StyleSheet`.
html2css :: PropertyParser p => XML.Document -> URI -> ConditionalStyles p
html2css xml url = testIsStyled $ ConditionalStyles {
    hostURL = url,
    mediaDocument = "document",
    isUnstyled = False,
    rules = Priority 3 : html2css' (XML.documentRoot xml) (conditionalStyles url "document"),
    propertyParser = temp
}

html2css' :: PropertyParser p => XML.Element -> ConditionalStyles p -> [ConditionalRule p]
html2css' (XML.Element (XML.Name "style" _ _) attrs children) base =
    [Internal (parseMediaQuery attrs) (parseForURL base (hostURL base) $ strContent children)]
html2css' (XML.Element (XML.Name "link" _ _) attrs _) base
    | Just link <- "href" `M.lookup` attrs,
        Just "stylesheet" <- "rel" `M.lookup` attrs,
        Just uri <- parseURIReference $ Txt.unpack link =
            [External (parseMediaQuery attrs) (relativeTo uri $ hostURL base)]
html2css' (XML.Element _ _ children) base = concat [html2css' el base | XML.NodeElement el <- children]

parseMediaQuery :: M.Map XML.Name Txt.Text -> Query.Expr
parseMediaQuery attrs
    | Just text <- "media" `M.lookup` attrs = Query.parse' (tokenize text) []
    | otherwise = []


strContent :: [XML.Node] -> Txt.Text
strContent (XML.NodeContent text : rest) = text `Txt.append` strContent rest
-- We do want to read in comments for CSS, just not for display.
strContent (XML.NodeComment text : rest) = text `Txt.append` strContent rest
strContent (XML.NodeElement (XML.Element _ _ children):rest) =
    strContent children `Txt.append` strContent rest
strContent (_:rest) = strContent rest
strContent [] = ""

---- Styling

el2stylist el = nodes2stylist [XML.NodeElement el] Nothing Nothing
nodes2stylist (XML.NodeElement (XML.Element (XML.Name name ns _) attrs childs):nodes) parent previous =
    let el = ElementNode {
        name = name,
        namespace = fromMaybe "" ns,
        attributes = L.sort [
            Attribute name (fromMaybe "" ns) (Txt.unpack value)
            | (XML.Name name ns _, value) <- M.toList attrs
        ],
        parent = parent,
        previous = previous
    } in StyleTree {
        style = el,
        children = nodes2stylist childs (Just el) Nothing
    } : nodes2stylist nodes parent previous
nodes2stylist (XML.NodeContent txt:nodes) parent previous = StyleTree {
        style = ElementNode {
            name = "", namespace = "",
            attributes = [Attribute "style" "" $ Txt.unpack $
                Txt.append "content: " $ serialize [String txt]],
            parent = parent, previous = previous
        },
        children = []
    } : nodes2stylist nodes parent previous
nodes2stylist (_:nodes) parent previous = nodes2stylist nodes parent previous
nodes2stylist [] _ _ = []

stylize' parent stylesheet (StyleTree el childs) = StyleTree {
        style = cascade' (HM.lookupDefault [] "" rules) overrides parent,
        children = traversePseudo "before" ++
            map (stylize' parent stylesheet) childs ++
            traversePseudo "after"
    }
  where
    rules = queryRules stylesheet el
    overrides = concat [ fst $ parseProperties' $ tokenize $ Txt.pack val
        | Attribute "style" _ val <- attributes el ]
    traversePseudo pclass
        | Just rules' <- pclass `HM.lookup` rules = [StyleTree (cascade' rules' [] parent) []]
        | otherwise = []