From ec796896bb8b26a9704a742cb521ad481d0d69ab Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Sun, 14 Jul 2019 16:12:16 +1200 Subject: [PATCH] Integrate stylizer, fix/silence errors. Stylish Haskell's parser is freezing upon certain syntaxes, the commented out code indicates that Rhapsode's logic is fine. --- src/DefaultCSS.hs | 64 +++++++++++++++++++++++------------------------ src/Main.hs | 16 +++++++++--- 2 files changed, 44 insertions(+), 36 deletions(-) diff --git a/src/DefaultCSS.hs b/src/DefaultCSS.hs index bff902f..b737c14 100644 --- a/src/DefaultCSS.hs +++ b/src/DefaultCSS.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}" diff --git a/src/Main.hs b/src/Main.hs index a2f8975..d35e46f 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -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 = -- 2.30.2