3 files changed, 165 insertions(+), 10 deletions(-)

M src/Main.hs
A src/SSML.hs
M src/StyleTree.hs

@@ 26,6 26,7 @@ import Data.Scientific (toRealFloat)
 
 import DefaultCSS
 import StyleTree
+import qualified SSML
 
 main :: IO ()
 main = do

@@ 0,0 1,146 @@
+{-# LANGUAGE OverloadedStrings #-}
+module SSML(styleToSSML) where
+import Text.XML
+import qualified Data.Text as Txt
+import Data.Map
+import qualified Data.Map as M
+import Data.CSS.Syntax.Tokens (tokenize, Token(Dimension))
+
+import Data.Char (isSpace)
+import Data.Maybe (fromJust)
+import Data.List (elemIndex)
+
+import StyleTree
+
+--------
+---- Basic conversion
+--------
+styleToSSML' StyleTree {speak = False} =
+    Element (Name "blank" Nothing Nothing) empty []
+styleToSSML' self =  buildEl0 "prosody" [
+            ("volume", volume self),
+            ("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" [
+            ("field", maybeBool (punctuation self) "punctuation" "punctuation"),
+            ("mode", maybeBool (punctuation self) "all" "none")
+        ] $ buildVoices (voice self) $ buildBox self
+
+serializePitch Inherit = Nothing
+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 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
+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),
+        ("gender", Just gender),
+        ("variant", maybeCast variant)
+    ] children
+
+buildVoices Nothing = buildEl "blank" []
+buildVoices (Just voice) = buildVoice voice
+
+--------
+---- CSS Speech Box Model
+--------
+buildBox self = [
+        buildBreak $ pauseBefore self,
+        buildCue $ cueBefore self,
+        buildBreak $ restBefore self,
+        NodeContent $ content self
+    ] ++ Prelude.map (NodeElement . styleToSSML') (children self) ++ [
+        buildBreak $ restAfter self,
+        buildCue $ cueAfter self,
+        buildBreak $ pauseAfter self
+    ]
+
+buildBreak self = NodeElement $ buildEl "break" [
+        ("strength", strength self),
+        ("time", time self)
+    ] []
+buildCue self = NodeElement $
+    buildEl0 "prosody" [("volume", maybeAdjust $ cueVolume self)] $
+    buildEl "audio" [("src", Just $ src self)] []
+
+volumes = ["x-weak", "weak", "medium", "strong", "x-strong"]
+maxBreak x@(Element _ a _) y@(Element _ b _)
+    | Just a' <- "strength" `M.lookup` a, Just b' <- "strength" `M.lookup` b, a' /= b' =
+        if fromJust (elemIndex a' volumes) > fromJust (elemIndex b' volumes) then x else y
+    | Just a' <- "time" `M.lookup` a, Just b' <- "time" `M.lookup` b, a' /= b' =
+        if toMS (tokenize a') > toMS (tokenize b') then x else y
+    | otherwise = x
+toMS [Dimension _ n "s"] = cssFloat n * 1000
+toMS [Dimension _ n "ms"] = cssFloat n
+toMS _ = 0 -- Should never happen.
+
+--------
+---- XML Output Utils
+--------
+buildEl name attrs elChildren =
+    Element (Name name Nothing Nothing) (attrsFromList attrs) elChildren
+buildEl0 name attrs child = buildEl name attrs [NodeElement child]
+
+attrsFromList ((name, Just value):attrs) =
+    insert (Name name Nothing Nothing) value $ attrsFromList attrs
+attrsFromList ((_, Nothing):attrs) = attrsFromList attrs
+attrsFromList [] = empty
+
+--------
+---- Tidyup
+--------
+stripEmptyEls (Element name attrs elChildren) =
+    Element name attrs $ stripEmptyNodes elChildren
+stripEmptyNodes (NodeElement el@(Element _ attrs elChildren ):nodes)
+    | M.null attrs = stripEmptyNodes (elChildren ++ nodes)
+    | otherwise = NodeElement (stripEmptyEls el) : stripEmptyNodes nodes
+stripEmptyNodes (NodeContent txt : nodes) -- strip whitespace
+    | Txt.stripStart txt == "" = stripEmptyNodes nodes
+    | otherwise = NodeContent (collapseSpaces txt) : stripEmptyNodes nodes
+stripEmptyNodes (node:nodes) = stripEmptyNodes nodes
+stripEmptyNodes [] = []
+
+collapseSpaces txt
+    | Txt.stripStart txt == "" = "" -- Avoids errors from head/tail tests.
+    | isSpace $ Txt.head txt = " " `Txt.append` collapseSpaces txt
+    | isSpace $ Txt.last txt = collapseSpaces (Txt.stripEnd txt) `Txt.append` " "
+    | otherwise = Txt.unwords $ Txt.words txt
+
+collapseBreaks :: Element -> Element
+collapseBreaks (Element name attrs elChildren) =
+    Element name attrs $ collapseBreaks' elChildren
+collapseBreaks' :: [Node] -> [Node]
+collapseBreaks' (
+        NodeElement a@(Element "break" _ _):
+        NodeElement b@(Element "break" _ _):
+        nodes
+    ) = NodeElement (maxBreak a b) : collapseBreaks' nodes
+collapseBreaks' (NodeElement el:nodes) = NodeElement (collapseBreaks el) : collapseBreaks' nodes
+collapseBreaks' (node:nodes) = node:collapseBreaks' nodes
+collapseBreaks' [] = []
+
+styleToSSML self = collapseBreaks $ stripEmptyEls $ buildEl0 "speak" [] $ styleToSSML' self

