{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module Render(retreiveStyles, renderDoc, c_renderDoc) where

import qualified Data.ByteString.Lazy as B
import qualified Text.XML as XML
import           Data.Text as Txt (pack, unpack, Text(..), intercalate)

import qualified Data.Map as M
import System.Directory as Dir
import Data.FileEmbed

--- External Rhapsode subcomponents
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           Network.URI
import           Network.URI.Fetch
import           Network.URI.Charset

--- For CSS assets
import           Data.List (nub, elem)
import           Control.Concurrent.Async (forConcurrently)
import           System.IO.Temp
import           Control.Exception (catch)

-- Internal Rhapsode Subcomponents
import StyleTree
import SSML

-- C API
import Types
import Foreign.StablePtr
import Foreign.C.String
import Data.ByteString (useAsCString)

renderDoc :: Style.QueryableStyleSheet (Style.VarParser StyleTree) -> XML.Element -> B.ByteString
renderDoc style html =
    renderElLBS $ styleToSSML $ applyCounters $ stylize style html

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

retreiveStyles :: Session -> CSSCond.ConditionalStyles StyleTree -> IO (CSSCond.ConditionalStyles StyleTree)
retreiveStyles manager authorStyle = do
    let agentStyle = H2C.cssPriorityAgent authorStyle `CSS.parse` $(embedStringFile "useragent.css")
    userStyle <- loadUserStyles agentStyle
    CSSCond.loadImports loadURL lowerVars lowerToks userStyle []
  where
    loadURL url = do
        response <- fetchURL manager ["text/css"] url
        let charsets' = map unpack charsets
        return $ case response of
            ("text/css", Left text) -> text
            ("text/css", Right bytes) -> applyCSScharset charsets' $ B.toStrict bytes
            (_, _) -> ""

resolve' :: CSS.StyleSheet s => s -> CSSCond.ConditionalStyles StyleTree -> s
resolve' = CSSCond.resolve lowerVars lowerToks
lowerVars "speech" = CSSCond.B True
lowerVars "-rhapsode" = CSSCond.B True
lowerVars _ = CSSCond.B False
lowerToks _ = CSSCond.B False

applyCSScharset (charset:charsets) bytes
        | cssCharset (CSSTok.tokenize text) == Txt.pack charset = text
        | otherwise = applyCSScharset charsets bytes
    where
        text = convertCharset charset bytes
applyCSScharset _ bytes = convertCharset "utf-8" bytes
cssCharset toks | (CSSTok.AtKeyword "charset":toks') <- skipCSSspace toks,
        (CSSTok.String charset:_) <- skipCSSspace toks' = charset
    | otherwise = ""
skipCSSspace (CSSTok.Whitespace:toks) = skipCSSspace toks
skipCSSspace toks = toks

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


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]}

--------
---- Download assets
--------
-- TODO upstream into Haskell Stylist, or a new HURL Stylist hackage.

data StyleAssets = StyleAssets {
    filterProps :: [Txt.Text],
    assets :: [URI]
}

instance CSS.StyleSheet StyleAssets where
    addRule (StyleAssets filterProps self) (CSS.StyleRule _ props _) =
        StyleAssets filterProps $ nub (
            self ++ [uri | (prop, val) <- props,
                    prop `elem` filterProps,
                    CSSTok.Url text <- val,
                    Just uri <- [parseAbsoluteURI $ Txt.unpack text]]
            )

downloadAssets session mimes (StyleAssets _ assets) = do
    dir <- Dir.getXdgDirectory Dir.XdgCache "rhapsode"
    Dir.removeDirectoryRecursive dir `catch` ignoreError -- Clear cache.
    Dir.createDirectoryIfMissing True dir

    fetchURLs session mimes assets $ filterMIMEs mimes $ saveDownload nullURI dir
  where
    ignoreError :: IOError -> IO ()
    ignoreError _ = return ()

filterMIMEs mimes cb download@(_, mime, _)
    | mime `elem` mimes = cb download
    | otherwise = return nullURI

rewritePropertyVal rewrites (CSSTok.Url text:vals)
    | Just uri <- parseURIReference $ Txt.unpack text, Just rewrite <- uri `M.lookup` rewrites =
        CSSTok.Url (Txt.pack $ uriToString id rewrite "") : rewritePropertyVal rewrites vals
    | otherwise = CSSTok.Url "" : rewritePropertyVal rewrites vals
rewritePropertyVal rewrites (val:vals) = val:rewritePropertyVal rewrites vals
rewritePropertyVal _ [] = []

data URIRewriter s = URIRewriter (M.Map URI URI) s
instance CSS.StyleSheet s => CSS.StyleSheet (URIRewriter s) where
    setPriority p (URIRewriter r s) = URIRewriter r $ CSS.setPriority p s
    addRule (URIRewriter r s) (CSS.StyleRule sel props psuedo) =
        URIRewriter r $ CSS.addRule s $ CSS.StyleRule sel [
            (prop, rewritePropertyVal r val) | (prop, val) <- props
        ] psuedo
    addAtRule (URIRewriter r s) name toks =
        let (self', toks') = CSS.addAtRule s name toks in (URIRewriter r s, toks)

--------
---- 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
--------
---- C API
--------
foreign export ccall c_renderDoc :: StablePtr Session -> StablePtr Page -> Bool -> IO CString -- Hard to C bindings without IO

c_renderDoc c_session c_page rewriteURLs = do
    session <- deRefStablePtr c_session
    page <- deRefStablePtr c_page
    css' <- retreiveStyles session $ css page
    qCSS <- if rewriteURLs then do
        assets <- downloadAssets session [
                "audio/vnd.wav"
            ] $ resolve' (StyleAssets ["cue-before", "cue-after", "cue"] []) css'
        let URIRewriter _ qCSS' =  resolve' (URIRewriter (M.fromList assets) Style.queryableStyleSheet) css'
        return qCSS'
        else return $ resolve' Style.queryableStyleSheet css'
    let ssml = renderDoc qCSS $ XML.documentRoot $ html page
    B.toStrict ssml `useAsCString` \cstr -> do
        str <- peekCString cstr
        newCString str