From f1a311bde5149ce6abff67f809b4215a04ca5470 Mon Sep 17 00:00:00 2001
From: Adrian Cochrane <adrian@openwork.nz>
Date: Sat, 20 Jul 2019 10:54:07 +1200
Subject: [PATCH] Implement mappings to SSML <prosody> attributes.

---
 rhapsode.cabal |  2 +-
 src/Main.hs    | 50 +++++++++++++++++++++++++++++++++++++++++++++-----
 2 files changed, 46 insertions(+), 6 deletions(-)

diff --git a/rhapsode.cabal b/rhapsode.cabal
index d23371f..81ce927 100644
--- a/rhapsode.cabal
+++ b/rhapsode.cabal
@@ -64,7 +64,7 @@ executable rhapsode
         http-client, http-client-tls, bytestring,
         html-conduit, xml-conduit, text, containers,
         network-uri,
-        stylish-haskell >= 0.4.0, css-syntax, stylish-html-conduit
+        stylish-haskell >= 0.4.0, css-syntax, stylish-html-conduit >= 0.1.0.3, scientific
   
   -- Directories containing source files.
   hs-source-dirs:      src
diff --git a/src/Main.hs b/src/Main.hs
index 4e78fea..0be4ef4 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -20,6 +20,7 @@ import qualified Data.HTML2CSS as H2C
 
 import qualified Data.List as L
 import qualified Data.Map as M
+import Data.Scientific (toRealFloat)
 
 import DefaultCSS
 
@@ -64,13 +65,52 @@ stylizeEl styles html
     where
         buildEl (MPP attrs) children = XML.NodeElement $ XML.Element name attrs children
         buildText _ txt = XML.NodeContent txt
-        name = XML.Name "style" Nothing Nothing
+        name = XML.Name "prosody" Nothing Nothing
 
 data MapPropertyParser = MPP (M.Map XML.Name Text)
+addAttr self name value = Just $ MPP $ M.insert (XML.Name name Nothing Nothing) value self
+lowerHz n "khz" absolute = lowerHz (n*1000) "hz" absolute
+-- Relative offsets are communicated in SSML by the presence of a sign character.
+lowerHz n "hz" True | n < 0 = "0hz"
+    | otherwise = Txt.pack (show n ++ "hz")
+lowerHz n "hz" False | n < 0 = Txt.pack (show n ++ "hz")
+    | otherwise = Txt.pack ('+' : show n ++ "hz")
+
+cssFloat :: CSSTok.NumericValue -> Float
+cssFloat (CSSTok.NVInteger i) = fromInteger i
+cssFloat (CSSTok.NVNumber n) = toRealFloat n
+
 instance Style.PropertyParser MapPropertyParser where
     temp = MPP M.empty
     inherit _ = Style.temp
-    longhand _ (MPP self) name value = Just $ MPP $ M.insert xmlName xmlValue self
-        where
-            xmlName = XML.Name name Nothing Nothing
-            xmlValue = CSSTok.serialize value
+
+    longhand _ (MPP self) "voice-volume" [CSSTok.Ident kw] -- TODO handle offsets
+        | kw `elem` ["silent", "x-soft", "soft", "medium", "loud", "x-loud"] = addAttr self "volume" kw
+    longhand _ (MPP self) "voice-volume" [CSSTok.Ident "initial"] = addAttr self "volume" "medium"
+
+    longhand _ (MPP self) "voice-rate" [CSSTok.Ident kw] -- TODO handle percentages
+        | kw `elem` ["x-slow", "slow", "medium", "fast", "x-fast"] = addAttr self "rate" kw
+        | kw `elem` ["initial", "normal"] = addAttr self "rate" "default"
+
+    longhand _ (MPP self) "voice-pitch" [CSSTok.Ident kw] -- TODO handle offsets
+        | kw `elem` ["x-low", "low", "medium", "high", "x-high"] = addAttr self "pitch" kw
+    longhand _ (MPP self) "voice-pitch" [CSSTok.Ident "initial"] = addAttr self "pitch" "medium"
+    longhand _ (MPP self) "voice-pitch" [CSSTok.Dimension _ n unit, CSSTok.Ident "absolute"] =
+        addAttr self "pitch" $ lowerHz (cssFloat n) unit True
+    longhand _ (MPP self) "voice-pitch" [CSSTok.Ident "absolute", CSSTok.Dimension _ n unit] =
+        addAttr self "pitch" $ lowerHz (cssFloat n) unit True
+    longhand _ (MPP self) "voice-pitch" [CSSTok.Dimension _ n unit] =
+        addAttr self "pitch" $ lowerHz (cssFloat n) unit False
+
+    longhand _ (MPP self) "voice-range" [CSSTok.Ident kw] -- TODO handle offsets
+        | kw `elem` ["x-low", "low", "medium", "high", "x-high"] = addAttr self "range" kw
+    longhand _ (MPP self) "voice-range" [CSSTok.Ident "initial"] = addAttr self "range" "medium"
+    longhand _ (MPP self) "voice-range" [CSSTok.Dimension _ n unit, CSSTok.Ident "absolute"] =
+        addAttr self "range" $ lowerHz (cssFloat n) unit True
+    longhand _ (MPP self) "voice-range" [CSSTok.Ident "absolute", CSSTok.Dimension _ n unit] =
+        addAttr self "range" $ lowerHz (cssFloat n) unit True
+    longhand _ (MPP self) "voice-range" [CSSTok.Dimension _ n unit] =
+        addAttr self "range" $ lowerHz (cssFloat n) unit False
+
+    longhand _ self _ [CSSTok.Ident "inherit"] = Just self -- Imply the inheritance
+    longhand _ _ _ _ = Nothing
-- 
2.30.2