3 files changed, 16 insertions(+), 92 deletions(-)

M src/DefaultCSS.hs
M src/Main.hs
M src/SSML.hs

@@ 3,6 3,7 @@ module DefaultCSS(userAgentCSS) where
 userAgentCSS = unlines [
   "head, link, meta, style, script, title, base {speak: never}",
   "datalist, template {speak: never}",
+  "html {speak-as: no-punctuation} body {speak-as: normal}",
   "",
   "/** Forms **/",
   "/* Hide buttons that don't do anything */",


@@ 37,6 38,7 @@ userAgentCSS = unlines [
   "",
   "/** Sectioning **/",
   "footer, header {voice-volume: soft}",
+  "nav {speak: never} /* Expose the links for navigation, but not narration */",
   "h1, h2, h3, h4, h5, h6, legend, th, summary, dt {voice-stress: strong}",
   "h1 {pause: x-strong; voice-rate: x-slow}",
   "h2 {pause: strong; voice-rate: slow}",


@@ 49,7 51,7 @@ userAgentCSS = unlines [
   "hr {pause: x-strong}",
   "p, pre, samp, blockquote {pause: strong}",
   "pre, address, samp {speak-as: literal-punctuation}",
-  "",
+  "pre, samp, code {voice: neutral 2}",
   ":link {cue-before: url(link.wav); voice-pitch: low}",
   ":link:visited {cue-before: url(link.wav) -1db}",
   "",


@@ 96,7 98,7 @@ userAgentCSS = unlines [
   "abbr[title]::after {content: attr(title); voice-volume: x-soft}",
   "abbr {speak-as: spell-out}",
   "",
-  "q, blockquote {voice-family: neutral 2}",
+  "q, blockquote {voice-family: female 2}",
   "cite {voice-stress: reduce}",
   "dialog:not([open]) {speak: never}",
   "kbd {speak-as: spell-out}",

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


@@ 40,6 40,12 @@ main = do
     let transcript = stylize style html
     C8.putStrLn $ renderElLBS $ styleToSSML transcript
 
+renderElLBS el = XML.renderLBS XML.def $ XML.Document {
+        XML.documentPrologue = XML.Prologue [] Nothing [],
+        XML.documentRoot = el,
+        XML.documentEpilogue = []
+    }
+
 retreiveStyles html manager base = do
     style <- H2C.externalStyles authorStyle testMedia html loadURL
     return style


@@ 62,90 68,3 @@ stylize styles html = H2C.traverseStyles buildNode buildText styles html
     where
         buildNode self children = self {children = children}
         buildText _ txt = Style.temp {content = txt}
-
-styleToSSML StyleTree {speak = False} =
-    XML.Element (XML.Name "blank" Nothing Nothing) M.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) (
-            XML.NodeContent (content self) :
-            map (\node -> XML.NodeElement $ styleToSSML node) (children 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
-
---------
----- XML Output Utils
---------
-buildEl name attrs elChildren =
-    XML.Element (XML.Name name Nothing Nothing) (attrsFromList attrs) elChildren
-buildEl0 name attrs child = buildEl name attrs [XML.NodeElement child]
-
-attrsFromList ((name, Just value):attrs) =
-    M.insert (XML.Name name Nothing Nothing) value $ attrsFromList attrs
-attrsFromList ((_, Nothing):attrs) = attrsFromList attrs
-attrsFromList [] = M.empty
-
-stripEmptyEls (XML.Element name attrs elChildren) =
-    XML.Element name attrs $ stripEmptyNodes elChildren
-stripEmptyNodes (XML.NodeElement el@(XML.Element _ attrs elChildren ):nodes)
-    | M.null attrs = stripEmptyNodes (elChildren ++ nodes)
-    | otherwise = XML.NodeElement (stripEmptyEls el) : stripEmptyNodes nodes
-stripEmptyNodes (XML.NodeContent txt : nodes) = -- strip whitespace
-    XML.NodeContent (collapseSpaces txt) : stripEmptyNodes nodes
-stripEmptyNodes (node:nodes) = stripEmptyNodes nodes
-stripEmptyNodes [] = []
-
-collapseSpaces txt
-    | txt == "" = "" -- Avoids errors from head/tail tests.
-    | isSpace $ Txt.head txt = " " `Txt.append` collapseSpaces (Txt.stripStart txt)
-    | isSpace $ Txt.last txt = collapseSpaces (Txt.stripEnd txt) `Txt.append` " "
-    | otherwise = Txt.unwords $ Txt.words txt
-
-renderElLBS el = XML.renderLBS XML.def $ XML.Document {
-        XML.documentPrologue = XML.Prologue [] Nothing [],
-        XML.documentRoot = stripEmptyEls el,
-        XML.documentEpilogue = []
-    }

@@ 83,6 83,7 @@ buildBreak self = NodeElement $ buildEl "break" [
         ("strength", strength self),
         ("time", time self)
     ] []
+buildCue NoCue = NodeElement $ buildEl "blank" [] []
 buildCue self = NodeElement $
     buildEl0 "prosody" [("volume", maybeAdjust $ cueVolume self)] $
     buildEl "audio" [("src", Just $ src self)] []


@@ 118,6 119,8 @@ stripEmptyEls (Element name attrs elChildren) =
 stripEmptyNodes (NodeElement el@(Element _ attrs elChildren ):nodes)
     | M.null attrs = stripEmptyNodes (elChildren ++ nodes)
     | otherwise = NodeElement (stripEmptyEls el) : stripEmptyNodes nodes
+stripEmptyNodes (NodeContent a : NodeContent b : nodes) =
+    stripEmptyNodes (NodeContent (Txt.append a b) : nodes)
 stripEmptyNodes (NodeContent txt : nodes) -- strip whitespace
     | Txt.stripStart txt == "" = stripEmptyNodes nodes
     | otherwise = NodeContent (collapseSpaces txt) : stripEmptyNodes nodes


@@ 125,8 128,8 @@ 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
+    | txt == "" = "" -- Avoids errors from head/tail tests.
+    | isSpace $ Txt.head txt = " " `Txt.append` collapseSpaces (Txt.stripStart txt)
     | isSpace $ Txt.last txt = collapseSpaces (Txt.stripEnd txt) `Txt.append` " "
     | otherwise = Txt.unwords $ Txt.words txt