@@ 1,6 1,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 module StyleTree(
-        StyleTree(..), Pitch(..), Voice(..), Unit'(..), pitchAdjust
+        StyleTree(..), Pitch(..), Voice(..), Unit'(..), pitchAdjust,
+        Pause(..), Cue(..), cssFloat
     ) where
 
 import Data.CSS.Syntax.Tokens


@@ 60,9 61,9 @@ parsePause toks@[Dimension _ _ unit] | unit `elem` ["s", "ms"] = Just Pause {
     }
 parsePause _ = Nothing
 
-data Cue = Cue {src :: Text, cueVolume :: Float} | NoCue
-parseCue [Url source] = Just $ Cue source 0
-parseCue [Url source, Dimension _ n "dB"] = Just $ Cue source $ cssFloat n
+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
 


@@ 83,6 84,8 @@ data StyleTree = StyleTree {
     pauseAfter :: Pause,
     restBefore :: Pause,
     restAfter :: Pause,
+    cueBefore :: Cue,
+    cueAfter :: Cue,
 
     children :: [StyleTree],
     content :: Text


@@ 106,6 109,8 @@ instance Style.PropertyParser StyleTree where
         pauseAfter = Pause Nothing Nothing,
         restBefore = Pause Nothing Nothing,
         restAfter = Pause Nothing Nothing,
+        cueBefore = NoCue,
+        cueAfter = NoCue,
 
         children = [],
         content = ""


@@ 122,12 127,12 @@ instance Style.PropertyParser StyleTree where
     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", c)]
-    --shorthand _ "cue" v | Just _ <- parseCue v =
-    --    [("cue-before", v), ("cue-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 = []


@@ 173,6 178,9 @@ instance Style.PropertyParser StyleTree where
     longhand _ self "rest-before" toks = parsePause toks >>= \val -> Just self {restBefore = val}
     longhand _ self "rest-after" toks = parsePause toks >>= \val -> Just self {restAfter = val}
 
+    longhand _ self "cue-before" toks = parseCue toks >>= \val -> Just self {cueBefore = val}
+    longhand _ self "cue-after" toks = parseCue toks >>= \val -> Just self {cueAfter = val}
+
     longhand _ self _ [Ident "inherit"] = Just self
     longhand _ _ _ _ = Nothing