From b5f53aef8a6f9d01d0c971187eef8847d2b4084c Mon Sep 17 00:00:00 2001
From: Adrian Cochrane <adrian@openwork.nz>
Date: Mon, 22 Jul 2019 19:20:58 +1200
Subject: [PATCH] Allow adjusting keyword values.

---
 src/Main.hs      | 18 ++++++++++++++----
 src/StyleTree.hs | 29 +++++++++++++++++++++++++----
 2 files changed, 39 insertions(+), 8 deletions(-)

diff --git a/src/Main.hs b/src/Main.hs
index c62aea0..a1cc3f8 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -69,6 +69,11 @@ styleToSSML self =  buildEl0 "prosody" [
             ("rate", rate self),
             ("pitch", serializePitch $ pitch self),
             ("range", serializePitch $ range self)
+        ] $ buildEl0 "prosody" [
+            ("volume", maybeAdjust $ volumeAdjust self),
+            ("rate", maybeAdjust $ rateAdjust self),
+            ("pitch", maybeAdjust $ pitchAdjust $ pitch self),
+            ("range", maybeAdjust $ pitchAdjust $ range self)
         ] $ buildEl0 "emphasis" [("level", stress self)] $
         buildEl0 "say-as" [("interpret-as", speakAs self)] $
         buildEl0 "tts:style" [
@@ -80,13 +85,15 @@ styleToSSML self =  buildEl0 "prosody" [
         )
 
 serializePitch Inherit = Nothing
-serializePitch (Pitch kw) = Just kw
+serializePitch (Pitch kw _) = Just kw
 serializePitch (Absolute "khz" n) = serializePitch $ Absolute "hz" (1000 * n)
 serializePitch (Absolute _ n) | n < 0 = Nothing
     | otherwise = Just $ Txt.pack (show n ++ "hz")
-serializePitch (Relative "khz" n) = serializePitch $ Relative "hz" (1000 * n)
-serializePitch (Relative _ n) | n < 0 = Just $ Txt.pack (show n ++ "hz")
-    | otherwise = Just $ Txt.pack ("+" ++ show n ++ "hz")
+serializePitch (Relative unit n) = Just $ relativeUnit unit n
+
+relativeUnit "khz" n = relativeUnit "hz" $ 1000 * n
+relativeUnit unit n | n < 0 = Txt.pack (show n) `Txt.append` unit
+    | otherwise = Txt.pack ('+':show n) `Txt.append` unit
 
 maybeBool (Just True) truthy _ = Just truthy
 maybeBool (Just False) _ falsy = Just falsy
@@ -95,6 +102,9 @@ maybeBool Nothing _ _ = Nothing
 maybeCast (Just n) = Just $ Txt.pack $ show n
 maybeCast Nothing = Nothing
 
+maybeAdjust (Just (Unit' unit n)) = Just $ relativeUnit unit n
+maybeAdjust Nothing = Nothing
+
 buildVoice (Voice name) children = buildEl "voice" [("name", Just name)] children
 buildVoice (VoicePattern age gender variant) children = buildEl "voice" [
         ("age", maybeCast age),
diff --git a/src/StyleTree.hs b/src/StyleTree.hs
index 998916f..31778e0 100644
--- a/src/StyleTree.hs
+++ b/src/StyleTree.hs
@@ -1,6 +1,6 @@
 {-# LANGUAGE OverloadedStrings #-}
 module StyleTree(
-        StyleTree(..), Pitch(..), Voice(..)
+        StyleTree(..), Pitch(..), Voice(..), Unit'(..), pitchAdjust
     ) where
 
 import Data.CSS.Syntax.Tokens
@@ -10,10 +10,19 @@ 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
+data Unit' = Unit' Text Float
+pitchAdjust (Pitch _ adjust) = adjust
+pitchAdjust _ = Nothing
 
-parsePitch [Ident kw] | kw `elem` ["x-low", "low", "medium", "high", "x-high"] = Just $ Pitch kw
-parsePitch [Ident "initial"] = Just $ Pitch "medium"
+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]
@@ -31,6 +40,7 @@ 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)
@@ -59,7 +69,9 @@ parseCue _ = 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,
@@ -80,7 +92,9 @@ instance Style.PropertyParser StyleTree where
     temp = StyleTree {
         voice = Nothing,
         volume = Nothing,
+        volumeAdjust = Nothing,
         rate = Nothing,
+        rateAdjust = Nothing,
         pitch = Inherit,
         range = Inherit,
         speak = True,
@@ -118,11 +132,18 @@ instance Style.PropertyParser StyleTree where
     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"}
-- 
2.30.2