M rhapsode.cabal => rhapsode.cabal +2 -2
@@ 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
M src/Render.hs => src/Render.hs +22 -69
@@ 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
--------
M src/SSML.hs => src/SSML.hs +79 -142
@@ 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
A src/SpeechStyle.hs => src/SpeechStyle.hs +191 -0
@@ 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
D src/StyleTree.hs => src/StyleTree.hs +0 -224
@@ 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
M src/Types.hs => src/Types.hs +3 -2
@@ 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)
M useragent.css => useragent.css +2 -1
@@ 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)}