From 3644420190043ddaf5c79212232a2772d1a086f8 Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Mon, 19 Apr 2021 17:09:35 +1200 Subject: [PATCH] Implement sortable tables (TODO attach aria-sort attrs). --- src/Input.hs | 10 +++- src/Links.hs | 45 ++++++++++++++--- src/Table.hs | 134 +++++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 181 insertions(+), 8 deletions(-) create mode 100644 src/Table.hs diff --git a/src/Input.hs b/src/Input.hs index b6dfbcc..d7b8ced 100644 --- a/src/Input.hs +++ b/src/Input.hs @@ -31,6 +31,8 @@ import System.Directory import System.FilePath (()) import Data.FileEmbed +import Table -- Apply table sorting here... + -- For C API import Types import Data.HTML2CSS (html2css) @@ -50,10 +52,14 @@ fetchDocument http referer mime URI { uriScheme = "app:", uriPath = appID } = do return referer -- TODO play an error or success sound fetchDocument http referer mime uri = fetchURL' http mime uri >>= parseDocument' referer http -parseDocument' ref@Page {visitedURLs = hist} sess resp@(_, mime, _) = do +parseDocument' ref@Page {visitedURLs = hist} sess resp@(URI {uriFragment = anchor}, mime, _) = do page <- parseDocument ref sess resp >>= logHistory hist apps' <- appsForMIME sess mime - return $ attachHistory $ page { pageMIME = mime, apps = apps' } + return $ attachHistory $ page { + pageMIME = mime, + apps = apps', + html = applySortDoc anchor $ html page + } where attachHistory x@Page { Types.url = uri'} | Types.url x == uri' = x | ((_, back):backs) <- backStack ref, back == uri' = diff --git a/src/Links.hs b/src/Links.hs index 072de13..9b0ce8b 100644 --- a/src/Links.hs +++ b/src/Links.hs @@ -9,6 +9,9 @@ import Data.Text (Text, unpack, append, pack, replace, strip) import qualified Data.Text.Lazy as LTxt import qualified Data.Text.Foreign as FTxt import Data.Maybe +import Text.Read (readMaybe) + +import Table (splitTable) import Types import Foreign.StablePtr @@ -66,12 +69,14 @@ extractEl _ el@(Element _ attrs []) -- in [Link (pack name) (pack title) uri] -- FIXME `mimeInfo` freezes... [Link typ "" uri] where attrs' = M.mapKeys nameLocalName attrs ---extractEl _ el@(Element (Name "link" _ _) attrs []) --- | Just "stylesheet" <- "rel" `M.lookup` attrs', Nothing <- "title" `M.lookup` attrs', --- Just val <- "href" `M.lookup` attrs', Just uri <- parseURIReference $ unpack val = --- let Application name _ title _ = mimeInfo "text/css" --- in [Link (pack name) (pack title) uri] --- where attrs' = M.mapKeys nameLocalName attrs +extractEl _ el@(Element (Name "link" _ _) attrs []) + | Just "stylesheet" <- "rel" `M.lookup` attrs', Nothing <- "title" `M.lookup` attrs', + Just val <- "href" `M.lookup` attrs', Just uri <- parseURIReference $ unpack val = + let Application name _ title _ = mimeInfo "text/css" + in [Link (pack name) (pack title) uri] + where attrs' = M.mapKeys nameLocalName attrs +extractEl path (Element (Name "table" _ _) _ childs) = + extractTable path (splitTable childs) ++ extractNodes (0:path) childs extractEl path el@(Element _ _ children) = extractElAttr el "href" ++ extractElAttr el "longdesc" ++ @@ -87,6 +92,34 @@ extractElAttr (Element _ attrs children) attr title' = fromMaybe "" $ M.lookup "title" attrs' attrs' = M.mapKeys nameLocalName attrs +extractTable path (thead, _, _) = extractTable' path [el | NodeElement el <- thead] +extractTable' path (Element (Name "thead" _ _) _ childs:_) = + extractTable' path [el | NodeElement el <- childs] +extractTable' path (Element (Name "tr" _ _) _ childs:_) = extractTR path 0 childs +extractTable' path (_:els) = extractTable' path els +extractTable' _ [] = [] + +extractTR path count (NodeElement (Element (Name name _ _) attrs childs):nodes) + | name `elem` ["th", "td"] = + extractTH path count ordering childs : extractTR path count' nodes + where + count' = count + fromMaybe 1 colspan + colspan = readMaybe =<< unpack <$> M.lookup "colspan" attrs' + ordering = M.lookup "aria-sort" attrs' + attrs' = M.mapKeys nameLocalName attrs +extractTR path count (_:nodes) = extractTR path count nodes +extractTR _ _ [] = [] +extractTH path count ordering nodes = Link { + label = nodesText nodes "", + title = pack $ show count, + href = nullURI { + uriFragment = '#': intercalate "." [show n | n <- path] ++ o ordering : show count + } + } + where + o (Just "ascending") = '>' + o _ = '<' + extractNodes p@(n:path) (NodeElement el:nodes) = extractEl p el ++ extractNodes (succ n:path) nodes extractNodes path (NodeInstruction instruct:nodes) = extractMisc [MiscInstruction instruct] ++ extractNodes path nodes diff --git a/src/Table.hs b/src/Table.hs new file mode 100644 index 0000000..fff6da1 --- /dev/null +++ b/src/Table.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE OverloadedStrings #-} +module Table(applySort, applySortDoc, splitTable) where + +import Text.XML +import Data.Text +import qualified Data.Map as M + +import Data.Maybe +import qualified Data.List as L +import Text.Read (readMaybe) + +applySortDoc :: String -> Document -> Document +applySortDoc anchor doc@Document {documentRoot = el} = doc {documentRoot = applySort anchor el} + +applySort :: String -> Element -> Element +applySort ('#':'-':'r':'h':'a':'p':'s':'-':'%':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 = header ++ + (L.concatMap (L.map NodeElement . markup) $ L.sortBy compareRows sortable) + ++ footer + } + | otherwise = el + where + compareRows (TableRow a _) (TableRow b _) + | asc = (a !! col) `compare` (b !! col) + | otherwise = (b !! col) `compare` (a !! col) + (header, _, footer) = splitTable $ elementNodes el + +data TableRow = TableRow { keys :: [Text], markup :: [Element] } + +table2sorttable Element { + elementName = Name "table" _ _, + elementAttributes = attrs, + elementNodes = childs + } | "-rhaps-unsortable" `elem` 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 [] = ([], []) + +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 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 _ [] = [] -- 2.30.2