{-# LANGUAGE OverloadedStrings #-}
module SSML(styleToSSML) where
import Text.XML
import qualified Data.Text as Txt
import Data.Map
import qualified Data.Map as M
import Data.CSS.Syntax.Tokens (tokenize, Token(Dimension))

import Data.Char (isSpace)
import Data.Maybe (fromJust)
import Data.List (elemIndex)

import StyleTree

--------
---- Basic conversion
--------
styleToSSML' StyleTree {speak = False} =
    Element (Name "blank" Nothing Nothing) empty []
styleToSSML' self =  buildEl0 "prosody" [
            ("volume", volume self),
            ("rate", rate self),
            ("pitch", serializePitch $ pitch self),
            ("range", serializePitch $ range self)
        ] $ buildEl0 "prosody" [
            ("volume", maybeAdjust $ volumeAdjust self),
            ("rate", maybeAdjust $ rateAdjust self),
            ("pitch", maybeAdjust $ pitchAdjust $ pitch self),
            ("range", maybeAdjust $ pitchAdjust $ range self)
        ] $ buildEl0 "emphasis" [("level", stress self)] $
        buildEl0 "say-as" [("interpret-as", speakAs self)] $
        buildEl0 "tts:style" [
            ("field", maybeBool (punctuation self) "punctuation" "punctuation"),
            ("mode", maybeBool (punctuation self) "all" "none")
        ] $ buildVoices (voice self) $ buildBox self

serializePitch Inherit = Nothing
serializePitch (Pitch kw _) = Just kw
serializePitch (Absolute "khz" n) = serializePitch $ Absolute "hz" (1000 * n)
serializePitch (Absolute _ n) | n < 0 = Nothing
    | otherwise = Just $ Txt.pack (show n ++ "hz")
serializePitch (Relative unit n) = Just $ relativeUnit unit n

relativeUnit "khz" n = relativeUnit "hz" $ 1000 * n
relativeUnit unit n | n < 0 = Txt.pack (show n) `Txt.append` unit
    | otherwise = Txt.pack ('+':show n) `Txt.append` unit

maybeBool (Just True) truthy _ = Just truthy
maybeBool (Just False) _ falsy = Just falsy
maybeBool Nothing _ _ = Nothing

maybeCast (Just n) = Just $ Txt.pack $ show n
maybeCast Nothing = Nothing

maybeAdjust (Just (Unit' unit n)) = Just $ relativeUnit unit n
maybeAdjust Nothing = Nothing

buildVoice (Voice name) children = buildEl "voice" [("name", Just name)] children
buildVoice (VoicePattern age gender variant) children = buildEl "voice" [
        ("age", maybeCast age),
        ("gender", Just gender),
        ("variant", maybeCast variant)
    ] children

buildVoices Nothing = buildEl "blank" []
buildVoices (Just voice) = buildVoice voice

--------
---- CSS Speech Box Model
--------
buildBox self = [
        buildBreak $ pauseBefore self,
        buildCue $ cueBefore self,
        buildBreak $ restBefore self
    ] ++ Prelude.map (NodeContent . value) (content self)
    ++ Prelude.map (NodeElement . styleToSSML') (children self) ++ [
        buildBreak $ restAfter self,
        buildCue $ cueAfter self,
        buildBreak $ pauseAfter self
    ]

buildBreak self = NodeElement $ buildEl "break" [
        ("strength", strength self),
        ("time", time self)
    ] []
buildCue NoCue = NodeElement $ buildEl "blank" [] []
buildCue self = NodeElement $
    buildEl0 "prosody" [("volume", maybeAdjust $ cueVolume self)] $
    buildEl "audio" [("src", Just $ src self)] []

volumes = ["x-weak", "weak", "medium", "strong", "x-strong"]
maxBreak x@(Element _ a _) y@(Element _ b _)
    | Just a' <- "strength" `M.lookup` a, Just b' <- "strength" `M.lookup` b, a' /= b' =
        if fromJust (elemIndex a' volumes) > fromJust (elemIndex b' volumes) then x else y
    | Just a' <- "time" `M.lookup` a, Just b' <- "time" `M.lookup` b, a' /= b' =
        if toMS (tokenize a') > toMS (tokenize b') then x else y
    | otherwise = x
toMS [Dimension _ n "s"] = cssFloat n * 1000
toMS [Dimension _ n "ms"] = cssFloat n
toMS _ = 0 -- Should never happen.

--------
---- XML Output Utils
--------
buildEl name attrs elChildren =
    Element (Name name Nothing Nothing) (attrsFromList attrs) elChildren
buildEl0 name attrs child = buildEl name attrs [NodeElement child]

attrsFromList ((name, Just value):attrs) =
    insert (Name name Nothing Nothing) value $ attrsFromList attrs
attrsFromList ((_, Nothing):attrs) = attrsFromList attrs
attrsFromList [] = empty

--------
---- Tidyup
--------
stripEmptyEls (Element name attrs elChildren) =
    Element name attrs $ stripEmptyNodes elChildren
stripEmptyNodes (NodeElement el@(Element _ attrs elChildren ):nodes)
    | M.null attrs = stripEmptyNodes (elChildren ++ nodes)
    | otherwise = NodeElement (stripEmptyEls el) : stripEmptyNodes nodes
stripEmptyNodes (NodeContent a : NodeContent b : nodes) =
    stripEmptyNodes (NodeContent (Txt.append a b) : nodes)
stripEmptyNodes (NodeContent txt : nodes) -- strip whitespace
    | Txt.stripStart txt == "" = stripEmptyNodes nodes
    | otherwise = NodeContent (collapseSpaces txt) : stripEmptyNodes nodes
stripEmptyNodes (node:nodes) = stripEmptyNodes nodes
stripEmptyNodes [] = []

collapseSpaces txt
    | txt == "" = "" -- Avoids errors from head/tail tests.
    | isSpace $ Txt.head txt = " " `Txt.append` collapseSpaces (Txt.stripStart txt)
    | isSpace $ Txt.last txt = collapseSpaces (Txt.stripEnd txt) `Txt.append` " "
    | otherwise = Txt.unwords $ Txt.words txt

collapseBreaks :: Element -> Element
collapseBreaks (Element name attrs elChildren) =
    Element name attrs $ collapseBreaks' elChildren
collapseBreaks' :: [Node] -> [Node]
collapseBreaks' (
        NodeElement a@(Element "break" _ _):
        NodeElement b@(Element "break" _ _):
        nodes
    ) = NodeElement (maxBreak a b) : collapseBreaks' nodes
collapseBreaks' (NodeElement el:nodes) = NodeElement (collapseBreaks el) : collapseBreaks' nodes
collapseBreaks' (node:nodes) = node:collapseBreaks' nodes
collapseBreaks' [] = []

styleToSSML self = collapseBreaks $ stripEmptyEls $ buildEl0 "speak" [] $ styleToSSML' self