{-# LANGUAGE OverloadedStrings #-}
module SpeechStyle(SpeechStyle(..),
    Unit'(..), Pitch(..), pitchAdjust, Voice(..), Pause(..), Cue(..)) where

import Data.CSS.Syntax.Tokens
import Data.CSS.Style
import qualified Data.Text as Txt
import Data.Text (Text, unpack, pack, append)
import Data.Scientific (toRealFloat)
import Data.Maybe (isJust, catMaybes, fromMaybe)

import Text.Read (readMaybe) -- to parse <progress> into a more international textual representation.
import Network.MIME.Info as MIME

data Unit' = Unit' Text Float
data SpeechStyle = SpeechStyle {
    volume :: Maybe Text,
    volumeAdjust :: Maybe Unit',
    rate :: Maybe Text,
    rateAdjust :: Maybe Unit',
    pitch :: Maybe Pitch,
    range :: Maybe Pitch,

    speak :: Bool,
    speakAs :: Maybe Text,
    punctuation :: Maybe Bool,

    voices :: [Voice],
    stress :: Maybe Text,

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

    cueBefore :: Cue,
    cueAfter :: Cue,
    marker :: Maybe Text,

    content :: Text,
    lang :: Maybe Text,
    pseudoEl' :: Maybe Text
}

volumes = Txt.words "silent x-soft soft medium loud x-loud"
stresses = Txt.words "strong moderate none reduced"

instance PropertyParser SpeechStyle where
    temp = SpeechStyle {
        volume = Nothing,
        volumeAdjust = Nothing,
        rate = Nothing,
        rateAdjust = Nothing,
        pitch = Nothing,
        range = Nothing,

        speak = True,
        speakAs = Nothing,
        punctuation = Nothing,

        voices = [],
        stress = Nothing,

        pauseBefore = Pause Nothing Nothing,
        pauseAfter = Pause Nothing Nothing,
        restBefore = Pause Nothing Nothing,
        restAfter = Pause Nothing Nothing,
        cueBefore = NoCue,
        cueAfter = NoCue,
        marker = Nothing,

        content = "",
        lang = Nothing,
        pseudoEl' = Nothing
    }
    inherit _ = temp -- Text synthesizers handle inheritance.

    longhand _ self "voice-volume" [Ident "initial"] = Just self {volume = Just "medium"}
    longhand _ self "voice-volume" [Ident kw, Dimension _ n "dB"]
        | kw `elem` Prelude.tail volumes = Just self {volume = Just kw, volumeAdjust = Just $ cssUnit n "dB"}
    longhand _ self "voice-volume" [Ident kw] | kw `elem` volumes = Just self {volume = Just kw}

    longhand _ self "voice-rate" [kw, Percentage _ n] =
        longhand self self { rateAdjust = Just $ cssUnit n "%" } "voice-rate" [kw]
    longhand _ self "voice-rate" [Ident kw]
        | 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 = (\v -> self { pitch = Just v }) <$> parsePitch toks
    longhand _ self "voice-range" toks = (\v -> self { range = Just v }) <$> 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"] =
        longhand self self { punctuation = Just (kw == "literal-punctuation") } "speak-as" [tok]

    longhand _ self "voice-family" [Ident preserve] = Just self
    longhand _ self "voice-family" toks | Prelude.all isJust val = Just self { voices = catMaybes val }
        where val = Prelude.map parseVoice $ split' Comma toks

    longhand _ self "voice-stress" [Ident kw] | kw `elem` stresses = Just self { stress = Just kw }

    longhand _ self "pause-before" toks = (\v -> self { pauseBefore = v }) <$> parsePause toks
    longhand _ self "pause-after" toks = (\v -> self { pauseBefore = v }) <$> parsePause toks
    longhand _ self "rest-before" toks = (\v -> self { restBefore = v }) <$> parsePause toks
    longhand _ self "rest-after" toks = (\v -> self { restAfter = v }) <$> parsePause toks

    longhand _ self "cue-before" toks = (\v -> self { cueBefore = v }) <$> parseCue toks
    longhand _ self "cue-after" toks = (\v -> self { cueAfter = v }) <$> parseCue toks
    longhand _ self "-rhaps-marker" toks = (\v -> self { marker = Just v }) <$> parseStrings toks

    longhand _ self "content" [Ident "initial"] = Just self {content = ""}
    longhand _ self "content" toks = (\v -> self {content = v}) <$> parseStrings toks
    longhand _ self "::" [Ident pseudo] = Just self {pseudoEl' = Just pseudo} -- To make sure content doesn't override :before & :after
    longhand _ self "-rhaps-lang" [String v] = Just self {lang = Just v}
    longhand _ _ _ _ = Nothing

    shorthand _ "pause" [a, b] | isPause [a], isPause [b] = [("pause-before", [a]), ("pause-after", [b])]
    shorthand _ "pause" toks | isPause toks = [("pause-before", toks), ("pause-after", toks)]
    shorthand _ "rest" [a, b] | isPause [a], isPause [b] = [("rest-before", [a]), ("rest-after", [b])]
    shorthand _ "rest" toks | isPause toks = [("rest-before", toks), ("rest-after", toks)]

    shorthand _ "cue" (a:b:c) | isCue [a, b], isCue c = [("cue-before", [a, b]), ("cue-after", c)]
    shorthand _ "cue" (a:b) | isCue [a], isCue b = [("cue-before", [a]), ("cue-after", b)]
    shorthand _ "cue" toks | isCue toks = [("cue-before", toks), ("cue-after", toks)]

    shorthand _ "-rhaps-marker" [Ident m] = [
            ("-rhaps-marker", [String m, Function "counter", Ident m, RightParen]),
            ("counter-increment", [Ident m])
        ]

    shorthand self key value | isJust $ longhand self self key value = [(key, value)]
        | otherwise = []

-- parsers
data Pitch = Pitch Text (Maybe Unit') | Absolute Unit' | Relative Unit'
pitchAdjust (Pitch _ adjust) = adjust
pitchAdjust _ = Nothing

pitches = ["x-low", "low", "medium", "high", "x-high"]
parsePitch [Ident "initial"] = Just $ Pitch "medium" Nothing
parsePitch [kw, Percentage n' n] = parsePitch [kw, Dimension n' n "%"]
parsePitch [Ident kw, Dimension _ n unit]
    | kw `elem` pitches && unit `elem` ["hz", "khz", "st", "%"] =
        Just $ Pitch kw $ Just $ cssUnit n unit
parsePitch [Ident kw] | kw `elem` pitches = Just $ Pitch kw Nothing
parsePitch [Dimension _ n unit, Ident "absolute"]
    | unit `elem` ["hz", "khz"], cssFloat n > 0 = Just $ Absolute $ cssUnit n unit
parsePitch [Ident "absolute", Dimension _ n unit]
    | unit `elem` ["hz", "khz"], cssFloat n > 0 = Just $ Absolute $ cssUnit n unit
parsePitch [Dimension _ n unit]
    | unit `elem` ["hz", "khz"] = Just $ Relative $ cssUnit n unit
parsePitch _ = Nothing

data Voice = Voice Text | VoicePattern (Maybe Integer) Text (Maybe Integer)
genders = ["male", "female", "neutral"]
parseVoice (Comma:toks) = parseVoice toks
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
parseVoice _ = Nothing

data Pause = Pause { strength :: Maybe Text, time :: Maybe Unit' }
pauses = Txt.words "x-weak weak medium strong x-strong"
parsePause [Ident "none"] = Nothing
parsePause [Ident kw] | kw `elem` pauses = Just Pause { strength = Just kw, time = Nothing }
parsePause [Dimension _ n unit] | unit `elem` ["s", "ms"] =
    Just $ Pause Nothing $ Just $ cssUnit n unit
parsePause _ = Nothing
isPause = isJust . parsePause

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 $ cssUnit n "dB"
parseCue [Ident "none"] = Just NoCue
parseCue _ = Nothing
isCue = isJust . parseCue

parseStrings (String txt:toks) = append txt <$> parseStrings toks
parseStrings (Function "-rhaps-percentage":String num:String denom:RightParen:toks) =
    append (pack $ show frac) <$> parseStrings toks
  where
    frac :: Int
    frac = round (readNum num / readNum denom * 100)
    readNum :: Text -> Float
    readNum = fromMaybe (0.0) . readMaybe . unpack
parseStrings (Function "-rhaps-filetype":String mime:RightParen:toks) =
    append (pack $ MIME.name $ mimeInfo $ unpack mime) <$> parseStrings toks
parseStrings [] = Just ""
parseStrings _ = Nothing

-- ParsingUtils
cssUnit n "khz" = Unit' "hz" (cssFloat n*1000)
cssUnit n unit = Unit' unit $ cssFloat n
cssFloat :: NumericValue -> Float
cssFloat (NVInteger i) = fromInteger i
cssFloat (NVNumber n) = toRealFloat n

split' :: Eq a => a -> [a] -> [[a]]
split' _ [] = []
split' sep list = h:split' sep t where (h,t) = Prelude.break (==sep) list