From 5914c323239fac18fb72673ef9152dc76381f374 Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Mon, 6 Apr 2020 10:36:39 +1200 Subject: [PATCH] Remove dead code. --- src/CExports.hs | 2 +- src/Input.hs | 78 +++------------------- src/Main.hs | 174 ------------------------------------------------ 3 files changed, 12 insertions(+), 242 deletions(-) delete mode 100644 src/Main.hs diff --git a/src/CExports.hs b/src/CExports.hs index 768f62a..f25efd7 100644 --- a/src/CExports.hs +++ b/src/CExports.hs @@ -18,7 +18,7 @@ import System.Directory (getCurrentDirectory) -- default referer URI import Control.Concurrent.Async (forConcurrently, concurrently) import Data.Maybe (catMaybes, fromMaybe) -import Input (fetchURLs, fetchDocument, docForText) +import Input (fetchDocument, docForText) import Data.HTML2CSS (html2css) -- For c_renderDoc diff --git a/src/Input.hs b/src/Input.hs index 46f0788..c7749e5 100644 --- a/src/Input.hs +++ b/src/Input.hs @@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} -module Input(parseArgs, ProgramCtl(..), fetchURLs, fetchDocument, docForText) where +module Input(fetchDocument, docForText) where import Data.Text.Lazy (fromStrict) import qualified Data.Text as Txt @@ -27,72 +27,16 @@ import qualified Data.CSS.Syntax.Tokens as CSSTok import qualified Data.HTML2CSS as H2C import Network.URI.Charset ---- Commandline arguments -data ProgramCtl = ProgramCtl { - docs :: [(URI, XML.Document)], - outSSML :: Maybe Handle, - outLinks :: Maybe Handle -} -parseArgs :: Session -> IO ProgramCtl -parseArgs http = do - args <- getArgs - let (inputs, outputs) = partition (isPrefixOf "-" . fst) $ preparseArgs args - cwd <- getCurrentDirectory - let base = URI {uriScheme = "file:", uriPath = cwd, - uriAuthority = Nothing, uriQuery = "", uriFragment = ""} - let inputs' = [(f, relativeTo uri base) | (f, Just uri) <- inputs] - docs <- forConcurrently inputs' $ evalInput http - - outSSML <- parseSSMLout outputs - outLinks <- parseLinksOut outputs - return $ ProgramCtl { - docs = [(uri, doc) | ((_, uri), doc) <- zip inputs' docs], - outSSML = outSSML, - outLinks = outLinks - } - -preparseArgs (flag@('-':_):val:args) | Just url <- parseURIReference val = - (flag, Just url) : preparseArgs args -preparseArgs (flag@('+':_):args@(('+':_):_)) = (flag, Nothing) : preparseArgs args -preparseArgs (flag@('+':_):args@(('-':_):_)) = (flag, Nothing) : preparseArgs args -preparseArgs [flag@('+':_)] = [(flag, Nothing)] -preparseArgs (flag@('+':_):val:args) = (flag, parseURIReference val) : preparseArgs args -preparseArgs (val:args) | Just url <- parseURIReference val = - ("-h", Just url) : preparseArgs args -preparseArgs [] = [] -preparseArgs (arg:_) = error ("Unsupported argument " ++ arg) - -parseSSMLout (("+s", Just uri):_) = openFile (uriPath uri) WriteMode >>= return . Just -parseSSMLout (("+ssml", Just uri):_) = openFile (uriPath uri) WriteMode >>= return . Just -parseSSMLout (("+s", Nothing):_) = return $ Just stdout -parseSSMLout (("+ssml", Nothing):_) = return $ Just stdout -parseSSMLout (_:args) = parseSSMLout args -parseSSMLout [] = return Nothing - -parseLinksOut (("+l", Just uri):_) = openFile (uriPath uri) WriteMode >>= return . Just -parseLinksOut (("+links", Just uri):_) = openFile (uriPath uri) WriteMode >>= return . Just -parseLinksOut (("+l", Nothing):_) = return $ Just stdout -parseLinksOut (("+links", Nothing):_) = return $ Just stdout -parseLinksOut (_:args) = parseLinksOut args -parseLinksOut [] = return Nothing - - -evalInput http ("-h", url) = fetchDocument http ["text/html", "text/xml", "text/plain"] url -evalInput http ("-html", url) = fetchDocument http ["text/html", "text/xml", "text/plain"] url -evalInput http ("-x", url) = fetchDocument http ["text/xml", "text/html", "text/plain"] url -evalInput http ("-xml", url) = fetchDocument http ["text/xml", "text/html", "text/plain"] url -evalInput _ (flag, _) = error ("Unsupported input flag " ++ flag) - -fetchURLs session refererDoc refererURL srcs = forConcurrently srcs $ \(mime, url) -> do - let u = relativeTo url refererURL - let charsets' = map Txt.unpack charsets - resp <- fetchURL session mime u - (a, b) <- case resp of - ("text/css", bytes) -> let - cssParser = CSS.parseForURL (conditionalStyles u "document") u - in return (refererDoc, cssParser $ applyCSScharset charsets' bytes) - _ -> parseDocument session resp >>= \doc -> return (doc, H2C.html2css doc refererURL) - return (u, a, b) +--fetchURLs session refererDoc refererURL srcs = forConcurrently srcs $ \(mime, url) -> do +-- let u = relativeTo url refererURL +-- let charsets' = map Txt.unpack charsets +-- resp <- fetchURL session mime u +-- (a, b) <- case resp of +-- ("text/css", bytes) -> let +-- cssParser = CSS.parseForURL (conditionalStyles u "document") u +-- in return (refererDoc, cssParser $ applyCSScharset charsets' bytes) +-- _ -> parseDocument session resp >>= \doc -> return (doc, H2C.html2css doc refererURL) +-- return (u, a, b) applyCSScharset (charset:charsets) (Right bytes) | cssCharset (CSSTok.tokenize text) == Txt.pack charset = text diff --git a/src/Main.hs b/src/Main.hs deleted file mode 100644 index f95d0f7..0000000 --- a/src/Main.hs +++ /dev/null @@ -1,174 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Main where - -import qualified Data.ByteString.Lazy.Char8 as C8 -import qualified Data.ByteString.Lazy as B - -import qualified Text.XML as XML -import Data.Text as Txt (pack, unpack, Text(..), intercalate) - -import qualified Data.Map as M -import System.Directory as Dir -import Control.Monad -import System.IO (stdout, hPutStrLn) - --- To handle text encoding errors, whilst trying them out -import System.IO.Unsafe (unsafePerformIO) -import Control.Exception (catch, evaluate) -import Data.Text.Encoding.Error (UnicodeException) - ---- External Rhapsode subcomponents -import qualified Data.CSS.Syntax.StyleSheet as CSS -import qualified Data.CSS.Style as Style -import qualified Data.CSS.Syntax.Tokens as CSSTok -import qualified Data.CSS.Preprocessor.Conditions as CSSCond -import qualified Data.HTML2CSS as H2C -import Network.URI.Fetch -import Network.URI.Charset - --- Internal Rhapsode Subcomponents -import DefaultCSS -import StyleTree -import SSML -import Input -import Links -import CExports - -main :: IO () -main = do - http <- newSession - ProgramCtl docs outSSML outLinks <- parseArgs http - forM docs $ \(uri, doc) -> do - let html = XML.documentRoot doc - style <- retreiveStyles http $ H2C.html2css doc uri - - case (outLinks, outSSML) of - (Nothing, Nothing) -> C8.putStrLn $ renderDoc style html - (Just hLinks, Just hSSML) -> do - forM (extractLinks doc) (hPutStrLn hLinks . unpack . linkToText) - C8.hPutStrLn hSSML $ renderDoc style html - return () - (Just hLinks, Nothing) -> do - forM (extractLinks doc) (hPutStrLn hLinks . unpack . linkToText) - return () - (Nothing, Just hSSML) -> C8.hPutStrLn hSSML $ renderDoc style html - return () - -renderDoc style html = - renderElLBS $ styleToSSML $ applyCounters $ stylize style html - -renderElLBS el = XML.renderLBS XML.def $ XML.Document { - XML.documentPrologue = XML.Prologue [] Nothing [], - XML.documentRoot = el, - XML.documentEpilogue = [] - } - -retreiveStyles :: Session -> CSSCond.ConditionalStyles StyleTree -> IO (Style.QueryableStyleSheet (Style.VarParser StyleTree)) -retreiveStyles manager authorStyle = do - let agentStyle = H2C.cssPriorityAgent authorStyle `CSS.parse` Txt.pack userAgentCSS - userStyle <- loadUserStyles agentStyle - importedStyle <- CSSCond.loadImports loadURL lowerVars lowerToks userStyle [] - return $ CSSCond.resolve lowerVars lowerToks Style.queryableStyleSheet importedStyle - where - loadURL url = do - response <- fetchURL manager ["text/css"] url - let charsets' = map unpack charsets - return $ case response of - ("text/css", Left text) -> text - ("text/css", Right bytes) -> applyCSScharset charsets' $ B.toStrict bytes - (_, _) -> "" - - lowerVars "speech" = CSSCond.B True - lowerVars "-rhapsode" = CSSCond.B True - lowerVars _ = CSSCond.B False - lowerToks _ = CSSCond.B False - -applyCSScharset (charset:charsets) bytes - | cssCharset (CSSTok.tokenize text) == Txt.pack charset = text - | otherwise = applyCSScharset charsets bytes - where - text = convertCharset charset bytes -applyCSScharset _ bytes = convertCharset "utf-8" bytes -cssCharset toks | (CSSTok.AtKeyword "charset":toks') <- skipCSSspace toks, - (CSSTok.String charset:_) <- skipCSSspace toks' = charset - | otherwise = "" -skipCSSspace (CSSTok.Whitespace:toks) = skipCSSspace toks -skipCSSspace toks = toks - -loadUserStyles styles = do - dir <- Dir.getXdgDirectory Dir.XdgConfig "rhapsode" - exists <- Dir.doesDirectoryExist dir - loadDirectory dir exists - where - loadDirectory _ False = return styles - loadDirectory dir True = do - files <- Dir.listDirectory dir - loadFiles (H2C.cssPriorityUser styles) files - loadFiles style (file:files) = do - source <- readFile file - 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]} - --------- ----- 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 -- 2.30.2