{-# LANGUAGE OverloadedStrings #-}
module Main where

import System.Environment
import Data.Char (isSpace)

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,
        words, unwords, head, last, stripStart, stripEnd, intercalate)

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.CSS.Preprocessor.Conditions as CSSCond
import qualified Data.HTML2CSS as H2C

import qualified Data.List as L
import qualified Data.Map as M
import Data.Scientific (toRealFloat)
import Data.Maybe (fromJust, fromMaybe)
import System.Directory as Dir

import DefaultCSS
import StyleTree
import SSML

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
    let aboutBlank = fromJust $ parseURI "about:blank"
    style <- retreiveStyles (fromMaybe aboutBlank $ parseURI url) html manager $ fromJust $ parseURI url
    let transcript = stylize style html
    C8.putStrLn $ renderElLBS $ styleToSSML $ applyCounters transcript

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

retreiveStyles uri html manager base = do
    style <- H2C.externalStylesForURL authorStyle testMedia html base loadURL
    userStyle <- loadUserStyles style
    importedStyle <- CSSCond.loadImports loadURL lowerVars lowerToks userStyle []
    return $ CSSCond.resolve lowerVars lowerToks Style.queryableStyleSheet importedStyle
  where
    emptyStyle :: CSSCond.ConditionalStyles StyleTree
    emptyStyle = CSSCond.conditionalStyles uri "document"
    agentStyle = H2C.cssPriorityAgent emptyStyle `CSS.parse` Txt.pack userAgentCSS
    authorStyle = H2C.internalStylesForURL testMedia agentStyle base html

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

    lowerVars "speech" = CSSCond.B True
    lowerVars "-rhapsode" = CSSCond.B True
    lowerVars _ = CSSCond.B False
    lowerToks _ = CSSCond.B False

loadUserStyles styles = do
    dir <- Dir.getXdgDirectory Dir.XdgConfig "rhapsode"
    exists <- Dir.doesDirectoryExist dir
    loadDirectory dir exists
  where
    loadDirectory _ False = return styles
    loadDirectory dir True = do
        files <- Dir.listDirectory dir
        loadFiles (H2C.cssPriorityUser styles) files
    loadFiles style (file:files) = do
        source <- readFile file
        CSS.parse style (Txt.pack source) `loadFiles` files
    loadFiles style [] = return style

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


stylize styles html = H2C.traversePrepopulatedStyles buildChild buildNode buildText styles html
    where
        buildChild (Style.VarParser _ self) _ | content self == [] = Nothing
            | otherwise = Just [Style.temp {content = content self}]
        buildNode (Style.VarParser _ self) children = self {children = children}
        buildText _ txt = Style.temp {content = [Content txt]}

--------
---- Counters
--------
treeOrder :: (c -> c -> [Integer] -> StyleTree -> (c, StyleTree)) ->
        c -> c -> [Integer] -> [StyleTree] -> (c, [StyleTree])
treeOrder cb prevContext context (num:path) (node:nodes) = (tailContext, node' {children = children'} : nodes')
    where
        (selfContext, node') = cb prevContext context (num:path) node
        (childContext, children') = treeOrder cb selfContext selfContext (0:num:path) $ children node
        (tailContext, nodes') = treeOrder cb selfContext childContext (num + 1:path) nodes
treeOrder _ _ context _ [] = (context, [])
treeOrder _ _ _ [] _ = error "Invalid path during tree traversal!"

inheritCounters path counterSource valueSource = M.intersectionWith cb valueSource counterSource -- indexed by name & el-path
    where cb val source = [counter | path `elem` [p | (p, _) <- source], counter@(path, _) <- val]
instantiateCounter counters path name val = M.insertWith appendCounter name [(path, val)] counters
    where
        appendCounter new (old@((_:oldPath), _):olds)
            | oldPath == tail path = new ++ olds
            | otherwise =  new ++ (old:olds)
instantiateCounters path instruct counters = foldl cb counters instruct
    where cb counters' (name, value) = instantiateCounter counters' path name value
incrementCounter counters path name val = M.insertWith addCounter name [(path, val)] counters
    where addCounter ((_, new):_) ((path, old):rest) = (path, new + old):rest
incrementCounters path instruct counters = foldl cb counters instruct
    where cb counters' (name, value) = incrementCounter counters' path name value
setCounter counters path name val = M.insertWith setCounter' name [(path, val)] counters
    where setCounter' ((_, val):_) ((path, _):rest) = (path, val):rest
setCounters path instruct counters = foldl cb counters instruct
    where cb counters' (name, value) = setCounter counters' path name value

renderCounter counters (Content txt) = Content txt
renderCounter counters (Counter name)
    | Just ((_, count):_) <- name `M.lookup` counters = Content $ Txt.pack $ show count
    | otherwise = Content ""
renderCounter counters (Counters name sep)
    | Just counter <- name `M.lookup` counters = Content $ Txt.intercalate sep [
            Txt.pack $ show count | (_, count) <- reverse counter
        ]
    | otherwise = Content ""
renderCounters node counters = (counters, node {
        content = map (renderCounter counters) $ content node,
        counterSet = [(name, value) | (name, ((_, value):_)) <- M.toList counters]
    })

applyCounters root = root {
        children = snd $ treeOrder cb M.empty M.empty [0] $ children root
    } where
        cb :: M.Map Text [([Integer], Integer)] -> M.Map Text [([Integer], Integer)] ->
            [Integer] -> StyleTree -> (M.Map Text [([Integer], Integer)], StyleTree)
        cb counterSource valueSource path node = renderCounters node $
            setCounters path (counterSet node) $
            incrementCounters path (counterIncrement node) $
            instantiateCounters path (counterReset node) $
            inheritCounters path counterSource valueSource