From ee018b4934ebaf93fd4a94a830d8240573f54e63 Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Tue, 28 Apr 2020 19:12:45 +1200 Subject: [PATCH] Extensively refactor to use the CSS engine's counters implementation. --- rhapsode.cabal | 4 +- src/Render.hs | 91 +++++------------- src/SSML.hs | 221 ++++++++++++++++---------------------------- src/SpeechStyle.hs | 191 ++++++++++++++++++++++++++++++++++++++ src/StyleTree.hs | 224 --------------------------------------------- src/Types.hs | 5 +- useragent.css | 3 +- 7 files changed, 299 insertions(+), 440 deletions(-) create mode 100644 src/SpeechStyle.hs delete mode 100644 src/StyleTree.hs diff --git a/rhapsode.cabal b/rhapsode.cabal index 75adf01..2e3f602 100644 --- a/rhapsode.cabal +++ b/rhapsode.cabal @@ -54,7 +54,7 @@ library exposed-modules: CExports, Input, Links, Render, Types -- Modules included in this library. - other-modules: SSML, StyleTree + other-modules: SSML, SpeechStyle -- LANGUAGE extensions used by modules in this package. -- other-extensions: @@ -63,7 +63,7 @@ library build-depends: base >=4.9 && <=4.12, directory, bytestring, html-conduit, xml-conduit, text, containers, data-default-class, network-uri, - stylist >= 2 && <3, css-syntax, xml-conduit-stylist >= 1.2 && <2, scientific, + stylist >= 2 && <3, css-syntax, xml-conduit-stylist >= 2 && <3, scientific, async, hurl >= 1.4.1.0, filepath, temporary, file-embed >= 0.0.9 && < 0.1 diff --git a/src/Render.hs b/src/Render.hs index 2f90965..4cf0cd2 100644 --- a/src/Render.hs +++ b/src/Render.hs @@ -10,13 +10,19 @@ import qualified Data.Map as M import System.Directory as Dir import Data.FileEmbed +import Data.Maybe (fromMaybe, maybeToList) +import Debug.Trace (trace) + --- External Rhapsode subcomponents import qualified Data.CSS.Syntax.StyleSheet as CSS import qualified Data.CSS.Style as Style +import Data.CSS.StyleTree import qualified Data.CSS.Syntax.Tokens as CSSTok import qualified Data.CSS.Preprocessor.Conditions as CSSCond import Data.CSS.Preprocessor.Assets import qualified Data.CSS.Preprocessor.PsuedoClasses as CSSPseudo +import qualified Data.CSS.Preprocessor.Text as CSSTxt + import qualified Data.HTML2CSS as H2C import Network.URI import Network.URI.Fetch @@ -29,7 +35,7 @@ import System.IO.Temp import Control.Exception (catch) -- Internal Rhapsode Subcomponents -import StyleTree +import SpeechStyle import SSML -- C API @@ -38,9 +44,20 @@ import Foreign.StablePtr import Foreign.C.String import Data.ByteString (useAsCString) -renderDoc :: Style.QueryableStyleSheet (Style.VarParser StyleTree) -> XML.Element -> B.ByteString +renderDoc :: Style.QueryableStyleSheet (Style.VarParser (CSSTxt.TextStyle SpeechStyle)) -> XML.Element -> B.ByteString renderDoc style html = - renderElLBS $ styleToSSML $ applyCounters $ stylize style html + renderElLBS $ styleToSSML $ CSSTxt.resolve $ inlinePseudos $ H2C.stylizeEl style html + +inlinePseudos :: Style.PropertyParser s => StyleTree [(Text, Style.VarParser s)] -> StyleTree s +inlinePseudos (StyleTree self childs) = StyleTree { + style = fromMaybe Style.temp $ Style.innerParser <$> lookup "" self, + children = pseudo "before" ++ map inlinePseudos childs ++ pseudo "after" + } where + pseudo n + | Just style <- Style.innerParser <$> lookup n self, + Just style' <- Style.longhand style style "::" [CSSTok.Ident n] = [StyleTree style' []] + | Just style <- Style.innerParser <$> lookup n self = [StyleTree style []] + | otherwise = [] renderElLBS el = XML.renderLBS XML.def $ XML.Document { XML.documentPrologue = XML.Prologue [] Nothing [], @@ -48,7 +65,7 @@ renderElLBS el = XML.renderLBS XML.def $ XML.Document { XML.documentEpilogue = [] } -retreiveStyles :: Session -> CSSCond.ConditionalStyles StyleTree -> IO (CSSCond.ConditionalStyles StyleTree) +retreiveStyles :: Session -> CSSCond.ConditionalStyles (CSSTxt.TextStyle SpeechStyle) -> IO (CSSCond.ConditionalStyles (CSSTxt.TextStyle SpeechStyle)) retreiveStyles manager authorStyle = do let agentStyle = H2C.cssPriorityAgent authorStyle `CSS.parse` $(embedStringFile "useragent.css") userStyle <- loadUserStyles agentStyle @@ -62,7 +79,7 @@ retreiveStyles manager authorStyle = do ("text/css", Right bytes) -> applyCSScharset charsets' $ B.toStrict bytes (_, _) -> "" -resolve' :: CSS.StyleSheet s => s -> CSSCond.ConditionalStyles StyleTree -> s +resolve' :: CSS.StyleSheet s => s -> CSSCond.ConditionalStyles (CSSTxt.TextStyle SpeechStyle) -> s resolve' = CSSCond.resolve lowerVars lowerToks lowerVars "speech" = CSSCond.B True lowerVars "-rhapsode" = CSSCond.B True @@ -95,14 +112,6 @@ loadUserStyles styles = do CSS.parse style (Txt.pack source) `loadFiles` files loadFiles style [] = return style - -stylize styles html = H2C.traversePrepopulatedStyles buildChild buildNode buildText styles html - where - buildChild (Style.VarParser _ self) _ | content self == [] = Nothing - | otherwise = Just [Style.temp {content = content self}] - buildNode (Style.VarParser _ self) children = self {children = children} - buildText _ txt = Style.temp {content = [Content txt]} - -------- ---- Download assets -------- @@ -119,62 +128,6 @@ downloadAssets session mimes (StyleAssets _ assets) = do filterMIMEs mimes cb download@(_, mime, _) | mime `elem` mimes = cb download | otherwise = return nullURI - --------- ----- Counters --------- -treeOrder :: (c -> c -> [Integer] -> StyleTree -> (c, StyleTree)) -> - c -> c -> [Integer] -> [StyleTree] -> (c, [StyleTree]) -treeOrder cb prevContext context (num:path) (node:nodes) = (tailContext, node' {children = children'} : nodes') - where - (selfContext, node') = cb prevContext context (num:path) node - (childContext, children') = treeOrder cb selfContext selfContext (0:num:path) $ children node - (tailContext, nodes') = treeOrder cb selfContext childContext (num + 1:path) nodes -treeOrder _ _ context _ [] = (context, []) -treeOrder _ _ _ [] _ = error "Invalid path during tree traversal!" - -inheritCounters path counterSource valueSource = M.intersectionWith cb valueSource counterSource -- indexed by name & el-path - where cb val source = [counter | path `elem` [p | (p, _) <- source], counter@(path, _) <- val] -instantiateCounter counters path name val = M.insertWith appendCounter name [(path, val)] counters - where - appendCounter new (old@((_:oldPath), _):olds) - | oldPath == tail path = new ++ olds - | otherwise = new ++ (old:olds) -instantiateCounters path instruct counters = foldl cb counters instruct - where cb counters' (name, value) = instantiateCounter counters' path name value -incrementCounter counters path name val = M.insertWith addCounter name [(path, val)] counters - where addCounter ((_, new):_) ((path, old):rest) = (path, new + old):rest -incrementCounters path instruct counters = foldl cb counters instruct - where cb counters' (name, value) = incrementCounter counters' path name value -setCounter counters path name val = M.insertWith setCounter' name [(path, val)] counters - where setCounter' ((_, val):_) ((path, _):rest) = (path, val):rest -setCounters path instruct counters = foldl cb counters instruct - where cb counters' (name, value) = setCounter counters' path name value - -renderCounter counters (Content txt) = Content txt -renderCounter counters (Counter name) - | Just ((_, count):_) <- name `M.lookup` counters = Content $ Txt.pack $ show count - | otherwise = Content "" -renderCounter counters (Counters name sep) - | Just counter <- name `M.lookup` counters = Content $ Txt.intercalate sep [ - Txt.pack $ show count | (_, count) <- reverse counter - ] - | otherwise = Content "" -renderCounters node counters = (counters, node { - content = map (renderCounter counters) $ content node, - counterSet = [(name, value) | (name, ((_, value):_)) <- M.toList counters] - }) - -applyCounters root = root { - children = snd $ treeOrder cb M.empty M.empty [0] $ children root - } where - cb :: M.Map Text [([Integer], Integer)] -> M.Map Text [([Integer], Integer)] -> - [Integer] -> StyleTree -> (M.Map Text [([Integer], Integer)], StyleTree) - cb counterSource valueSource path node = renderCounters node $ - setCounters path (counterSet node) $ - incrementCounters path (counterIncrement node) $ - instantiateCounters path (counterReset node) $ - inheritCounters path counterSource valueSource -------- ---- C API -------- diff --git a/src/SSML.hs b/src/SSML.hs index 0b8a1f8..9465729 100644 --- a/src/SSML.hs +++ b/src/SSML.hs @@ -1,149 +1,86 @@ {-# LANGUAGE OverloadedStrings #-} -module SSML(styleToSSML) where +module SSML(styleToSSML, postorder) where + import Text.XML import qualified Data.Text as Txt import Data.Map +import Data.Maybe (isNothing, fromMaybe) 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), +import Data.CSS.StyleTree + +import SpeechStyle + +styleToSSML :: StyleTree SpeechStyle -> Element +styleToSSML = Element "{http://www.w3.org/2001/10/synthesis}speak" M.empty . styleToNodes +styleToNodes :: StyleTree SpeechStyle -> [Node] +styleToNodes = Prelude.map style . postorder styleToSSML' + +styleToSSML' SpeechStyle { speak = False } _ = [] +styleToSSML' self@SpeechStyle {content = ""} children = el "prosody" [ + ("rhapsode:pseudo", pseudoEl self), + ("volume", volume self), + ("rate", rate self), + ("pitch", pitch2txt <$> pitch self), + ("range", pitch2txt <$> range self) + ] $ el "prosody" [ + ("volume", unit2txt <$> volumeAdjust self), + ("rate", unit2txt <$> rateAdjust self), + ("pitch", unit2txt <$> (pitchAdjust =<< pitch self)), + ("range", unit2txt <$> (pitchAdjust =<< range self)) + ] $ el "emphasis" [("level", stress self)] $ + el "say-as" [("interpret-as", speakAs self)] $ + el "tts:style" [ + ("field", (\_ -> "punctuation") <$> speakAs self), + ("mode", (\b -> if b then "all" else "none") <$> punctuation self) + ] $ buildVoices (reverse $ voices self) $ + buildBox self children +styleToSSML' style childs = styleToSSML' style {content = ""} ( + pseudo "before" ++ [NodeContent $ content style] ++ pseudo "after") + where + pseudo n = [child | child@(NodeElement (Element _ attrs _)) <- childs, + M.lookup "rhapsode:pseudo" attrs == Just n] + +buildVoices (Voice name:voices) children = + el "voice" [("name", Just name)] $ buildVoices voices children +buildVoices (VoicePattern age gender variant:voices) children = el "voice" [ + ("age", Txt.pack <$> show <$> 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 - ] ++ Prelude.map (NodeContent . value) (content self) - ++ Prelude.map (NodeElement . styleToSSML') (children self) ++ [ - buildBreak $ restAfter self, - buildCue $ cueAfter self, - buildBreak $ pauseAfter self + ("variant", Txt.pack <$> show <$> variant) + ] $ buildVoices voices children +buildVoices [] children = children + +buildBox self childs = concat [ + breakEl $ pauseBefore self, + audioEl $ cueBefore self, + breakEl $ restBefore self, + childs, + breakEl $ restAfter self, + audioEl $ cueAfter self, + breakEl $ pauseAfter self ] - -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)] [] - -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 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 -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 - -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 +breakEl self = el "break" [("strength", strength self), ("time", unit2txt <$> time self)] [] +audioEl NoCue = [] +audioEl self = el "prosody" [("volume", unit2txt <$> cueVolume self)] $ + el "audio" [("src", Just $ src self)] [] + +-- support +postorder :: (a -> [b] -> [b]) -> StyleTree a -> [StyleTree b] +postorder cb (StyleTree self children) = + [StyleTree self' children' | self' <- cb self $ Prelude.map style children'] + where children' = concat $ Prelude.map (postorder cb) children + +el :: Name -> [(Name, Maybe Txt.Text)] -> [Node] -> [Node] +el n attrs children | all (isNothing . snd) attrs = children + | otherwise = [NodeElement $ Element { + elementName = n, + elementAttributes = M.fromList [(k, v) | (k, Just v) <- attrs], + elementNodes = children + }] + +relativeUnit n | n < 0 = Txt.pack (show n) + | otherwise = Txt.pack ('+':show n) +unit2txt (Unit' unit n) = relativeUnit n `Txt.append` unit + +pitch2txt (Pitch kw _) = kw +pitch2txt (Absolute (Unit' unit n)) = Txt.pack (show n) `Txt.append` unit +pitch2txt (Relative n) = unit2txt n diff --git a/src/SpeechStyle.hs b/src/SpeechStyle.hs new file mode 100644 index 0000000..8c07f22 --- /dev/null +++ b/src/SpeechStyle.hs @@ -0,0 +1,191 @@ +{-# LANGUAGE OverloadedStrings #-} +module SpeechStyle(SpeechStyle(..), + Unit'(..), Pitch(..), pitchAdjust, Voice(..), Pause(..), Cue(..)) where + +import Data.CSS.Syntax.Tokens +import Data.CSS.Style +import Data.Text as Txt +import Data.Scientific (toRealFloat) +import Data.Maybe (isJust, catMaybes) + +data Unit' = Unit' Text Float +data SpeechStyle = SpeechStyle { + volume :: Maybe Text, + volumeAdjust :: Maybe Unit', + rate :: Maybe Text, + rateAdjust :: Maybe Unit', + pitch :: Maybe Pitch, + range :: Maybe Pitch, + + speak :: Bool, + speakAs :: Maybe Text, + punctuation :: Maybe Bool, + + voices :: [Voice], + stress :: Maybe Text, + + pauseBefore :: Pause, + pauseAfter :: Pause, + restBefore :: Pause, + restAfter :: Pause, + + cueBefore :: Cue, + cueAfter :: Cue, + + content :: Text, + pseudoEl :: Maybe Text +} + +volumes = Txt.words "silent x-soft soft medium loud x-loud" +stresses = Txt.words "strong moderate none reduced" + +instance PropertyParser SpeechStyle where + temp = SpeechStyle { + volume = Nothing, + volumeAdjust = Nothing, + rate = Nothing, + rateAdjust = Nothing, + pitch = Nothing, + range = Nothing, + + speak = True, + speakAs = Nothing, + punctuation = Nothing, + + voices = [], + stress = Nothing, + + pauseBefore = Pause Nothing Nothing, + pauseAfter = Pause Nothing Nothing, + restBefore = Pause Nothing Nothing, + restAfter = Pause Nothing Nothing, + cueBefore = NoCue, + cueAfter = NoCue, + + content = "", + pseudoEl = Nothing + } + inherit _ = temp -- Text synthesizers handle inheritance. + + longhand _ self "voice-volume" [Ident "initial"] = Just self {volume = Just "medium"} + longhand _ self "voice-volume" [Ident kw, Dimension _ n "dB"] + | kw `elem` Prelude.tail volumes = Just self {volume = Just kw, volumeAdjust = Just $ cssUnit n "dB"} + longhand _ self "voice-volume" [Ident kw] | kw `elem` volumes = Just self {volume = Just kw} + + longhand _ self "voice-rate" [kw, Percentage _ n] = + longhand self self { rateAdjust = Just $ cssUnit n "%" } "voice-rate" [kw] + longhand _ self "voice-rate" [Ident kw] + | kw `elem` ["x-slow", "slow", "medium", "fast", "x-fast"] = Just self {rate = Just kw} + | kw `elem` ["initial", "normal"] = Just self {rate = Just "default"} + + longhand _ self "voice-pitch" toks = (\v -> self { pitch = Just v }) <$> parsePitch toks + longhand _ self "voice-range" toks = (\v -> self { range = Just v }) <$> parsePitch toks + + longhand _ self "speak" [Ident "never"] = Just self { speak = False } + longhand _ self "speak" [Ident kw] | kw `elem` ["always", "initial"] = Just self { speak = True } + + longhand _ self "speak-as" [Ident kw] | kw `elem` ["normal", "initial"] = Just self { speakAs = Nothing } + longhand _ self "speak-as" [Ident "spell-out"] = Just self { speakAs = Just "characters" } + longhand _ self "speak-as" [Ident "digits"] = Just self { speakAs = Just "tts:digits" } + longhand _ self "speak-as" [Ident "literal-punctuation"] = Just self { speakAs = Nothing, punctuation = Just True } + longhand _ self "speak-as" [Ident "no-punctuation"] = Just self { speakAs = Nothing, punctuation = Just False } + longhand _ self "speak-as" [tok, Ident kw] | kw `elem` ["literal-punctuation", "no-punctuation"] = + longhand self self { punctuation = Just (kw == "literal-punctuation") } "speak-as" [tok] + + longhand _ self "voice-family" [Ident preserve] = Just self + longhand _ self "voice-family" toks | Prelude.all isJust val = Just self { voices = catMaybes val } + where val = Prelude.map parseVoice $ split' Comma toks + + longhand _ self "voice-stress" [Ident kw] | kw `elem` stresses = Just self { stress = Just kw } + + longhand _ self "pause-before" toks = (\v -> self { pauseBefore = v }) <$> parsePause toks + longhand _ self "pause-after" toks = (\v -> self { pauseBefore = v }) <$> parsePause toks + longhand _ self "rest-before" toks = (\v -> self { restBefore = v }) <$> parsePause toks + longhand _ self "rest-after" toks = (\v -> self { restAfter = v }) <$> parsePause toks + + longhand _ self "cue-before" toks = (\v -> self { cueBefore = v }) <$> parseCue toks + longhand _ self "cue-after" toks = (\v -> self { cueAfter = v }) <$> parseCue toks + + longhand _ self "content" [Ident "initial"] = Just self {content = ""} + longhand _ self "content" toks = (\v -> self {content = v}) <$> parseStrings toks + longhand _ self "::" [Ident pseudo] = Just self {pseudoEl = Just pseudo} -- To make sure content doesn't override :before & :after + longhand _ _ _ _ = Nothing + + shorthand _ "pause" [a, b] | isPause [a], isPause [b] = [("pause-before", [a]), ("pause-after", [b])] + shorthand _ "pause" toks | isPause toks = [("pause-before", toks), ("pause-after", toks)] + shorthand _ "rest" [a, b] | isPause [a], isPause [b] = [("rest-before", [a]), ("rest-after", [b])] + shorthand _ "rest" toks | isPause toks = [("rest-before", toks), ("rest-after", toks)] + + shorthand _ "cue" (a:b:c) | isCue [a, b], isCue c = [("cue-before", [a, b]), ("cue-after", c)] + shorthand _ "cue" (a:b) | isCue [a], isCue b = [("cue-before", [a]), ("cue-after", b)] + shorthand _ "cue" toks | isCue toks = [("cue-before", toks), ("cue-after", toks)] + + shorthand self key value | isJust $ longhand self self key value = [(key, value)] + | otherwise = [] + +-- parsers +data Pitch = Pitch Text (Maybe Unit') | Absolute Unit' | Relative Unit' +pitchAdjust (Pitch _ adjust) = adjust +pitchAdjust _ = Nothing + +pitches = ["x-low", "low", "medium", "high", "x-high"] +parsePitch [Ident "initial"] = Just $ Pitch "medium" Nothing +parsePitch [kw, Percentage n' n] = parsePitch [kw, Dimension n' n "%"] +parsePitch [Ident kw, Dimension _ n unit] + | kw `elem` pitches && unit `elem` ["hz", "khz", "st", "%"] = + Just $ Pitch kw $ Just $ cssUnit n unit +parsePitch [Ident kw] | kw `elem` pitches = Just $ Pitch kw Nothing +parsePitch [Dimension _ n unit, Ident "absolute"] + | unit `elem` ["hz", "khz"], cssFloat n > 0 = Just $ Absolute $ cssUnit n unit +parsePitch [Ident "absolute", Dimension _ n unit] + | unit `elem` ["hz", "khz"], cssFloat n > 0 = Just $ Absolute $ cssUnit n unit +parsePitch [Dimension _ n unit] + | unit `elem` ["hz", "khz"] = Just $ Relative $ cssUnit n unit +parsePitch _ = Nothing + +data Voice = Voice Text | VoicePattern (Maybe Integer) Text (Maybe Integer) +genders = ["male", "female", "neutral"] +parseVoice (Comma:toks) = parseVoice toks +parseVoice (Ident "child":toks) = parseVoice (Number "6" (NVInteger 6):toks) +parseVoice (Ident "young":toks) = parseVoice (Number "24" (NVInteger 24):toks) +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) +parseVoice [Number _ (NVInteger age), Ident kw] + | age >= 0 && kw `elem` genders = Just $ VoicePattern (Just age) kw Nothing +parseVoice _ = Nothing + +data Pause = Pause { strength :: Maybe Text, time :: Maybe Unit' } +pauses = Txt.words "x-weak weak medium strong x-strong" +parsePause [Ident "none"] = Nothing +parsePause [Ident kw] | kw `elem` pauses = Just Pause { strength = Just kw, time = Nothing } +parsePause [Dimension _ n unit] | unit `elem` ["s", "ms"] = + Just $ Pause Nothing $ Just $ cssUnit n unit +parsePause _ = Nothing +isPause = isJust . parsePause + +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 $ cssUnit n "dB" +parseCue [Ident "none"] = Just NoCue +parseCue _ = Nothing +isCue = isJust . parseCue + +-- ParsingUtils +parseStrings (String txt:toks) = append txt <$> parseStrings toks +parseStrings [] = Just "" +parseStrings _ = Nothing + +cssUnit n "khz" = Unit' "hz" (cssFloat n*1000) +cssUnit n unit = Unit' unit $ cssFloat n +cssFloat :: NumericValue -> Float +cssFloat (NVInteger i) = fromInteger i +cssFloat (NVNumber n) = toRealFloat n + +split' :: Eq a => a -> [a] -> [[a]] +split' _ [] = [] +split' sep list = h:split' sep t where (h,t) = Prelude.break (==sep) list diff --git a/src/StyleTree.hs b/src/StyleTree.hs deleted file mode 100644 index c08b10d..0000000 --- a/src/StyleTree.hs +++ /dev/null @@ -1,224 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module StyleTree( - StyleTree(..), Pitch(..), Voice(..), Unit'(..), pitchAdjust, - Pause(..), Cue(..), StyleLeaf(..), cssFloat - ) where - -import Data.CSS.Syntax.Tokens -import qualified Data.CSS.Style as Style -import Data.Text -import Data.Scientific (toRealFloat) - -data Unit' = Unit' Text Float -pitchAdjust (Pitch _ adjust) = adjust -pitchAdjust _ = Nothing - -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] - | unit `elem` ["hz", "khz"] = Just $ Absolute unit $ cssFloat n -parsePitch [Dimension _ n unit] - | unit `elem` ["hz", "khz"] = Just $ Relative unit $ cssFloat n -parsePitch _ = Nothing - -data Voice = Voice Text | VoicePattern (Maybe Integer) Text (Maybe Integer) - -genders = ["male", "female", "neutral"] -parseVoice (Ident "child":toks) = parseVoice (Number "6" (NVInteger 6):toks) -parseVoice (Ident "young":toks) = parseVoice (Number "24" (NVInteger 24):toks) -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) -parseVoice [Number _ (NVInteger age), Ident kw] - | age >= 0 && kw `elem` genders = Just $ VoicePattern (Just age) kw Nothing - -data Pause = Pause { - strength :: Maybe Text, - time :: Maybe Text -} -parsePause [Ident "none"] = Nothing -parsePause [Ident kw] - | kw `elem` ["x-weak", "weak", "medium", "strong", "x-strong"] = Just Pause { - strength = Just kw, time = Nothing - } -parsePause toks@[Dimension _ _ unit] | unit `elem` ["s", "ms"] = Just Pause { - strength = Nothing, time = Just $ serialize toks - } -parsePause _ = Nothing - -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 - -data StyleLeaf = Content {value :: Text} | Counter Text | Counters Text Text deriving Eq -parseContent (String txt:toks) = (\val -> Content txt : val) <$> parseContent toks -parseContent (Function "counter" : Ident c : LeftParen : toks) = - (\val -> Counter c : val) <$> parseContent toks -parseContent (Function "counters" : Ident c : Comma : String sep : LeftParen : toks) = - (\val -> Counters c sep : val) <$> parseContent toks -parseContent [] = Just [] -parseContent _ = Nothing - -parseCounters _ [Ident "none"] = Just [] -parseCounters _ [] = Just [] -parseCounters x (Ident counter : Number _ (NVInteger count) : toks) = - (:) (counter, count) <$> parseCounters x toks -parseCounters x (Ident counter : toks) = (:) (counter, x) <$> parseCounters x toks -parseCounters _ _ = 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, - speakAs :: Maybe Text, - punctuation :: Maybe Bool, - stress :: Maybe Text, - - pauseBefore :: Pause, - pauseAfter :: Pause, - restBefore :: Pause, - restAfter :: Pause, - cueBefore :: Cue, - cueAfter :: Cue, - - counterReset :: [(Text, Integer)], - counterIncrement :: [(Text, Integer)], - counterSet :: [(Text, Integer)], - - children :: [StyleTree], - content :: [StyleLeaf] -} - -instance Style.PropertyParser StyleTree where - temp = StyleTree { - voice = Nothing, - volume = Nothing, - volumeAdjust = Nothing, - rate = Nothing, - rateAdjust = Nothing, - pitch = Inherit, - range = Inherit, - speak = True, - speakAs = Nothing, - punctuation = Nothing, - stress = Nothing, - - pauseBefore = Pause Nothing Nothing, - pauseAfter = Pause Nothing Nothing, - restBefore = Pause Nothing Nothing, - restAfter = Pause Nothing Nothing, - cueBefore = NoCue, - cueAfter = NoCue, - - counterReset = [], - counterIncrement = [], - counterSet = [], - - children = [], - content = [] - } - inherit _ = Style.temp - - shorthand _ "pause" [a, b] | Just _ <- parsePause [a], Just _ <- parsePause [b] = - [("pause-before", [a]), ("pause-after", [b])] - shorthand _ "pause" v | Just _ <- parsePause v = - [("pause-before", v), ("pause-after", v)] - - shorthand _ "rest" [a, b] | Just _ <- parsePause [a], Just _ <- parsePause [b] = - [("rest-before", [a]), ("rest-after", [b])] - 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", 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 = [] - - 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"} - - longhand _ self "voice-pitch" toks = (\val -> self {pitch = val}) <$> parsePitch toks - longhand _ self "voice-range" toks = (\val -> self {range = val}) <$> parsePitch toks - - longhand _ self "speak" [Ident "never"] = Just self {speak = False} - longhand _ self "speak" [Ident kw] | kw `elem` ["always", "initial"] = Just self {speak = True} - - longhand _ self "speak-as" [Ident kw] | - kw `elem` ["normal", "initial"] = Just self {speakAs = Nothing} - longhand _ self "speak-as" [Ident "spell-out"] = Just self {speakAs = Just "characters"} - longhand _ self "speak-as" [Ident "digits"] = Just self {speakAs = Just "tts:digits"} - longhand _ self "speak-as" [Ident "literal-punctuation"] = Just self {speakAs = Nothing, punctuation = Just True} - longhand _ self "speak-as" [Ident "no-punctuation"] = Just self {speakAs = Nothing, punctuation = Just False} - longhand _ self "speak-as" [tok, Ident kw] - | kw `elem` ["literal-punctuation", "no-punctuation"], Just self' <- Style.longhand self self "speak-as" [tok] = - Just self' {punctuation = Just (kw == "literal-punctuation")} - - longhand _ self "voice-family" [Ident "preserve"] = Just self - longhand _ self "voice-family" toks = (\val -> self {voice = Just val}) <$> parseVoice toks - - longhand _ self "voice-stress" [Ident kw] - | kw `elem` ["strong", "moderate", "none", "reduced"] = Just self {stress = Just kw} - longhand _ self "voice-stress" [Ident "normal"] = Just self {stress = Just "moderate"} - - longhand _ self "pause-before" toks = (\val -> self {pauseBefore = val}) <$> parsePause toks - longhand _ self "pause-after" toks = (\val -> self {pauseAfter = val}) <$> parsePause toks - longhand _ self "rest-before" toks = (\val -> self {restBefore = val}) <$> parsePause toks - longhand _ self "rest-after" toks = (\val -> self {restAfter = val}) <$> parsePause toks - - longhand _ self "cue-before" toks = (\val -> self {cueBefore = val}) <$> parseCue toks - longhand _ self "cue-after" toks = (\val -> self {cueAfter = val}) <$> parseCue toks - - longhand _ self "content" toks = (\val -> self {content = val}) <$> parseContent toks - - longhand _ self "counter-reset" toks = (\val -> self {counterReset = val}) <$> parseCounters 0 toks - longhand _ self "counter-increment" toks = (\val -> self {counterIncrement = val}) <$> parseCounters 1 toks - longhand _ self "counter-set" toks = (\val -> self {counterSet = val}) <$> parseCounters 0 toks - - longhand _ self _ [Ident "inherit"] = Just self - longhand _ _ _ _ = Nothing - --------- ----- Helpers --------- -cssFloat :: NumericValue -> Float -cssFloat (NVInteger i) = fromInteger i -cssFloat (NVNumber n) = toRealFloat n diff --git a/src/Types.hs b/src/Types.hs index bff207e..825ad8f 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -2,8 +2,9 @@ module Types(CArray, Page(..)) where import System.Directory (getCurrentDirectory) -- default referer URI -import StyleTree (StyleTree) +import SpeechStyle (SpeechStyle) import Data.CSS.Preprocessor.Conditions (ConditionalStyles, conditionalStyles) +import Data.CSS.Preprocessor.Text (TextStyle) import Text.XML import qualified Data.Map.Strict as M import Network.URI @@ -13,7 +14,7 @@ import Foreign.StablePtr type CArray a = Ptr a -data Page = Page {url :: URI, css :: ConditionalStyles StyleTree, html :: Document} +data Page = Page {url :: URI, css :: ConditionalStyles (TextStyle SpeechStyle), html :: Document} foreign export ccall c_initialReferer :: IO (StablePtr Page) diff --git a/useragent.css b/useragent.css index 6f40047..2db4034 100644 --- a/useragent.css +++ b/useragent.css @@ -1,6 +1,7 @@ head, link, meta, style, script, title, base {speak: never} datalist, template {speak: never} html {speak-as: normal no-punctuation} +* {white-space: normal;} /** Forms **/ button, select, textarea, input, output {speak: never} /* Leave to special form entry mode */ @@ -30,7 +31,7 @@ h6 {voice-pitch: high} hr {pause: x-strong} p, pre, samp, blockquote {pause: strong} pre, address, samp {speak-as: literal-punctuation} -pre, samp, code {voice: neutral 2} +pre, samp, code {voice: neutral 2; white-space: pre;} [href], :link {cue-after: url(about:link.wav) !important; voice-pitch: low} :link:visited {cue-after: url(about:link.wav) -1db !important} img {voice-volume: soft; content: attr(src)} -- 2.30.2