{-# 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

import Data.Maybe (fromMaybe, maybeToList)
import Debug.Trace (trace)

--- External Rhapsode subcomponents
import qualified Data.CSS.Syntax.StyleSheet as CSS
import qualified Data.CSS.Style as Style
import           Data.CSS.StyleTree
import qualified Data.CSS.Syntax.Tokens as CSSTok
import qualified Data.CSS.Preprocessor.Conditions as CSSCond
import           Data.CSS.Preprocessor.Assets
import qualified Data.CSS.Preprocessor.PsuedoClasses as CSSPseudo
import qualified Data.CSS.Preprocessor.Text as CSSTxt

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 SpeechStyle
import SSML

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

renderDoc :: Style.QueryableStyleSheet (Style.VarParser (CSSTxt.TextStyle SpeechStyle)) -> XML.Element -> B.ByteString
renderDoc style html =
    renderElLBS $ styleToSSML $ CSSTxt.resolve $ inlinePseudos $ H2C.stylizeEl style html

inlinePseudos :: Style.PropertyParser s => StyleTree [(Text, Style.VarParser s)] -> StyleTree s
inlinePseudos (StyleTree self childs) = StyleTree {
        style = fromMaybe Style.temp $ Style.innerParser <$> lookup "" self,
        children = pseudo "before" ++ map inlinePseudos childs ++ pseudo "after"
    } where
        pseudo n
            | Just style <- Style.innerParser <$> lookup n self,
                Just style' <- Style.longhand style style "::" [CSSTok.Ident n] = [StyleTree style' []]
            | Just style <- Style.innerParser <$> lookup n self = [StyleTree style []]
            | otherwise = []

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

retreiveStyles :: Session -> CSSCond.ConditionalStyles (CSSTxt.TextStyle SpeechStyle) -> IO (CSSCond.ConditionalStyles (CSSTxt.TextStyle SpeechStyle))
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 (CSSTxt.TextStyle SpeechStyle) -> 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

targetSel "" = [CSSTok.Ident "main"]
targetSel ('#':id) = [CSSTok.Hash CSSTok.HUnrestricted $ Txt.pack id]
targetSel _ = []

rhapsodePseudoFilter url = CSSPseudo.addRewrite "link" "[src], [href]" $
    CSSPseudo.addRewrite' "target" (targetSel $ uriFragment url) $
    CSSPseudo.htmlPsuedoFilter Style.queryableStyleSheet

--------
---- Download assets
--------
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
--------
---- 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
    let pseudoFilter = rhapsodePseudoFilter $ url 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 assets pseudoFilter) css'
        return $ CSSPseudo.inner qCSS'
        else return $ CSSPseudo.inner $ resolve' pseudoFilter css'
    let ssml = renderDoc qCSS $ XML.documentRoot $ html page
    B.toStrict ssml `useAsCString` \cstr -> do
        str <- peekCString cstr
        newCString str