2 files changed, 44 insertions(+), 36 deletions(-)

M src/DefaultCSS.hs
M src/Main.hs

@@ 9,30 9,30 @@ userAgentCSS = unlines [
   "button[type=button] {speak: never}",
   "button[formaction] {speak: always}",
   "",
-  "button::before, input[type=button]::before, input[type=submit]::before {",
-  "        content: 'Button';",
-  "        pitch: high;",
-  "}",
-  "select::before, textarea::before, input::before {content: 'Input'; pitch: high}",
-  "output::before {content: 'Output'; pitch: high}",
+--  "button::before, input[type=button]::before, input[type=submit]::before {",
+--  "        content: 'Button';",
+--  "        pitch: high;",
+--  "}",
+--  "select::before, textarea::before, input::before {content: 'Input'; pitch: high}",
+--  "output::before {content: 'Output'; pitch: high}",
   "text-area, button, select, input, output {pitch: low}",
-  "input, output {content: attr(value)}",
-  "text-area {speak-as: literal-punctuation}",
+--  "input, output {content: attr(value)}",
+--  "text-area {speak-as: literal-punctuation}",
   "",
-  "option:not([checked]) {speak: never}",
+--  "option:not([checked]) {speak: never}",
   "select[multiple] option {cue-before: url(bulletpoint.wav)}",
   "",
   "/* Forms themselves require a label in order to support navigation */",
-  "form::before {content: 'Form'}",
-  "form[action]::before {content: attr(action)}",
-  "form[alt]::before {content: attr(alt)}",
-  "form[title]::before {content: attr(title)}",
+--  "form::before {content: 'Form'}",
+--  "form[action]::before {content: attr(action)}",
+--  "form[alt]::before {content: attr(alt)}",
+--  "form[title]::before {content: attr(title)}",
   "",
   "/** Tables **/",
-  "table::before {content: 'Table'; voice-volume: x-soft}",
+--  "table::before {content: 'Table'; voice-volume: x-soft}",
   "tr {cue-before: url(bulletpoint.wav)}",
   "td, th {cue-before: url(bulletpoint.wav) -1db}",
-  "th::th /* Rhapsode-specific, selects inlined table headers */ {speak: never;}",
+--  "th::th /* Rhapsode-specific, selects inlined table headers */ {speak: never;}",
   "table caption {voice-volume: soft}",
   "",
   "/** Sectioning **/",


@@ 50,8 50,8 @@ userAgentCSS = unlines [
   "p, pre, samp, blockquote {pause: strong}",
   "pre, address, samp {speak-as: literal-punctuation}",
   "",
-  ":link {cue-before: url(link.wav); voice-rate: slow}",
-  ":link:visited {cue-before: url(link.wav) -1db}",
+--  ":link {cue-before: url(link.wav); voice-rate: slow}",
+--  ":link:visited {cue-before: url(link.wav) -1db}",
   "",
   "b, strong {voice-rate: x-slow}",
   "i, em {voice-stress: strong}",


@@ 78,29 78,29 @@ 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 ol ol ol li::before {",
-  "content: counters(-rhaps-ol1, -rhaps-ol2, -rhaps-ol3, -rhaps-ol4)",
-  "}",
-  "ol ol ol ol ol li::before {",
-  "content: counters(-rhaps-ol1, -rhaps-ol2, -rhaps-ol3, -rhaps-ol4, -rhaps-ol5)",
-  "}",
-  "ol ol ol ol ol ol li::before {",
-  "content: counters(-rhaps-ol1, -rhaps-ol2, -rhaps-ol3, -rhaps-ol4, -rhaps-ol5, -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 ol ol ol li::before {",
+--  "content: counters(-rhaps-ol1, -rhaps-ol2, -rhaps-ol3, -rhaps-ol4)",
+--  "}",
+--  "ol ol ol ol ol li::before {",
+--  "content: counters(-rhaps-ol1, -rhaps-ol2, -rhaps-ol3, -rhaps-ol4, -rhaps-ol5)",
+--  "}",
+--  "ol ol ol ol ol ol li::before {",
+--  "content: counters(-rhaps-ol1, -rhaps-ol2, -rhaps-ol3, -rhaps-ol4, -rhaps-ol5, -rhaps-ol6)",
+--  "}",
   "",
   "",
   "/** HTML6 **/",
-  "abbr[title]::after {content: attr(title); voice-volume: x-soft}",
+--  "abbr[title]::after {content: attr(title); voice-volume: x-soft}",
   "abbr {speak-as: spell-out}",
   "",
   "q, blockquote {voice-family: neutral 2}",
   "cite {voice-stress: reduce}",
-  "dialog:not([open]) {speak: never}",
+--  "dialog:not([open]) {speak: never}",
   "kbd {speak-as: spell-out}",
-  "progress {content: attr(value) 'of' attr(max)}",
+--  "progress {content: attr(value) 'of' attr(max)}"
   "sub {voice-rate: x-fast}",
   "sup {voice-rate: fast}",
   "var {voice-rate: slow}"

@@ 27,11 27,18 @@ main = do
     -- TODO support more URI schemes, and do nonblocking networking. This could be it's own module.
     request <- HTTP.parseRequest url
     manager <- HTTP.newManager TLS.tlsManagerSettings
+    putStrLn "Loading page..."
     response <- HTTP.httpLbs request manager
     let html = XML.documentRoot $ HTML.parseLBS $ HTTP.responseBody response
+    putStrLn "Loaded page!"
     style <- retreiveStyles html manager request
-    C8.putStrLn $ HTTP.responseBody response
+    C8.putStrLn $ renderElLBS $ stylizeEl style html
 
+renderElLBS el = XML.renderLBS XML.def $ XML.Document {
+        XML.documentPrologue = XML.Prologue [] Nothing [],
+        XML.documentRoot = el,
+        XML.documentEpilogue = []
+    }
 
 cssPriorityAgent = 1
 cssPriorityUser = 2


@@ 39,12 46,12 @@ cssPriorityAuthor = 3
 
 retreiveStyles html manager base = do
     css <- externalStyles html manager base
-    return $ authorStyle (css ++ internalStyles html)
+    return agentStyle -- $ authorStyle (css ++ internalStyles html) -- FIXME freezes
   where
-    emptyStyle :: Style.QueryableStyleSheet Style.TrivialPropertyParser
+    emptyStyle :: Style.QueryableStyleSheet MapPropertyParser
     emptyStyle = Style.queryableStyleSheet {Style.priority = cssPriorityAgent}
     agentStyle = CSS.parse emptyStyle $ Txt.pack userAgentCSS
-    authorStyle = foldl CSS.parse $ agentStyle {Style.priority = cssPriorityAuthor}
+    -- authorStyle = foldl CSS.parse $ agentStyle {Style.priority = cssPriorityAuthor}
 
 externalStyles html manager base = go $ linkedStyles html
     where -- TODO parallelise loads


@@ 97,6 104,7 @@ stylizeNodes up upStyle prev styles (XML.NodeElement el:nodes) =
     XML.NodeElement (stylizeEl' up upStyle prev styles el) :
         stylizeNodes up upStyle stylishEl styles nodes
     where stylishEl = Just $ elToStylish el up prev
+stylizeNodes a b c d (_:nodes) = stylizeNodes a b c d nodes
 stylizeNodes _ _ _ _ [] = []
 
 elToStylish (XML.Element (XML.Name name _ _) attrs _) parent previous =