From 5b9b03db39796dc0993f248954906f9de57c8e81 Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Tue, 23 Jul 2019 09:21:19 +1200 Subject: [PATCH] Integrate CSS Speech Box Model, improve user agent stylesheet. --- src/DefaultCSS.hs | 6 ++- src/Main.hs | 95 ++++------------------------------------------- src/SSML.hs | 7 +++- 3 files changed, 16 insertions(+), 92 deletions(-) diff --git a/src/DefaultCSS.hs b/src/DefaultCSS.hs index 6807916..cada362 100644 --- a/src/DefaultCSS.hs +++ b/src/DefaultCSS.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}", diff --git a/src/Main.hs b/src/Main.hs index afb651a..7077ebc 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -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 = [] - } diff --git a/src/SSML.hs b/src/SSML.hs index 8f890b3..f1202be 100644 --- a/src/SSML.hs +++ b/src/SSML.hs @@ -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 -- 2.30.2