{-# LANGUAGE OverloadedStrings #-}
-- | Bindings from `xml-conduit` to `haskell-stylist`.
module Data.HTML2CSS(
        html2css, cssPriorityAgent, cssPriorityUser, cssPriorityAuthor, -- parsing
        preorder, el2styletree, els2stylist, el2stylist, stylize, stylize', stylizeEl -- 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

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

preorder :: (Maybe b -> Maybe b -> a -> b) -> StyleTree a -> StyleTree b
preorder cb self = head $ preorder' cb Nothing Nothing [self]
preorder' :: (Maybe b -> Maybe b -> a -> b) ->
        Maybe b -> Maybe b -> [StyleTree a] -> [StyleTree b]
preorder' cb parent previous (self:sibs) = let self' = cb parent previous $ style self
        in StyleTree self' (preorder' cb (Just self') Nothing $ children self) :
            preorder' cb parent (Just self') sibs
preorder' _ _ _ [] = []

el2styletree el = StyleTree (Left el) $ mapMaybe node2styletree $ XML.elementNodes el
node2styletree (XML.NodeElement el) = Just $ el2styletree el
node2styletree (XML.NodeContent txt) = Just $ StyleTree (Right [("content", [String txt])]) []
node2styletree _ = Nothing

previous' (Just ElementNode {name = "", previous = prev'}) = previous' prev'
previous' prev' = prev'

els2stylist = preorder els2stylist'
els2stylist' parent previous (Left (XML.Element (XML.Name name ns _) attrs _)) =
    ElementNode {
        name = name, namespace = fromMaybe "" ns,
        attributes = L.sort [
            Attribute n (fromMaybe "" ns) $ Txt.unpack v | (XML.Name n ns _, v) <- M.toList attrs
        ],
        parent = parent, previous = previous' previous
    }
els2stylist' parent previous (Right attrs) = ElementNode {
        name = "", namespace = "",
        attributes = [Attribute "style" "" $ Txt.unpack $ Txt.concat style],
        parent = parent, previous = previous' previous
    } where style = concat [[prop, ": ", serialize v, "; "] | (prop, v) <- attrs]

el2stylist = els2stylist . el2styletree

stylize :: PropertyParser s => QueryableStyleSheet s -> StyleTree Element -> StyleTree [(Txt.Text, s)]
stylize = preorder . stylize'
stylize' :: PropertyParser s => QueryableStyleSheet s -> Maybe [(Txt.Text, s)] -> Maybe [(Txt.Text, s)] ->
        Element -> [(Txt.Text, s)]
stylize' stylesheet parent _ el = ("", base) : [
        (k, cascade' v [] base) | (k, v) <- HM.toList $ queryRules stylesheet el
    ] where
        base = cascade stylesheet el overrides $ fromMaybe temp $ lookup "" =<< parent
        overrides = concat [fst $ parseProperties' $ tokenize $ Txt.pack val
            | Attribute "style" _ val <- attributes el]
stylizeEl stylesheet = stylize stylesheet . el2stylist