{-# LANGUAGE OverloadedStrings #-}
module Main where

import System.Environment

import qualified Network.HTTP.Client as HTTP
import           Network.HTTP.Client.Internal
import qualified Network.HTTP.Client.TLS as TLS
import           Network.URI
import qualified Data.ByteString.Lazy.Char8 as C8

import qualified Text.HTML.DOM as HTML
import qualified Text.XML as XML
import           Data.Text as Txt (pack, unpack, Text(..), append)

import qualified Data.CSS.Syntax.StyleSheet as CSS
import qualified Data.CSS.Style as Style
import qualified Data.CSS.Syntax.Tokens as CSSTok
import qualified Data.HTML2CSS as H2C

import qualified Data.List as L
import qualified Data.Map as M

import DefaultCSS

main :: IO ()
main = do
    url:_ <- getArgs
    -- TODO support more URI schemes, and do nonblocking networking. This could be it's own module.
    request <- HTTP.parseRequest url
    manager <- HTTP.newManager TLS.tlsManagerSettings
    response <- HTTP.httpLbs request manager
    let html = XML.documentRoot $ HTML.parseLBS $ HTTP.responseBody response
    style <- retreiveStyles html manager request
    C8.putStrLn $ renderElLBS $ stylizeEl style html

renderElLBS el = XML.renderLBS XML.def $ XML.Document {
        XML.documentPrologue = XML.Prologue [] Nothing [],
        XML.documentRoot = el,
        XML.documentEpilogue = []
    }

retreiveStyles html manager base = do
    style <- H2C.externalStyles authorStyle testMedia html loadURL
    return agentStyle -- FIXME Stylish Haskell freezes when I parse more.
  where
    emptyStyle :: Style.QueryableStyleSheet MapPropertyParser
    emptyStyle = Style.queryableStyleSheet
    agentStyle = H2C.cssPriorityAgent emptyStyle `CSS.parse` Txt.pack userAgentCSS
    authorStyle = H2C.internalStyles testMedia (H2C.cssPriorityAuthor agentStyle) html

    loadURL url = do -- TODO parallelise.
        request <- setUriRelative base url
        response <- HTTP.httpLbs request manager
        return $ Txt.pack $ C8.unpack $ HTTP.responseBody response

testMedia attrs = media == Nothing || media == Just "speech"
    where media = "media" `M.lookup` attrs


stylizeEl styles html
        | XML.NodeElement el <- H2C.traverseStyles buildEl buildText styles html = el
        |otherwise = XML.Element name M.empty []
    where
        buildEl (MPP attrs) children = XML.NodeElement $ XML.Element name attrs children
        buildText _ txt = XML.NodeContent txt
        name = XML.Name "style" Nothing Nothing

data MapPropertyParser = MPP (M.Map XML.Name Text)
instance Style.PropertyParser MapPropertyParser where
    temp = MPP M.empty
    longhand _ (MPP self) name value = Just $ MPP $ M.insert xmlName xmlValue self
        where
            xmlName = XML.Name name Nothing Nothing
            xmlValue = CSSTok.serialize value