M src/CExports.hs => src/CExports.hs +1 -1
@@ 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
M src/Input.hs => src/Input.hs +11 -67
@@ 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
D src/Main.hs => src/Main.hs +0 -174
@@ 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