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

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

import Text.Read (readMaybe) -- to parse <progress> into a more international textual representation.
import MimeInfo (mimeInfoCached) -- to correct label of rel=alternate links.
import Network.URI.Fetch as App (Application(..))

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 $ App.name $ mimeInfoCached $ 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