3 files changed, 181 insertions(+), 8 deletions(-)

M src/Input.hs
M src/Links.hs
A src/Table.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' =

@@ 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

@@ 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 _ []     = []