5 files changed, 67 insertions(+), 29 deletions(-)

M rhapsode.cabal
M src/DefaultCSS.hs
M src/Main.hs
M src/SSML.hs
M src/StyleTree.hs

@@ 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

@@ 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)",
   "}",
   "",

@@ 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]}

@@ 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

@@ 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