{-# LANGUAGE OverloadedStrings #-}
module StyleTree(
        StyleTree(..), Pitch(..), Voice(..), Unit'(..), pitchAdjust,
        Pause(..), Cue(..), StyleLeaf(..), cssFloat
    ) 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 Unit' = Unit' Text Float
pitchAdjust (Pitch _ adjust) = adjust
pitchAdjust _ = Nothing

data Pitch = Pitch Text (Maybe Unit') | Absolute Text Float | Relative Text Float | Inherit

pitches = ["x-low", "low", "medium", "high", "x-high"]
parsePitch [Ident kw, Percentage n' n] = parsePitch [Ident kw, Dimension n' n "%"]
parsePitch [Ident kw, Dimension _ n unit]
    | kw `elem` pitches && unit `elem` ["hz", "khz", "st", "%"] =
        Just $ Pitch kw $ Just $ Unit' unit $ cssFloat n
parsePitch [Ident kw] | kw `elem` pitches = Just $ Pitch kw Nothing
parsePitch [Ident "initial"] = Just $ Pitch "medium" Nothing
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
    | otherwise = Just $ Voice kw
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 :: Maybe Unit'} | NoCue
parseCue [Url source] = Just $ Cue source Nothing
parseCue [Url source, Dimension _ n "dB"] = Just $ Cue source $ Just $ Unit' "dB" $ cssFloat n
parseCue [Ident "none"] = Just NoCue
parseCue _ = Nothing

data StyleLeaf = Content {value :: Text} deriving Eq

parseCounters [Ident "none"] = Just []
parseCounters [] = Just []
parseCounters (Ident counter : Number _ (NVInteger count) : toks) =
    (:) (counter, count) <$> parseCounters toks
parseCounters (Ident counter : toks) = (:) (counter, 0) <$> parseCounters toks
parseCounters _ = Nothing

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

    pauseBefore :: Pause,
    pauseAfter :: Pause,
    restBefore :: Pause,
    restAfter :: Pause,
    cueBefore :: Cue,
    cueAfter :: Cue,

    counterReset :: [(Text, Integer)],
    counterIncrement :: [(Text, Integer)],

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

instance Style.PropertyParser StyleTree where
    temp = StyleTree {
        voice = Nothing,
        volume = Nothing,
        volumeAdjust = Nothing,
        rate = Nothing,
        rateAdjust = 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,
        cueBefore = NoCue,
        cueAfter = NoCue,

        counterReset = [],
        counterIncrement = [],

        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", b)]
    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, Dimension _ n "dB"]
        | kw `elem` ["x-soft", "soft", "medium", "loud", "x-loud"] =
            Just self {volume = Just kw, volumeAdjust = Just $ Unit' "dB" $ cssFloat n}
    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, Percentage _ n] =
        Style.longhand self (self {
            rateAdjust = Just $ Unit' "%" $ cssFloat n
        }) "voice-rate" [Ident kw]
    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 = (\val -> self {pitch = val}) <$> parsePitch toks
    longhand _ self "voice-range" toks = (\val -> self {range = val}) <$> parsePitch toks

    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 {speakAs = Nothing, punctuation = Just True}
    longhand _ self "speak-as" [Ident "no-punctuation"] = Just self {speakAs = Nothing, punctuation = Just False}
    longhand _ self "speak-as" [tok, Ident kw]
        | kw `elem` ["literal-punctuation", "no-punctuation"], Just self' <- Style.longhand self self "speak-as" [tok] =
            Just self' {punctuation = Just (kw == "literal-punctuation")}

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

    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 = (\val -> self {pauseBefore = val}) <$> parsePause toks
    longhand _ self "pause-after" toks = (\val -> self {pauseAfter = val}) <$> parsePause toks
    longhand _ self "rest-before" toks = (\val -> self {restBefore = val}) <$> parsePause toks
    longhand _ self "rest-after" toks = (\val -> self {restAfter = val}) <$> parsePause toks

    longhand _ self "cue-before" toks = (\val -> self {cueBefore = val}) <$> parseCue toks
    longhand _ self "cue-after" toks = (\val -> self {cueAfter = val}) <$> parseCue toks

    longhand _ self "content" [String txt] = Just self {content = [Content txt]}

    longhand _ self "counter-reset" toks = (\val -> self {counterReset = val}) <$> parseCounters toks
    longhand _ self "counter-increment" toks = (\val -> self {counterIncrement = val}) <$> parseCounters toks

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

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