~alcinnz/rhapsode

ref: 122e09743f367de47db4e6efc56fb5a79082c91e rhapsode/src/StyleTree.hs -rw-r--r-- 9.5 KiB
122e0974 — Adrian Cochrane Style <aside>. 5 years ago
                                                                                
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
{-# 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} | Counter Text | Counters Text Text deriving Eq
parseContent (String txt:toks) = (\val -> Content txt : val) <$> parseContent toks
parseContent (Function "counter" : Ident c : LeftParen : toks) =
    (\val -> Counter c : val) <$> parseContent toks
parseContent (Function "counters" : Ident c : Comma : String sep : LeftParen : toks) =
    (\val -> Counters c sep : val) <$> parseContent toks
parseContent [] = Just []
parseContent _ = Nothing

parseCounters _ [Ident "none"] = Just []
parseCounters _ [] = Just []
parseCounters x (Ident counter : Number _ (NVInteger count) : toks) =
    (:) (counter, count) <$> parseCounters x toks
parseCounters x (Ident counter : toks) = (:) (counter, x) <$> parseCounters x 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)],
    counterSet :: [(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 = [],
        counterSet = [],

        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" toks = (\val -> self {content = val}) <$> parseContent toks

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

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

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