{-# LANGUAGE OverloadedStrings #-}
module StyleTree(
        StyleTree(..), Pitch(..), Voice(..)
    ) where

import Data.CSS.Syntax.Tokens
import Data.Map
import qualified Data.HTML2CSS as H2C
import qualified Data.CSS.Style as Style
import Data.Text
import Data.Scientific (toRealFloat)

data Pitch = Pitch Text | Absolute Text Float | Relative Text Float | Inherit

parsePitch [Ident kw] | kw `elem` ["x-low", "low", "medium", "high", "x-high"] = Just $ Pitch kw
parsePitch [Ident "initial"] = Just $ Pitch "medium"
parsePitch [Dimension _ n unit, Ident "absolute"]
    | unit `elem` ["hz", "khz"] = Just $ Absolute unit $ cssFloat n
parsePitch [Ident "absolute", Dimension _ n unit]
    | unit `elem` ["hz", "khz"] = Just $ Absolute unit $ cssFloat n
parsePitch [Dimension _ n unit]
    | unit `elem` ["hz", "khz"] = Just $ Relative unit $ cssFloat n
parsePitch _ = Nothing

data Voice = Voice Text | VoicePattern (Maybe Integer) Text (Maybe Integer)

genders = ["male", "female", "neutral"]
parseVoice (Ident "child":toks) = parseVoice (Number "6" (NVInteger 6):toks)
parseVoice (Ident "young":toks) = parseVoice (Number "24" (NVInteger 24):toks)
parseVoice (Ident "old":toks) = parseVoice (Number "75" (NVInteger 75):toks)
parseVoice [Ident kw, Number _ (NVInteger v)]
    | v >= 1 && kw `elem` genders = Just $ VoicePattern Nothing kw $ Just v
parseVoice [Ident kw] | kw `elem` genders = Just $ VoicePattern Nothing kw Nothing
parseVoice [Number _ (NVInteger age), Ident kw, Number _ (NVInteger v)]
    | age >= 0 && kw `elem` genders && v >= 1 =
        Just $ VoicePattern (Just age) kw (Just v)
parseVoice [Number _ (NVInteger age), Ident kw]
    | age >= 0 && kw `elem` genders = Just $ VoicePattern (Just age) kw Nothing

data Pause = Pause {
    strength :: Maybe Text,
    time :: Maybe Text
}
parsePause [Ident kw]
    | kw `elem` ["none", "x-weak", "weak", "medium", "strong", "x-strong"] = Just Pause {
        strength = Just kw, time = Nothing
    }
parsePause toks@[Dimension _ _ unit] | unit `elem` ["s", "ms"] = Just Pause {
        strength = Nothing, time = Just $ serialize toks
    }
parsePause _ = Nothing

data Cue = Cue {src :: Text, cueVolume :: Float} | NoCue
parseCue [Url source] = Just $ Cue source 0
parseCue [Url source, Dimension _ n "dB"] = Just $ Cue source $ cssFloat n
parseCue [Ident "none"] = Just NoCue
parseCue _ = Nothing

data StyleTree = StyleTree {
    voice :: Maybe Voice,
    volume :: Maybe Text,
    rate :: Maybe Text,
    pitch :: Pitch,
    range :: Pitch,
    speak :: Bool,
    speakAs :: Maybe Text,
    punctuation :: Maybe Bool,
    stress :: Maybe Text,

    pauseBefore :: Pause,
    pauseAfter :: Pause,
    restBefore :: Pause,
    restAfter :: Pause,

    children :: [StyleTree],
    content :: Text
}

instance Style.PropertyParser StyleTree where
    temp = StyleTree {
        voice = Nothing,
        volume = Nothing,
        rate = Nothing,
        pitch = Inherit,
        range = Inherit,
        speak = True,
        speakAs = Nothing,
        punctuation = Nothing,
        stress = Nothing,

        pauseBefore = Pause Nothing Nothing,
        pauseAfter = Pause Nothing Nothing,
        restBefore = Pause Nothing Nothing,
        restAfter = Pause Nothing Nothing,

        children = [],
        content = ""
    }
    inherit _ = Style.temp

    shorthand _ "pause" [a, b] | Just _ <- parsePause [a], Just _ <- parsePause [b] =
        [("pause-before", [a]), ("pause-after", [b])]
    shorthand _ "pause" v | Just _ <- parsePause v =
        [("pause-before", v), ("pause-after", v)]

    shorthand _ "rest" [a, b] | Just _ <- parsePause [a], Just _ <- parsePause [b] =
        [("rest-before", [a]), ("rest-after", [b])]
    shorthand _ "rest" v | Just _ <- parsePause v =
        [("rest-before", v), ("rest-after", v)]

    --shorthand _ "cue" (a:b@(Dimension _ _ _):c) | Just _ <- parseCue [a, b], Just _ <- parseCue c =
    --    [("cue-before", [a, b]), ("cue-after", c)]
    --shorthand _ "cue" (a:b) | Just _ <- parseCue [a], Just _ <- parseCue b =
    --    [("cue-before", [a]), ("cue-after", c)]
    --shorthand _ "cue" v | Just _ <- parseCue v =
    --    [("cue-before", v), ("cue-after", v)]

    shorthand self key value | Just _ <- Style.longhand self self key value = [(key, value)]
        | otherwise = []

    longhand _ self "voice-volume" [Ident kw] -- TODO handle offsets
        | kw `elem` ["silent", "x-soft", "soft", "medium", "loud", "x-loud"] =
            Just self {volume = Just kw}
    longhand _ self "voice-volume" [Ident "initial"] = Just self {volume = Just "medium"}

    longhand _ self "voice-rate" [Ident kw] -- TODO handle offsets
        | kw `elem` ["x-slow", "slow", "medium", "fast", "x-fast"] = Just self {rate = Just kw}
        | kw `elem` ["initial", "normal"] = Just self {rate = Just "default"}

    longhand _ self "voice-pitch" toks = parsePitch toks >>= \val -> Just self {pitch = val}
    longhand _ self "voice-range" toks = parsePitch toks >>= \val -> Just self {range = val}

    longhand _ self "speak" [Ident "never"] = Just self {speak = False}
    longhand _ self "speak" [Ident kw] | kw `elem` ["always", "initial"] = Just self {speak = True}

    longhand _ self "speak-as" [Ident kw] |
        kw `elem` ["normal", "initial"] = Just self {speakAs = Nothing}
    longhand _ self "speak-as" [Ident "spell-out"] = Just self {speakAs = Just "characters"}
    longhand _ self "speak-as" [Ident "digits"] = Just self {speakAs = Just "tts:digits"}
    longhand _ self "speak-as" [Ident "literal-punctuation"] = Just self {punctuation = Just True}
    longhand _ self "speak-as" [Ident "no-punctuation"] = Just self {punctuation = Just False}

    longhand _ self "voice-family" [Ident "preserve"] = Just self
    longhand _ self "voice-family" toks = parseVoice toks >>= \val -> Just self {voice = Just val}

    longhand _ self "voice-stress" [Ident kw]
        | kw `elem` ["strong", "moderate", "none", "reduced"] = Just self {stress = Just kw}
    longhand _ self "voice-stress" [Ident "normal"] = Just self {stress = Just "moderate"}

    longhand _ self "pause-before" toks = parsePause toks >>= \val -> Just self {pauseBefore = val}
    longhand _ self "pause-after" toks = parsePause toks >>= \val -> Just self {pauseAfter = val}
    longhand _ self "rest-before" toks = parsePause toks >>= \val -> Just self {restBefore = val}
    longhand _ self "rest-after" toks = parsePause toks >>= \val -> Just self {restAfter = val}

    longhand _ self _ [Ident "inherit"] = Just self
    longhand _ _ _ _ = Nothing

--------
---- Helpers
--------
cssFloat :: NumericValue -> Float
cssFloat (NVInteger i) = fromInteger i
cssFloat (NVNumber n) = toRealFloat n