From 2adc7fb2e4778f57c1af1406229639f485961470 Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Wed, 31 Jul 2019 20:25:16 +1200 Subject: [PATCH] Parse content & counter properties, cleanup property handling. --- rhapsode.cabal | 2 +- src/DefaultCSS.hs | 22 +++++++++++++++----- src/Main.hs | 15 ++++++++------ src/SSML.hs | 6 +++--- src/StyleTree.hs | 51 ++++++++++++++++++++++++++++++++++------------- 5 files changed, 67 insertions(+), 29 deletions(-) diff --git a/rhapsode.cabal b/rhapsode.cabal index 81ce927..254bee2 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 >= 0.1.0.3, scientific + stylish-haskell >= 0.4.0, css-syntax, stylish-html-conduit >= 0.2.0.0, scientific -- Directories containing source files. hs-source-dirs: src diff --git a/src/DefaultCSS.hs b/src/DefaultCSS.hs index cada362..2511aea 100644 --- a/src/DefaultCSS.hs +++ b/src/DefaultCSS.hs @@ -3,7 +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}", + "html {speak-as: normal no-punctuation}", "", "/** Forms **/", "/* Hide buttons that don't do anything */", @@ -52,7 +52,7 @@ userAgentCSS = unlines [ "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}", + "a[href], :link {cue-before: url(link.wav); voice-pitch: low}", ":link:visited {cue-before: url(link.wav) -1db}", "", "b, strong {voice-rate: slow}", @@ -80,16 +80,28 @@ userAgentCSS = unlines [ "ol ol ol ol {counter-reset: -rhaps-ol4}", "ol ol ol ol ol {counter-reset: -rhaps-ol5}", "ol ol ol ol ol ol {counter-reset: -rhaps-ol6}", - "ol li::before {content: counter(-rhaps-ol1)}", - "ol ol li::before {content: counters(-rhaps-ol1, -rhaps-ol2)}", - "ol ol ol li::before {content: counters(-rhaps-ol1, -rhaps-ol2, -rhaps-ol3)}", + "ol li::before {", + "counter-increment: -rhaps-ol1;", + "content: counter(-rhaps-ol1)", + "}", + "ol ol li::before {", + "counter-increment: -rhaps-ol2;", + "content: counters(-rhaps-ol1, -rhaps-ol2)", + "}", + "ol ol ol li::before {", + "counter-increment: -rhaps-ol3;", + "content: counters(-rhaps-ol1, -rhaps-ol2, -rhaps-ol3)", + "}", "ol ol ol ol li::before {", + "counter-increment: -rhaps-ol4;", "content: counters(-rhaps-ol1, -rhaps-ol2, -rhaps-ol3, -rhaps-ol4)", "}", "ol ol ol ol ol li::before {", + "counter-increment: -rhaps-ol5;", "content: counters(-rhaps-ol1, -rhaps-ol2, -rhaps-ol3, -rhaps-ol4, -rhaps-ol5)", "}", "ol ol ol ol ol ol li::before {", + "counter-increment: -rhaps-ol6;", "content: counters(-rhaps-ol1, -rhaps-ol2, -rhaps-ol3, -rhaps-ol4, -rhaps-ol5, -rhaps-ol6)", "}", "", diff --git a/src/Main.hs b/src/Main.hs index 7077ebc..c5a72f3 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -23,6 +23,7 @@ import qualified Data.HTML2CSS as H2C import qualified Data.List as L import qualified Data.Map as M import Data.Scientific (toRealFloat) +import Data.Maybe (fromJust) import DefaultCSS import StyleTree @@ -36,7 +37,7 @@ main = do manager <- HTTP.newManager TLS.tlsManagerSettings response <- HTTP.httpLbs request manager let html = XML.documentRoot $ HTML.parseLBS $ HTTP.responseBody response - style <- retreiveStyles html manager request + style <- retreiveStyles html manager $ fromJust $ parseURI url let transcript = stylize style html C8.putStrLn $ renderElLBS $ styleToSSML transcript @@ -47,16 +48,16 @@ renderElLBS el = XML.renderLBS XML.def $ XML.Document { } retreiveStyles html manager base = do - style <- H2C.externalStyles authorStyle testMedia html loadURL + style <- H2C.externalStylesForURL authorStyle testMedia html base loadURL return style where emptyStyle :: Style.QueryableStyleSheet StyleTree emptyStyle = Style.queryableStyleSheet agentStyle = H2C.cssPriorityAgent emptyStyle `CSS.parse` Txt.pack userAgentCSS - authorStyle = H2C.internalStyles testMedia agentStyle html + authorStyle = H2C.internalStylesForURL testMedia agentStyle base html loadURL url = do -- TODO parallelise. - request <- setUriRelative base url + request <- requestFromURI url response <- HTTP.httpLbs request manager return $ Txt.pack $ C8.unpack $ HTTP.responseBody response @@ -64,7 +65,9 @@ testMedia attrs = media == Nothing || media == Just "speech" where media = "media" `M.lookup` attrs -stylize styles html = H2C.traverseStyles buildNode buildText styles html +stylize styles html = H2C.traversePrepopulatedStyles buildChild buildNode buildText styles html where + buildChild self _ | content self == [] = Nothing + | otherwise = Just [Style.temp {content = content self}] buildNode self children = self {children = children} - buildText _ txt = Style.temp {content = txt} + buildText _ txt = Style.temp {content = [Content txt]} diff --git a/src/SSML.hs b/src/SSML.hs index f1202be..0b8a1f8 100644 --- a/src/SSML.hs +++ b/src/SSML.hs @@ -71,9 +71,9 @@ buildVoices (Just voice) = buildVoice voice buildBox self = [ buildBreak $ pauseBefore self, buildCue $ cueBefore self, - buildBreak $ restBefore self, - NodeContent $ content self - ] ++ Prelude.map (NodeElement . styleToSSML') (children 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 diff --git a/src/StyleTree.hs b/src/StyleTree.hs index 28df24b..4e750a5 100644 --- a/src/StyleTree.hs +++ b/src/StyleTree.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} module StyleTree( StyleTree(..), Pitch(..), Voice(..), Unit'(..), pitchAdjust, - Pause(..), Cue(..), cssFloat + Pause(..), Cue(..), StyleLeaf(..), cssFloat ) where import Data.CSS.Syntax.Tokens @@ -67,6 +67,15 @@ parseCue [Url source, Dimension _ n "dB"] = Just $ Cue source $ Just $ Unit' "dB parseCue [Ident "none"] = Just NoCue parseCue _ = Nothing +data StyleLeaf = Content {value :: Text} deriving Eq + +parseCounters [Ident "none"] = Just [] +parseCounters [] = Just [] +parseCounters (Ident counter : Number _ (NVInteger count) : toks) = + (:) (counter, count) <$> parseCounters toks +parseCounters (Ident counter : toks) = (:) (counter, 0) <$> parseCounters toks +parseCounters _ = Nothing + data StyleTree = StyleTree { voice :: Maybe Voice, volume :: Maybe Text, @@ -87,8 +96,11 @@ data StyleTree = StyleTree { cueBefore :: Cue, cueAfter :: Cue, + counterReset :: [(Text, Integer)], + counterIncrement :: [(Text, Integer)], + children :: [StyleTree], - content :: Text + content :: [StyleLeaf] } instance Style.PropertyParser StyleTree where @@ -112,8 +124,11 @@ instance Style.PropertyParser StyleTree where cueBefore = NoCue, cueAfter = NoCue, + counterReset = [], + counterIncrement = [], + children = [], - content = "" + content = [] } inherit _ = Style.temp @@ -153,8 +168,8 @@ instance Style.PropertyParser StyleTree where | 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 = parsePitch toks >>= \val -> Just self {pitch = val} - longhand _ self "voice-range" toks = parsePitch toks >>= \val -> Just self {range = val} + 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} @@ -163,23 +178,31 @@ instance Style.PropertyParser StyleTree where 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 {punctuation = Just True} - longhand _ self "speak-as" [Ident "no-punctuation"] = Just self {punctuation = Just False} + 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 = parseVoice toks >>= \val -> Just self {voice = Just val} + 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 = parsePause toks >>= \val -> Just self {pauseBefore = val} - longhand _ self "pause-after" toks = parsePause toks >>= \val -> Just self {pauseAfter = val} - 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 "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" [String txt] = Just self {content = [Content txt]} - 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 "counter-reset" toks = (\val -> self {counterReset = val}) <$> parseCounters toks + longhand _ self "counter-increment" toks = (\val -> self {counterIncrement = val}) <$> parseCounters toks longhand _ self _ [Ident "inherit"] = Just self longhand _ _ _ _ = Nothing -- 2.30.2