hurl-xml 0.1.0.0 → 0.2.0.0
raw patch · 5 files changed
+579/−582 lines, 5 filesdep ~base
Dependency ranges changed: base
Files
- hurl-xml.cabal +3/−3
- src/Network/MIME/XML.hs +0/−368
- src/Network/MIME/XML/Table.hs +0/−211
- src/Network/URI/Fetch/XML.hs +365/−0
- src/Network/URI/Fetch/XML/Table.hs +211/−0
hurl-xml.cabal view
@@ -10,7 +10,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change-version: 0.1.0.0+version: 0.2.0.0 -- A short (one-line) description of the package. synopsis: Fetch parsed XML & possibly CSS for a URL based on MIMEtype.@@ -51,10 +51,10 @@ library -- Modules exported by the library.- exposed-modules: Network.MIME.XML+ exposed-modules: Network.URI.Fetch.XML, Network.URI.Fetch.XML.Table -- Modules included in this library but not exported.- other-modules: Network.MIME.XML.Table+ other-modules: -- LANGUAGE extensions used by modules in this package. -- other-extensions:
− src/Network/MIME/XML.hs
@@ -1,368 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE PatternSynonyms, ViewPatterns #-}-module Network.MIME.XML(Page(..), loadVisited,- fetchDocument, pageForText, applyCSScharset, readStrict) where--import Data.Text.Lazy (fromStrict)-import qualified Data.Text as Txt-import Data.Text (Text)-import qualified Data.Text.IO as Txt-import Data.Text.Encoding-import qualified Data.Text.Lazy as LTxt-import qualified Data.ByteString.Lazy as B-import qualified Text.HTML.DOM as HTML-import qualified Text.XML as XML-import Text.XML (Document(..))-import Network.URI-import Network.URI.Fetch-import Network.URI.Charset-import qualified Data.Map as M-import qualified Data.Set as Set-import Data.Set (Set(..))-import Data.List (intercalate)-import Data.Time.Clock---- For alternative styles-import qualified Data.CSS.Syntax.Tokens as CSSTok-import Stylist.Parse--import System.IO-import System.IO.Temp-import Data.Default.Class-import System.Directory-import System.FilePath ((</>))-import Data.FileEmbed-import Data.Maybe (fromMaybe)-import Text.Read (readMaybe)--import Network.MIME.XML.Table -- Apply table sorting here...-import Data.HTML2CSS (html2css)--data Page styles = Page {- pageURL :: URI,- css :: styles,- initCSS :: styles,- html :: Document,- pageTitle :: String,- pageMIME :: String,- apps :: [Application],- backStack :: [(String, URI)],- forwardStack :: [(String, URI)],- -- Probably don't need an MVar here, but let's be safe!- visitedURLs :: Set Text,- appName :: String-}--loadVisited :: String -> IO (Set Text)-loadVisited appname = do- dir <- getXdgDirectory XdgData appname- let path = dir </> "history.gmni"- exists <- doesFileExist path-- if exists then do- file <- readStrict path- let hist = Set.fromList [Txt.pack uri | _:uri:_ <- map words $ lines file]- return hist- else return Set.empty--readStrict path = do s <- Prelude.readFile path; length s `seq` return s--utf8' bytes = convertCharset "utf-8" $ B.toStrict bytes-aCCEPT = ["text/xml", "application/xml", "text/html", "text/gemini",- "text/csv", "text/tab-separated-values", "text/css", "text/*", "*/*"]--fetchDocument http referer URI { uriScheme = "action:", uriPath = "nocache" } =- fetchDocument http { cachingEnabled = False } referer $ pageURL referer-fetchDocument http referer URI { uriScheme = "action:", uriPath = "novalidate" } =- fetchDocument http { validateCertificates = False } referer $ pageURL referer-fetchDocument http referer URI { uriScheme = "action:", uriPath = "history/back" } =- fetchURL' http aCCEPT (pageURL referer') >>= parseDocument' referer' http False- where referer' = shiftHistory referer (-1)-fetchDocument http referer URI { uriScheme = "action:", uriPath = "history/forward" } =- fetchURL' http aCCEPT (pageURL referer') >>= parseDocument' referer' http False- where referer' = shiftHistory referer 1-fetchDocument http referer URI {- uriScheme = "action:", uriPath = 'h':'i':'s':'t':'o':'r':'y':'/':x- } | Just x' <- readMaybe x, referer' <- shiftHistory referer x' =- fetchURL' http aCCEPT (pageURL referer') >>= parseDocument' referer http False-fetchDocument http referer URI { uriScheme = "app:", uriPath = appID } = do- dispatchByApp http Application {- name = "", icon = nullURI, description = "",- appId = appID- } (pageMIME referer) $ pageURL referer- return referer -- TODO play an error or success sound-fetchDocument http referer@Page { pageURL = uri0 } uri@URI { uriFragment = anchor }- | uri { uriFragment = "" } == uri0 { uriFragment = "" } = return referer {- html = applySortDoc anchor $ html referer,- pageURL = uri- }-fetchDocument http referer uri = fetchURL' http aCCEPT uri >>= parseDocument' referer http True--shiftHistory :: Page style -> Integer -> Page style-shiftHistory self 0 = self-shiftHistory self@Page { backStack = (title, url):bs } delta | delta < 0 =- shiftHistory self {- backStack = bs,- forwardStack = (pageTitle self, pageURL self):forwardStack self,- pageTitle = title,- pageURL = url- } $ succ delta-shiftHistory self@Page { forwardStack = (title, url):fs } delta | delta > 0 =- shiftHistory self {- forwardStack = fs,- backStack = (pageTitle self, pageURL self):backStack self,- pageTitle = title,- pageURL = url- } $ pred delta-shiftHistory self _ = self -- Error case.--parseDocument' ref@Page {visitedURLs = hist} sess saveHist resp@(URI {uriFragment = anch}, mime, _) = do- page <- parseDocument ref sess resp >>= logHistory hist- apps' <- appsForMIME sess mime- return $ attachHistory page {- pageMIME = mime,- apps = apps',- html = applySortDoc anch $ html page- }- where- attachHistory x@Page { pageTitle = title, pageURL = url }- | saveHist = x { backStack = (title, url):backStack ref, forwardStack = forwardStack ref }- | otherwise = x-parseDocument :: StyleSheet s => Page s -> Session -> (URI, String, Either Text B.ByteString)- -> IO (Page s)-parseDocument ref sess (uri, "html/x-error\t", resp) = parseDocument ref sess (uri, "text/html", resp)-parseDocument Page {initCSS = css', appName = name} _ (uri, "text/html", Left text) =- pageForDoc css' name uri $ HTML.parseLT $ fromStrict text-parseDocument Page {initCSS = css', appName = name} _(uri, "text/html", Right bytes) =- pageForDoc css' name uri $ HTML.parseLBS bytes-parseDocument Page {initCSS = css', appName = name} _- (uri, 't':'e':'x':'t':'/':'g':'e':'m':'i':'n':'i':';':'l':'a':'n':'g':'=':lang, Left text) =- pageForDoc css' name uri $ parseGemini (Just lang) text-parseDocument Page {initCSS = css', appName = name} _- (uri, 't':'e':'x':'t':'/':'g':'e':'m':'i':'n':'i':';':'l':'a':'n':'g':'=':lang, Right bytes) =- pageForDoc css' name uri $ parseGemini (Just lang) $ utf8' bytes-parseDocument Page {initCSS = css', appName = name} _ (uri, "text/gemini", Left text) =- pageForDoc css' name uri $ parseGemini Nothing text-parseDocument Page {initCSS = css', appName = name} _ (uri, "text/gemini", Right bytes) =- pageForDoc css' name uri $ parseGemini Nothing $ utf8' bytes-parseDocument a b (a', b'@"text/css", Right bytes) =- parseDocument a b (a', b', Left $ applyCSScharset (map Txt.unpack charsets) $ B.toStrict bytes)-parseDocument referer@Page {pageURL = uri', initCSS = css', appName = name} _- (uri, "text/css", Left text)- | URI {uriAuthority = Just host} <- pageURL referer = do- -- Save this per-domain setting- dir <- (</> "domain") <$> getXdgDirectory XdgConfig name- createDirectoryIfMissing True dir- Txt.writeFile (dir </> uriRegName host) $- CSSTok.serialize $ map absolutizeCSS $ CSSTok.tokenize text-- return ret- | otherwise = return ret- where- ret = referer {- css = parseForURL css' uri text- }- absolutizeCSS (CSSTok.Url text) | Just rel <- parseRelativeReference $ Txt.unpack text =- CSSTok.Url $ Txt.pack $ uriToStr' $ relativeTo rel uri'- absolutizeCSS tok = tok-parseDocument ref@Page {initCSS = css', appName = name} _ (uri, "text/csv", Left body) =- pageForDoc css' name uri $ parseDelimitedToTable ',' body-parseDocument ref@Page {initCSS = css', appName = name} _ (uri, "text/tab-separated-values", Left body) =- pageForDoc css' name uri $ parseDelimitedToTable '\t' body-parseDocument ref@Page {initCSS = css', appName = name} _ (uri, "text/csv", Right body) =- pageForDoc css' name uri $ parseDelimitedToTable ',' $ utf8' body-parseDocument ref@Page {initCSS = css', appName = name} _- (uri, "text/tab-separated-values", Right body) =- pageForDoc css' name uri $ parseDelimitedToTable '\t' $ utf8' body--parseDocument ref sess (uri, mime, body) | mime' /= mime = parseDocument ref sess (uri, mime', body)- where mime' = takeWhile (/= ';') mime-parseDocument Page {initCSS = css', appName = name} _ (uri, _, Left text)- | Right doc <- XML.parseText def $ fromStrict text = pageForDoc css' name uri doc- | otherwise = pageForText css' name uri text-parseDocument Page {initCSS = css', appName = name} _ (uri, _, Right bytes)- | Right doc <- XML.parseLBS def bytes = pageForDoc css' name uri doc-parseDocument Page {initCSS = css', appName = name} _ (uri, 't':'e':'x':'t':'/':_, Right bytes) =- -- charset wasn't specified, so assume utf-8.- pageForText css' name uri $ utf8' bytes-parseDocument Page {initCSS = css', appName = name} sess resp@(uri, mime, _) = do- dir <- getCurrentDirectory -- TODO find Downloads directory.- ret <- saveDownload nullURI {- uriScheme = "file:",- uriAuthority = Just (URIAuth "" "" "")- } dir resp >>= dispatchByMIME sess mime- pageForDoc css' name uri $ HTML.parseLT $ LTxt.pack $ fromMaybe "Unsupported filetype" ret--pageForText css' appname uri txt = pageForDoc css' appname uri XML.Document {- XML.documentPrologue = XML.Prologue [] Nothing [],- XML.documentRoot = XML.Element {- XML.elementName = "pre",- XML.elementAttributes = M.empty,- XML.elementNodes = [XML.NodeContent txt]- },- XML.documentEpilogue = []- }--pageForDoc :: StyleSheet s => s -> String -> URI -> Document -> IO (Page s)-pageForDoc css' appname uri doc = do- -- See if the user has configured an alternate stylesheet for this domain.- let authorStyle = return $ html2css doc uri css'- styles <- case uriAuthority uri of- Nothing -> authorStyle- Just host -> do- dir <- getXdgDirectory XdgConfig appname- let path = dir </> "domain" </> uriRegName host- hasAltStyle <- doesFileExist path- if not hasAltStyle then authorStyle else parse css' <$> Txt.readFile path-- return Page {pageURL = uri, html = doc, css = styles,- initCSS = css', appName = appname,- -- These fields are all blank, to be filled in later by logHistory & parseDocument'- pageTitle = "", pageMIME = "", apps = [],- backStack = [], forwardStack = [], visitedURLs = Set.empty}--logHistory hist ret@Page {pageURL = url', html = doc, appName = name} = do- dir <- getXdgDirectory XdgData name- createDirectoryIfMissing True dir- now <- getCurrentTime- let title = Txt.unpack $ getTitle $ XML.documentRoot doc- appendFile (dir </> "history.gmni") $ '\n' : intercalate " " [- "=>", uriToStr' url', show now, title- ]-- return ret { pageTitle = title, visitedURLs = Set.insert (Txt.pack $ uriToStr' url') hist}- where- getTitle (XML.Element "title" _ childs) = Txt.concat [txt | XML.NodeContent txt <- childs]- getTitle (XML.Element "h1" _ childs) = Txt.concat [txt | XML.NodeContent txt <- childs]- getTitle (XML.Element _ _ childs)- | title:_ <- [getTitle el | XML.NodeElement el <- childs] = title- | otherwise = ""--uriToStr' :: URI -> String-uriToStr' uri = uriToString id uri ""--------------- CSS charset sniffing----------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--------------- Gemini implementation------------ Copied from css-syntax.-pattern (:.) :: Char -> Txt.Text -> Txt.Text-pattern x :. xs <- (Txt.uncons -> Just (x, xs))--infixr 5 :.--el name text = XML.Element name M.empty [XML.NodeContent text]--parseGemini :: Maybe String -> Txt.Text -> XML.Document-parseGemini lang txt = XML.Document {- XML.documentPrologue = XML.Prologue [] Nothing [],- XML.documentRoot = XML.Element {- XML.elementName = "body",- XML.elementAttributes = M.fromList [- ("lang", Txt.pack lang') | Just langs <- [lang], lang' <- [csv langs]],- XML.elementNodes = map XML.NodeElement $ parseGemini' $ Txt.lines txt- },- XML.documentEpilogue = []- }--csv (',':_) = ""-csv (c:rest) = c:csv rest-csv "" = ""--parseGemini' :: [Txt.Text] -> [XML.Element]-parseGemini' (('#':.'#':.'#' :. '#':.'#':.'#':.line):lines) =- el "h6" line : parseGemini' lines-parseGemini' (('#':.'#':.'#' :. '#':.'#':.line):lines) =- el "h5" line : parseGemini' lines-parseGemini' (('#':.'#':.'#' :. '#':.line):lines) =- el "h4" line : parseGemini' lines-parseGemini' (('#':.'#':.'#':.line):lines) = el "h3" line : parseGemini' lines-parseGemini' (('#':.'#':.line):lines) = el "h2" line : parseGemini' lines-parseGemini' (('#':.line):lines) = el "h1" line : parseGemini' lines--- Not properly structured, but still sounds fine...-parseGemini' (('*':.line):lines) = el "li" line : parseGemini' lines-parseGemini' (('>':.line):lines) = el "blockquote" line : parseGemini' lines--parseGemini' (('=':.'>':.line):lines)- | (url:text@(_:_)) <- Txt.words line = (el "a" $ Txt.unwords text) {- XML.elementAttributes = M.insert "href" url M.empty- } : parseGemini' lines- | otherwise = (el "a" $ Txt.strip line) {- XML.elementAttributes = M.insert "href" (Txt.strip line) M.empty- } : parseGemini' lines-parseGemini' (('`':.'`':.'`':.line):lines) = el "p" line : go lines- where- go (('`':.'`':.'`':._):lines) = parseGemini' lines- go (_:lines) = go lines- go [] = []-parseGemini' ("```":lines) = go [] lines- where- go texts (('`':.'`':.'`':._):lines) =- el "pre" (Txt.unlines texts) : parseGemini' lines- go texts (line:lines) = go (texts ++ [line]) lines- go texts [] = []--parseGemini' (line:lines) = el "p" line : parseGemini' lines-parseGemini' [] = []--------------- TSV, CSV, etc-----------parseDelimitedValues _ "" row rows = reverse (reverse row : rows)-parseDelimitedValues delim ('\r':.cs) row rows = parseDelimitedValues delim cs row rows-parseDelimitedValues delim ('\n':.cs) row rows = parseDelimitedValues delim cs [] (reverse row : rows)-parseDelimitedValues delim (c:.'"':.cs) row rows | c == delim =- let (value, cs') = inner cs in parseDelimitedValues delim cs' (value:row) rows- where- inner (x:.y:.cs) | x == delim && y == delim = let (a, b) = inner cs in (delim `Txt.cons` a, b)- inner (c:.cs) | c == delim = ("", cs)- | otherwise = let (a, b) = inner cs in (c `Txt.cons` a, b)- inner "" = ("", "")-parseDelimitedValues delim (c:.cs) row rows | c == delim =- let (value, cs') = Txt.break (`elem` ['\r', '\n', delim]) cs- in parseDelimitedValues delim cs' (value:row) rows-parseDelimitedValues delim cs row rows =- let (value, cs') = Txt.break (`elem` ['\r', '\n', delim]) cs- in parseDelimitedValues delim cs (value:row) rows--escapeDelimitedValues delim source = map (map inner) $ parseDelimitedValues delim source [] []- where- inner = Txt.strip . Txt.replace "\\\\" "\\" . Txt.replace "\\n" "\n" .- Txt.replace "\\t" "\t" . Txt.replace "\\r" "\r"--parseDelimitedToTable delim source- | (head:body) <- filter (not . null) $ escapeDelimitedValues delim source =- XML.Document {- XML.documentPrologue = XML.Prologue [] Nothing [],- XML.documentRoot = XML.Element {- XML.elementName = "table",- XML.elementAttributes = M.empty,- XML.elementNodes = rowToTr "th" head : map (rowToTr "td") body- },- XML.documentEpilogue = []- }- | otherwise = XML.Document { -- Empty TSV/CSV/etc- XML.documentPrologue = XML.Prologue [] Nothing [],- XML.documentRoot = XML.Element "table" M.empty [],- XML.documentEpilogue = []- }-rowToTr tagname values = XML.NodeElement $ XML.Element "tr" M.empty $ map inner values- where- inner = XML.NodeElement . XML.Element tagname M.empty . singleton . XML.NodeContent- singleton a = [a]
− src/Network/MIME/XML/Table.hs
@@ -1,211 +0,0 @@-{-# LANGUAGE OverloadedStrings, PatternSynonyms, ViewPatterns #-}-module Network.MIME.XML.Table(applySort, applySortDoc, splitTable) where--import Text.XML-import Data.Text as Txt-import qualified Data.Map as M--import Data.Maybe-import qualified Data.List as L-import Text.Read (readMaybe)---- For smarter comparisons...-import Data.Time.Format (parseTimeM, defaultTimeLocale)-import Data.Time.Clock (UTCTime)-import Data.Char (isDigit)--applySortDoc :: String -> Document -> Document-applySortDoc anchor doc@Document {documentRoot = el} = doc {documentRoot = applySort anchor el}--applySort :: String -> Element -> Element-applySort ('#':'-':'a':'r':'g':'o':'-':'%':anchor) el- | (id', ord:col) <- L.break (`elem` ['<', '>']) anchor, Just col' <- readMaybe col =- applySort' id' (ord == '<') col' el-applySort _ el = el--applySort' :: String -> Bool -> Int -> Element -> Element-applySort' ('.':id') asc col el@Element { elementNodes = childs }- | (ix, subpath) <- L.break (== '.') id', Just ix' <- readMaybe ix =- el { elementNodes = setAt ix' (rewriteNode subpath) childs }- | otherwise = el- where- rewriteNode p (NodeElement child) = NodeElement $ applySort' p asc col child- rewriteNode _ x = x-applySort' "" asc col el = applySort'' asc col el--applySort' id' asc col el@Element { elementAttributes = attrs, elementNodes = childs }- | Just actual <- "id" `M.lookup` M.mapKeys nameLocalName attrs, pack id' == actual =- applySort'' asc col el- | otherwise = el { elementNodes = L.map searchNode childs }- where- searchNode (NodeElement child) = NodeElement $ applySort' id' asc col child- searchNode x = x--applySort'' asc col el- | Just sortable <- table2sorttable el = el {- elementNodes = annotateTHead header asc col ++- (L.concatMap (L.map NodeElement . markup) $ L.sortBy compareRows sortable)- ++ footer- }- | otherwise = el- where- compareRows (TableRow a _) (TableRow b _)- | asc = compareAs (a !! col) (b !! col) (comparators !! col)- | otherwise = compareAs (b !! col) (a !! col) (comparators !! col)- (header, _, footer) = splitTable $ elementNodes el- comparators = tableHeadComparators header--data TableRow = TableRow { keys :: [Text], markup :: [Element] }--table2sorttable Element {- elementName = Name "table" _ _,- elementAttributes = attrs,- elementNodes = childs- } | "-argo-unsortable" `notElem` attrs, (_, body, _) <- splitTable childs =- trs2sorttable body-table2sorttable _ = Nothing--splitTable :: [Node] -> ([Node], [Element], [Node])-splitTable (NodeElement el@Element { elementName = Name "caption" _ _}:els) =- let (header, body, footer) = splitTable els in (NodeElement el:header, body, footer)-splitTable (NodeElement el@Element { elementName = Name "colgroup" _ _}:els) =- let (header, body, footer) = splitTable els in (NodeElement el:header, body, footer)-splitTable (NodeElement el@Element { elementName = Name "thead" _ _}:els) =- let (body, footer) = splitTableBody els in ([NodeElement el], body, footer)-splitTable (NodeElement el@Element { elementName = Name "tr" _ _, elementNodes = childs}:els)- | L.all (== "th") [nameLocalName $ elementName el | NodeElement el <- childs] =- let (body, footer) = splitTableBody els in ([NodeElement el], body, footer)-splitTable els@(NodeElement _:_) =- let (body, footer) = splitTableBody els in ([], body, footer)-splitTable (_:els) = splitTable els-splitTable [] = ([], [], [])--splitTableBody :: [Node] -> ([Element], [Node])-splitTableBody (NodeElement el@Element { elementName = Name "tbody" _ _, elementNodes = childs }:els) =- ([el | NodeElement el@Element { elementName = Name "tr" _ _ } <- childs], els)-splitTableBody (NodeElement el@Element { elementName = Name "tr" _ _ }:els) =- let (body, footer) = splitTableBody els in (el:body, footer)-splitTableBody els@(NodeElement _:_) = ([], els)-splitTableBody (_:els) = splitTableBody els-splitTableBody [] = ([], [])--tableHeadComparators :: [Node] -> [Text]-tableHeadComparators = Prelude.map (fromMaybe "alphanumeric") . tableHeadComparators'-tableHeadComparators' :: [Node] -> [Maybe Text]-tableHeadComparators' (NodeElement el@Element { elementName = Name name _ _, elementNodes = childs}:els)- | name == "thead" = tableHeadComparators' childs `mergeRight` tableHeadComparators' els- | name `elem` ["colgroup", "tr"] = tableRowComparators childs `mergeRight` tableHeadComparators' els- | otherwise = tableHeadComparators' els-tableHeadComparators' [] = []-tableRowComparators :: [Node] -> [Maybe Text]-tableRowComparators (NodeElement el@(Element (Name "col" _ _) attrs _):els) =- let colspan = fromMaybe 1 (M.lookup "span" attrs >>= readMaybe . unpack)- in Prelude.replicate colspan (M.lookup "-argo-sortas" attrs) ++ tableRowComparators els-tableRowComparators (NodeElement el@(Element (Name n _ _) attrs _):els) | n `elem` ["td", "th"] =- let colspan = fromMaybe 1 (M.lookup "colspan" attrs >>= readMaybe . unpack)- in Prelude.replicate colspan (M.lookup "-argo-sortas" attrs) ++ tableRowComparators els-tableRowComparators (_:els) = tableRowComparators els-tableRowComparators [] = []-mergeRight :: [Maybe a] -> [Maybe a] -> [Maybe a]-mergeRight (_:as) (Just b:bs) = Just b : mergeRight as bs-mergeRight (a:as) (_:bs) = a : mergeRight as bs-mergeRight [] bs = bs-mergeRight as [] = as--annotateTHead (NodeElement el@Element { elementName = Name "thead" _ _, elementNodes = childs }:nodes) a c =- NodeElement el { elementNodes = annotateTHead childs a c } : nodes-annotateTHead (NodeElement el@Element { elementName = Name "tr" _ _, elementNodes = childs }:nodes) a c =- NodeElement el { elementNodes = annotateTR childs a c 0 } : nodes-annotateTHead (child:childs) a c = child:annotateTHead childs a c-annotateTHead [] _ _ = []--annotateTR (NodeElement el@Element { elementName = Name n _ _, elementAttributes = attrs }:nodes) asc col count- | n `elem` ["th", "td"], count >= col =- NodeElement el { elementAttributes = M.insert "aria-sort" asc' attrs }:nodes- | n `elem` ["th", "td"] = NodeElement el:annotateTR nodes asc col (count + colspan)- where- colspan = fromMaybe 1 (readMaybe =<< unpack <$> M.lookup "colspan" attrs')- attrs' = M.mapKeys nameLocalName attrs- asc' | asc = "ascending"- | otherwise = "descending"-annotateTR (node:nodes) a c n = node:annotateTR nodes a c n-annotateTR [] _ _ _ = []--trs2sorttable els@(el@Element { elementName = Name "tr" _ _, elementNodes = childs }:_)- | Just keys' <- tds2keys [el | NodeElement el <- childs],- Just (group, rest) <- groupTrs els 1,- Just rest' <- trs2sorttable rest = Just (TableRow keys' group : rest')-trs2sorttable [] = Just []-trs2sorttable _ = Nothing--tds2keys :: [Element] -> Maybe [Text]-tds2keys (el@Element {elementName = Name n _ _, elementAttributes = attrs, elementNodes = childs }:els)- | n `elem` ["td", "th"], Just key <- "-argo-sortkey" `M.lookup` attrs, Just rest <- tds2keys els =- Just (Prelude.replicate colspan key ++ rest)- | n `elem` ["td", "th"], Just rest <- tds2keys els =- Just (Prelude.replicate colspan (nodesText childs) ++ rest)- where- colspan | Just n <- "colspan" `M.lookup` M.mapKeys nameLocalName attrs,- Just m <- readMaybe $ unpack n = m- | otherwise = 1-tds2keys [] = Just []-tds2keys _ = Nothing--groupTrs (el@Element {elementName = Name "tr" _ _}:els) n- | rowRowspan n el <= 1 = Just (el:[], els)- | Just (tail, rest) <- groupTrs els $ pred n = Just (el:tail, rest)-groupTrs (_:els) n = groupTrs els n-groupTrs _ _ = Nothing--rowRowspan n Element {elementName = Name "tr" _ _, elementNodes = childs } =- Prelude.maximum (n : [n |- NodeElement (Element (Name name _ _) attrs _) <- childs,- name `elem` ["td", "th"],- rowspan <- maybeToList ("rowspan" `M.lookup` M.mapKeys nameLocalName attrs),- n <- maybeToList $ readMaybe $ unpack rowspan])------ Utils--(+++) = append-nodesText :: [Node] -> Text-nodesText (NodeElement (Element _ attrs children):nodes) = nodesText children +++ nodesText nodes-nodesText (NodeContent text:nodes) = text +++ nodesText nodes-nodesText (_:nodes) = nodesText nodes-nodesText [] = ""--setAt :: Int -> (a -> a) -> [a] -> [a]-setAt i a ls- | i < 0 = ls- | otherwise = go i ls- where- go 0 (x:xs) = a x : xs- go n (x:xs) = x : go (n-1) xs- go _ [] = []--pattern (:.) :: Char -> Txt.Text -> Txt.Text-pattern x :. xs <- (Txt.uncons -> Just (x, xs))--infixr 5 :.--compareAs :: Text -> Text -> Text -> Ordering---- Hueristic that readily handles both numbers & text-compareAs (a:.as) (b:.bs) "alphanumeric"- | isDigit a && isDigit b =- let (a', as') = Txt.break (not . isDigit) as- (b', bs') = Txt.break (not . isDigit) bs- in if Txt.length a' == Txt.length b' && a == b- then compareAs as bs "alphanumeric"- else if Txt.length a' == Txt.length b' then a `compare` b- else Txt.length a' `compare` Txt.length b'- | a == b = compareAs as bs "alphanumeric"- | otherwise = a `compare` b-compareAs as bs "text" = as `compare` bs-compareAs as bs "number" = readInt as `compare` readInt bs- where- readInt :: Text -> Maybe Float- readInt = readMaybe . Prelude.filter (`elem` '-':'.':['0'..'9']) . unpack-compareAs as bs fmt = readTime as `compare` readTime bs- where- readTime :: Text -> Maybe UTCTime- readTime = parseTimeM True defaultTimeLocale (unpack fmt) . unpack
+ src/Network/URI/Fetch/XML.hs view
@@ -0,0 +1,365 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE PatternSynonyms, ViewPatterns #-}+module Network.URI.Fetch.XML(Page(..), loadVisited,+ fetchDocument, pageForText, applyCSScharset, readStrict) where++import Data.Text.Lazy (fromStrict)+import qualified Data.Text as Txt+import Data.Text (Text)+import qualified Data.Text.IO as Txt+import Data.Text.Encoding+import qualified Data.Text.Lazy as LTxt+import qualified Data.ByteString.Lazy as B+import qualified Text.HTML.DOM as HTML+import qualified Text.XML as XML+import Text.XML (Document(..))+import Network.URI+import Network.URI.Fetch+import Network.URI.Charset+import qualified Data.Map as M+import qualified Data.Set as Set+import Data.Set (Set(..))+import Data.List (intercalate)+import Data.Time.Clock++-- For alternative styles+import qualified Data.CSS.Syntax.Tokens as CSSTok+import Stylist.Parse++import System.IO+import System.IO.Temp+import Data.Default.Class+import System.Directory+import System.FilePath ((</>))+import Data.FileEmbed+import Data.Maybe (fromMaybe)+import Text.Read (readMaybe)++import Network.URI.Fetch.XML.Table -- Apply table sorting here...+import Data.HTML2CSS (html2css)++data Page styles = Page {+ pageURL :: URI,+ css :: styles,+ initCSS :: URI -> String -> styles,+ domain :: String,+ html :: Document,+ pageTitle :: String,+ pageMIME :: String,+ apps :: [Application],+ backStack :: [(String, URI)],+ forwardStack :: [(String, URI)],+ -- Probably don't need an MVar here, but let's be safe!+ visitedURLs :: Set Text,+ appName :: String+}++loadVisited :: String -> IO (Set Text)+loadVisited appname = do+ dir <- getXdgDirectory XdgData appname+ let path = dir </> "history.gmni"+ exists <- doesFileExist path++ if exists then do+ file <- readStrict path+ let hist = Set.fromList [Txt.pack uri | _:uri:_ <- map words $ lines file]+ return hist+ else return Set.empty++readStrict path = do s <- Prelude.readFile path; length s `seq` return s++utf8' bytes = convertCharset "utf-8" $ B.toStrict bytes+aCCEPT = ["text/xml", "application/xml", "text/html", "text/gemini",+ "text/csv", "text/tab-separated-values", "text/css", "text/*", "*/*"]++fetchDocument http referer URI { uriScheme = "action:", uriPath = "nocache" } =+ fetchDocument http { cachingEnabled = False } referer $ pageURL referer+fetchDocument http referer URI { uriScheme = "action:", uriPath = "novalidate" } =+ fetchDocument http { validateCertificates = False } referer $ pageURL referer+fetchDocument http referer URI { uriScheme = "action:", uriPath = "history/back" } =+ fetchURL' http aCCEPT (pageURL referer') >>= parseDocument' referer' http False+ where referer' = shiftHistory referer (-1)+fetchDocument http referer URI { uriScheme = "action:", uriPath = "history/forward" } =+ fetchURL' http aCCEPT (pageURL referer') >>= parseDocument' referer' http False+ where referer' = shiftHistory referer 1+fetchDocument http referer URI {+ uriScheme = "action:", uriPath = 'h':'i':'s':'t':'o':'r':'y':'/':x+ } | Just x' <- readMaybe x, referer' <- shiftHistory referer x' =+ fetchURL' http aCCEPT (pageURL referer') >>= parseDocument' referer http False+fetchDocument http referer URI { uriScheme = "app:", uriPath = appID } = do+ dispatchByApp http Application {+ name = "", icon = nullURI, description = "",+ appId = appID+ } (pageMIME referer) $ pageURL referer+ return referer -- TODO play an error or success sound+fetchDocument http referer@Page { pageURL = uri0 } uri@URI { uriFragment = anchor }+ | uri { uriFragment = "" } == uri0 { uriFragment = "" } = return referer {+ html = applySortDoc anchor $ html referer,+ pageURL = uri+ }+fetchDocument http referer uri = fetchURL' http aCCEPT uri >>= parseDocument' referer http True++shiftHistory :: Page style -> Integer -> Page style+shiftHistory self 0 = self+shiftHistory self@Page { backStack = (title, url):bs } delta | delta < 0 =+ shiftHistory self {+ backStack = bs,+ forwardStack = (pageTitle self, pageURL self):forwardStack self,+ pageTitle = title,+ pageURL = url+ } $ succ delta+shiftHistory self@Page { forwardStack = (title, url):fs } delta | delta > 0 =+ shiftHistory self {+ forwardStack = fs,+ backStack = (pageTitle self, pageURL self):backStack self,+ pageTitle = title,+ pageURL = url+ } $ pred delta+shiftHistory self _ = self -- Error case.++parseDocument' ref@Page {visitedURLs = hist} sess saveHist resp@(URI {uriFragment = anch}, mime, _) = do+ page <- parseDocument ref {domain = "document"} sess resp >>= logHistory hist+ apps' <- appsForMIME sess mime+ return $ attachHistory page {+ pageMIME = mime,+ apps = apps',+ html = applySortDoc anch $ html page+ }+ where+ attachHistory x@Page { pageTitle = title, pageURL = url }+ | saveHist = x { backStack = (title, url):backStack ref, forwardStack = forwardStack ref }+ | otherwise = x+parseDocument :: StyleSheet s => Page s -> Session -> (URI, String, Either Text B.ByteString)+ -> IO (Page s)+parseDocument ref sess (uri, "html/x-error\t", resp) =+ parseDocument ref { domain = "error" } sess (uri, "text/html", resp)+parseDocument p _ (uri, "text/html", Left text) =+ pageForDoc p uri $ HTML.parseLT $ fromStrict text+parseDocument p _(uri, "text/html", Right bytes) =+ pageForDoc p uri $ HTML.parseLBS bytes+parseDocument p _+ (uri, 't':'e':'x':'t':'/':'g':'e':'m':'i':'n':'i':';':'l':'a':'n':'g':'=':lang, Left text) =+ pageForDoc p uri $ parseGemini (Just lang) text+parseDocument p _+ (uri, 't':'e':'x':'t':'/':'g':'e':'m':'i':'n':'i':';':'l':'a':'n':'g':'=':lang, Right bytes) =+ pageForDoc p uri $ parseGemini (Just lang) $ utf8' bytes+parseDocument p _ (uri, "text/gemini", Left text) =+ pageForDoc p uri $ parseGemini Nothing text+parseDocument p _ (uri, "text/gemini", Right bytes) =+ pageForDoc p uri $ parseGemini Nothing $ utf8' bytes+parseDocument a b (a', b'@"text/css", Right bytes) =+ parseDocument a b (a', b', Left $ applyCSScharset (map Txt.unpack charsets) $ B.toStrict bytes)+parseDocument referer@Page {pageURL = uri', initCSS = css', appName = name} _+ (uri, "text/css", Left text)+ | URI {uriAuthority = Just host} <- pageURL referer = do+ -- Save this per-domain setting+ dir <- (</> "domain") <$> getXdgDirectory XdgConfig name+ createDirectoryIfMissing True dir+ Txt.writeFile (dir </> uriRegName host) $+ CSSTok.serialize $ map absolutizeCSS $ CSSTok.tokenize text++ return ret+ | otherwise = return ret+ where+ ret = referer {+ css = parseForURL (css' uri' "document") uri text+ }+ absolutizeCSS (CSSTok.Url text) | Just rel <- parseRelativeReference $ Txt.unpack text =+ CSSTok.Url $ Txt.pack $ uriToStr' $ relativeTo rel uri'+ absolutizeCSS tok = tok+parseDocument ref _ (uri, "text/csv", Left body) =+ pageForDoc ref uri $ parseDelimitedToTable ',' body+parseDocument ref _ (uri, "text/tab-separated-values", Left body) =+ pageForDoc ref uri $ parseDelimitedToTable '\t' body+parseDocument ref _ (uri, "text/csv", Right body) =+ pageForDoc ref uri $ parseDelimitedToTable ',' $ utf8' body+parseDocument ref _ (uri, "text/tab-separated-values", Right body) =+ pageForDoc ref uri $ parseDelimitedToTable '\t' $ utf8' body++parseDocument ref sess (uri, mime, body) | mime' /= mime = parseDocument ref sess (uri, mime', body)+ where mime' = takeWhile (/= ';') mime+parseDocument p _ (uri, _, Left text)+ | Right doc <- XML.parseText def $ fromStrict text = pageForDoc p uri doc+ | otherwise = pageForText p uri text+parseDocument p _ (uri, _, Right bytes)+ | Right doc <- XML.parseLBS def bytes = pageForDoc p uri doc+parseDocument p _ (uri, 't':'e':'x':'t':'/':_, Right bytes) =+ -- charset wasn't specified, so assume utf-8.+ pageForText p uri $ utf8' bytes+parseDocument p sess resp@(uri, mime, _) = do+ dir <- getCurrentDirectory -- TODO find Downloads directory.+ ret <- saveDownload nullURI {+ uriScheme = "file:",+ uriAuthority = Just (URIAuth "" "" "")+ } dir resp >>= dispatchByMIME sess mime+ pageForDoc p uri $ HTML.parseLT $ LTxt.pack $ fromMaybe "Unsupported filetype" ret++pageForText referer uri txt = pageForDoc referer uri XML.Document {+ XML.documentPrologue = XML.Prologue [] Nothing [],+ XML.documentRoot = XML.Element {+ XML.elementName = "pre",+ XML.elementAttributes = M.empty,+ XML.elementNodes = [XML.NodeContent txt]+ },+ XML.documentEpilogue = []+ }++pageForDoc :: StyleSheet s => Page s -> URI -> Document -> IO (Page s)+pageForDoc referer@Page {initCSS = css', appName = appname, domain = d} uri doc = do+ -- See if the user has configured an alternate stylesheet for this domain.+ let authorStyle = return $ html2css doc uri $ css' uri d+ styles <- case uriAuthority uri of+ Nothing -> authorStyle+ Just host -> do+ dir <- getXdgDirectory XdgConfig appname+ let path = dir </> "domain" </> uriRegName host+ hasAltStyle <- doesFileExist path+ if not hasAltStyle then authorStyle else parse (css' uri d) <$> Txt.readFile path++ return referer {pageURL = uri, html = doc, css = styles}++logHistory hist ret@Page {pageURL = url', html = doc, appName = name} = do+ dir <- getXdgDirectory XdgData name+ createDirectoryIfMissing True dir+ now <- getCurrentTime+ let title = Txt.unpack $ getTitle $ XML.documentRoot doc+ appendFile (dir </> "history.gmni") $ '\n' : intercalate " " [+ "=>", uriToStr' url', show now, title+ ]++ return ret { pageTitle = title, visitedURLs = Set.insert (Txt.pack $ uriToStr' url') hist}+ where+ getTitle (XML.Element "title" _ childs) = Txt.concat [txt | XML.NodeContent txt <- childs]+ getTitle (XML.Element "h1" _ childs) = Txt.concat [txt | XML.NodeContent txt <- childs]+ getTitle (XML.Element _ _ childs)+ | title:_ <- [getTitle el | XML.NodeElement el <- childs] = title+ | otherwise = ""++uriToStr' :: URI -> String+uriToStr' uri = uriToString id uri ""++--------+---- CSS charset sniffing+--------+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++--------+---- Gemini implementation+--------+-- Copied from css-syntax.+pattern (:.) :: Char -> Txt.Text -> Txt.Text+pattern x :. xs <- (Txt.uncons -> Just (x, xs))++infixr 5 :.++el name text = XML.Element name M.empty [XML.NodeContent text]++parseGemini :: Maybe String -> Txt.Text -> XML.Document+parseGemini lang txt = XML.Document {+ XML.documentPrologue = XML.Prologue [] Nothing [],+ XML.documentRoot = XML.Element {+ XML.elementName = "body",+ XML.elementAttributes = M.fromList [+ ("lang", Txt.pack lang') | Just langs <- [lang], lang' <- [csv langs]],+ XML.elementNodes = map XML.NodeElement $ parseGemini' $ Txt.lines txt+ },+ XML.documentEpilogue = []+ }++csv (',':_) = ""+csv (c:rest) = c:csv rest+csv "" = ""++parseGemini' :: [Txt.Text] -> [XML.Element]+parseGemini' (('#':.'#':.'#' :. '#':.'#':.'#':.line):lines) =+ el "h6" line : parseGemini' lines+parseGemini' (('#':.'#':.'#' :. '#':.'#':.line):lines) =+ el "h5" line : parseGemini' lines+parseGemini' (('#':.'#':.'#' :. '#':.line):lines) =+ el "h4" line : parseGemini' lines+parseGemini' (('#':.'#':.'#':.line):lines) = el "h3" line : parseGemini' lines+parseGemini' (('#':.'#':.line):lines) = el "h2" line : parseGemini' lines+parseGemini' (('#':.line):lines) = el "h1" line : parseGemini' lines+-- Not properly structured, but still sounds fine...+parseGemini' (('*':.line):lines) = el "li" line : parseGemini' lines+parseGemini' (('>':.line):lines) = el "blockquote" line : parseGemini' lines++parseGemini' (('=':.'>':.line):lines)+ | (url:text@(_:_)) <- Txt.words line = (el "a" $ Txt.unwords text) {+ XML.elementAttributes = M.insert "href" url M.empty+ } : parseGemini' lines+ | otherwise = (el "a" $ Txt.strip line) {+ XML.elementAttributes = M.insert "href" (Txt.strip line) M.empty+ } : parseGemini' lines+parseGemini' (('`':.'`':.'`':.line):lines) = el "p" line : go lines+ where+ go (('`':.'`':.'`':._):lines) = parseGemini' lines+ go (_:lines) = go lines+ go [] = []+parseGemini' ("```":lines) = go [] lines+ where+ go texts (('`':.'`':.'`':._):lines) =+ el "pre" (Txt.unlines texts) : parseGemini' lines+ go texts (line:lines) = go (texts ++ [line]) lines+ go texts [] = []++parseGemini' (line:lines) = el "p" line : parseGemini' lines+parseGemini' [] = []++--------+---- TSV, CSV, etc+--------++parseDelimitedValues _ "" row rows = reverse (reverse row : rows)+parseDelimitedValues delim ('\r':.cs) row rows = parseDelimitedValues delim cs row rows+parseDelimitedValues delim ('\n':.cs) row rows = parseDelimitedValues delim cs [] (reverse row : rows)+parseDelimitedValues delim (c:.'"':.cs) row rows | c == delim =+ let (value, cs') = inner cs in parseDelimitedValues delim cs' (value:row) rows+ where+ inner (x:.y:.cs) | x == delim && y == delim = let (a, b) = inner cs in (delim `Txt.cons` a, b)+ inner (c:.cs) | c == delim = ("", cs)+ | otherwise = let (a, b) = inner cs in (c `Txt.cons` a, b)+ inner "" = ("", "")+parseDelimitedValues delim (c:.cs) row rows | c == delim =+ let (value, cs') = Txt.break (`elem` ['\r', '\n', delim]) cs+ in parseDelimitedValues delim cs' (value:row) rows+parseDelimitedValues delim cs row rows =+ let (value, cs') = Txt.break (`elem` ['\r', '\n', delim]) cs+ in parseDelimitedValues delim cs (value:row) rows++escapeDelimitedValues delim source = map (map inner) $ parseDelimitedValues delim source [] []+ where+ inner = Txt.strip . Txt.replace "\\\\" "\\" . Txt.replace "\\n" "\n" .+ Txt.replace "\\t" "\t" . Txt.replace "\\r" "\r"++parseDelimitedToTable delim source+ | (head:body) <- filter (not . null) $ escapeDelimitedValues delim source =+ XML.Document {+ XML.documentPrologue = XML.Prologue [] Nothing [],+ XML.documentRoot = XML.Element {+ XML.elementName = "table",+ XML.elementAttributes = M.empty,+ XML.elementNodes = rowToTr "th" head : map (rowToTr "td") body+ },+ XML.documentEpilogue = []+ }+ | otherwise = XML.Document { -- Empty TSV/CSV/etc+ XML.documentPrologue = XML.Prologue [] Nothing [],+ XML.documentRoot = XML.Element "table" M.empty [],+ XML.documentEpilogue = []+ }+rowToTr tagname values = XML.NodeElement $ XML.Element "tr" M.empty $ map inner values+ where+ inner = XML.NodeElement . XML.Element tagname M.empty . singleton . XML.NodeContent+ singleton a = [a]
+ src/Network/URI/Fetch/XML/Table.hs view
@@ -0,0 +1,211 @@+{-# LANGUAGE OverloadedStrings, PatternSynonyms, ViewPatterns #-}+module Network.URI.Fetch.XML.Table(applySort, applySortDoc, splitTable) where++import Text.XML+import Data.Text as Txt+import qualified Data.Map as M++import Data.Maybe+import qualified Data.List as L+import Text.Read (readMaybe)++-- For smarter comparisons...+import Data.Time.Format (parseTimeM, defaultTimeLocale)+import Data.Time.Clock (UTCTime)+import Data.Char (isDigit)++applySortDoc :: String -> Document -> Document+applySortDoc anchor doc@Document {documentRoot = el} = doc {documentRoot = applySort anchor el}++applySort :: String -> Element -> Element+applySort ('#':'-':'a':'r':'g':'o':'-':'%':anchor) el+ | (id', ord:col) <- L.break (`elem` ['<', '>']) anchor, Just col' <- readMaybe col =+ applySort' id' (ord == '<') col' el+applySort _ el = el++applySort' :: String -> Bool -> Int -> Element -> Element+applySort' ('.':id') asc col el@Element { elementNodes = childs }+ | (ix, subpath) <- L.break (== '.') id', Just ix' <- readMaybe ix =+ el { elementNodes = setAt ix' (rewriteNode subpath) childs }+ | otherwise = el+ where+ rewriteNode p (NodeElement child) = NodeElement $ applySort' p asc col child+ rewriteNode _ x = x+applySort' "" asc col el = applySort'' asc col el++applySort' id' asc col el@Element { elementAttributes = attrs, elementNodes = childs }+ | Just actual <- "id" `M.lookup` M.mapKeys nameLocalName attrs, pack id' == actual =+ applySort'' asc col el+ | otherwise = el { elementNodes = L.map searchNode childs }+ where+ searchNode (NodeElement child) = NodeElement $ applySort' id' asc col child+ searchNode x = x++applySort'' asc col el+ | Just sortable <- table2sorttable el = el {+ elementNodes = annotateTHead header asc col +++ (L.concatMap (L.map NodeElement . markup) $ L.sortBy compareRows sortable)+ ++ footer+ }+ | otherwise = el+ where+ compareRows (TableRow a _) (TableRow b _)+ | asc = compareAs (a !! col) (b !! col) (comparators !! col)+ | otherwise = compareAs (b !! col) (a !! col) (comparators !! col)+ (header, _, footer) = splitTable $ elementNodes el+ comparators = tableHeadComparators header++data TableRow = TableRow { keys :: [Text], markup :: [Element] }++table2sorttable Element {+ elementName = Name "table" _ _,+ elementAttributes = attrs,+ elementNodes = childs+ } | "-argo-unsortable" `notElem` attrs, (_, body, _) <- splitTable childs =+ trs2sorttable body+table2sorttable _ = Nothing++splitTable :: [Node] -> ([Node], [Element], [Node])+splitTable (NodeElement el@Element { elementName = Name "caption" _ _}:els) =+ let (header, body, footer) = splitTable els in (NodeElement el:header, body, footer)+splitTable (NodeElement el@Element { elementName = Name "colgroup" _ _}:els) =+ let (header, body, footer) = splitTable els in (NodeElement el:header, body, footer)+splitTable (NodeElement el@Element { elementName = Name "thead" _ _}:els) =+ let (body, footer) = splitTableBody els in ([NodeElement el], body, footer)+splitTable (NodeElement el@Element { elementName = Name "tr" _ _, elementNodes = childs}:els)+ | L.all (== "th") [nameLocalName $ elementName el | NodeElement el <- childs] =+ let (body, footer) = splitTableBody els in ([NodeElement el], body, footer)+splitTable els@(NodeElement _:_) =+ let (body, footer) = splitTableBody els in ([], body, footer)+splitTable (_:els) = splitTable els+splitTable [] = ([], [], [])++splitTableBody :: [Node] -> ([Element], [Node])+splitTableBody (NodeElement el@Element { elementName = Name "tbody" _ _, elementNodes = childs }:els) =+ ([el | NodeElement el@Element { elementName = Name "tr" _ _ } <- childs], els)+splitTableBody (NodeElement el@Element { elementName = Name "tr" _ _ }:els) =+ let (body, footer) = splitTableBody els in (el:body, footer)+splitTableBody els@(NodeElement _:_) = ([], els)+splitTableBody (_:els) = splitTableBody els+splitTableBody [] = ([], [])++tableHeadComparators :: [Node] -> [Text]+tableHeadComparators = Prelude.map (fromMaybe "alphanumeric") . tableHeadComparators'+tableHeadComparators' :: [Node] -> [Maybe Text]+tableHeadComparators' (NodeElement el@Element { elementName = Name name _ _, elementNodes = childs}:els)+ | name == "thead" = tableHeadComparators' childs `mergeRight` tableHeadComparators' els+ | name `elem` ["colgroup", "tr"] = tableRowComparators childs `mergeRight` tableHeadComparators' els+ | otherwise = tableHeadComparators' els+tableHeadComparators' [] = []+tableRowComparators :: [Node] -> [Maybe Text]+tableRowComparators (NodeElement el@(Element (Name "col" _ _) attrs _):els) =+ let colspan = fromMaybe 1 (M.lookup "span" attrs >>= readMaybe . unpack)+ in Prelude.replicate colspan (M.lookup "-argo-sortas" attrs) ++ tableRowComparators els+tableRowComparators (NodeElement el@(Element (Name n _ _) attrs _):els) | n `elem` ["td", "th"] =+ let colspan = fromMaybe 1 (M.lookup "colspan" attrs >>= readMaybe . unpack)+ in Prelude.replicate colspan (M.lookup "-argo-sortas" attrs) ++ tableRowComparators els+tableRowComparators (_:els) = tableRowComparators els+tableRowComparators [] = []+mergeRight :: [Maybe a] -> [Maybe a] -> [Maybe a]+mergeRight (_:as) (Just b:bs) = Just b : mergeRight as bs+mergeRight (a:as) (_:bs) = a : mergeRight as bs+mergeRight [] bs = bs+mergeRight as [] = as++annotateTHead (NodeElement el@Element { elementName = Name "thead" _ _, elementNodes = childs }:nodes) a c =+ NodeElement el { elementNodes = annotateTHead childs a c } : nodes+annotateTHead (NodeElement el@Element { elementName = Name "tr" _ _, elementNodes = childs }:nodes) a c =+ NodeElement el { elementNodes = annotateTR childs a c 0 } : nodes+annotateTHead (child:childs) a c = child:annotateTHead childs a c+annotateTHead [] _ _ = []++annotateTR (NodeElement el@Element { elementName = Name n _ _, elementAttributes = attrs }:nodes) asc col count+ | n `elem` ["th", "td"], count >= col =+ NodeElement el { elementAttributes = M.insert "aria-sort" asc' attrs }:nodes+ | n `elem` ["th", "td"] = NodeElement el:annotateTR nodes asc col (count + colspan)+ where+ colspan = fromMaybe 1 (readMaybe =<< unpack <$> M.lookup "colspan" attrs')+ attrs' = M.mapKeys nameLocalName attrs+ asc' | asc = "ascending"+ | otherwise = "descending"+annotateTR (node:nodes) a c n = node:annotateTR nodes a c n+annotateTR [] _ _ _ = []++trs2sorttable els@(el@Element { elementName = Name "tr" _ _, elementNodes = childs }:_)+ | Just keys' <- tds2keys [el | NodeElement el <- childs],+ Just (group, rest) <- groupTrs els 1,+ Just rest' <- trs2sorttable rest = Just (TableRow keys' group : rest')+trs2sorttable [] = Just []+trs2sorttable _ = Nothing++tds2keys :: [Element] -> Maybe [Text]+tds2keys (el@Element {elementName = Name n _ _, elementAttributes = attrs, elementNodes = childs }:els)+ | n `elem` ["td", "th"], Just key <- "-argo-sortkey" `M.lookup` attrs, Just rest <- tds2keys els =+ Just (Prelude.replicate colspan key ++ rest)+ | n `elem` ["td", "th"], Just rest <- tds2keys els =+ Just (Prelude.replicate colspan (nodesText childs) ++ rest)+ where+ colspan | Just n <- "colspan" `M.lookup` M.mapKeys nameLocalName attrs,+ Just m <- readMaybe $ unpack n = m+ | otherwise = 1+tds2keys [] = Just []+tds2keys _ = Nothing++groupTrs (el@Element {elementName = Name "tr" _ _}:els) n+ | rowRowspan n el <= 1 = Just (el:[], els)+ | Just (tail, rest) <- groupTrs els $ pred n = Just (el:tail, rest)+groupTrs (_:els) n = groupTrs els n+groupTrs _ _ = Nothing++rowRowspan n Element {elementName = Name "tr" _ _, elementNodes = childs } =+ Prelude.maximum (n : [n |+ NodeElement (Element (Name name _ _) attrs _) <- childs,+ name `elem` ["td", "th"],+ rowspan <- maybeToList ("rowspan" `M.lookup` M.mapKeys nameLocalName attrs),+ n <- maybeToList $ readMaybe $ unpack rowspan])+++--- Utils++(+++) = append+nodesText :: [Node] -> Text+nodesText (NodeElement (Element _ attrs children):nodes) = nodesText children +++ nodesText nodes+nodesText (NodeContent text:nodes) = text +++ nodesText nodes+nodesText (_:nodes) = nodesText nodes+nodesText [] = ""++setAt :: Int -> (a -> a) -> [a] -> [a]+setAt i a ls+ | i < 0 = ls+ | otherwise = go i ls+ where+ go 0 (x:xs) = a x : xs+ go n (x:xs) = x : go (n-1) xs+ go _ [] = []++pattern (:.) :: Char -> Txt.Text -> Txt.Text+pattern x :. xs <- (Txt.uncons -> Just (x, xs))++infixr 5 :.++compareAs :: Text -> Text -> Text -> Ordering+--- Hueristic that readily handles both numbers & text+compareAs (a:.as) (b:.bs) "alphanumeric"+ | isDigit a && isDigit b =+ let (a', as') = Txt.break (not . isDigit) as+ (b', bs') = Txt.break (not . isDigit) bs+ in if Txt.length a' == Txt.length b' && a == b+ then compareAs as bs "alphanumeric"+ else if Txt.length a' == Txt.length b' then a `compare` b+ else Txt.length a' `compare` Txt.length b'+ | a == b = compareAs as bs "alphanumeric"+ | otherwise = a `compare` b+compareAs as bs "text" = as `compare` bs+compareAs as bs "number" = readInt as `compare` readInt bs+ where+ readInt :: Text -> Maybe Float+ readInt = readMaybe . Prelude.filter (`elem` '-':'.':['0'..'9']) . unpack+compareAs as bs fmt = readTime as `compare` readTime bs+ where+ readTime :: Text -> Maybe UTCTime+ readTime = parseTimeM True defaultTimeLocale (unpack fmt) . unpack