{-# 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 :: String -> Document -> Document
applySortDoc anchor :: String
anchor doc :: Document
doc@Document {documentRoot :: Document -> Element
documentRoot = Element
el} = Document
doc {documentRoot :: Element
documentRoot = String -> Element -> Element
applySort String
anchor Element
el}

applySort :: String -> Element -> Element
applySort :: String -> Element -> Element
applySort ('#':'-':'a':'r':'g':'o':'-':'%':anchor :: String
anchor) el :: Element
el
    | (id' :: String
id', ord :: Char
ord:col :: String
col) <- (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
L.break (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`L.elem` ['<', '>']) String
anchor, Just col' :: Int
col' <- String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe String
col =
        String -> Bool -> Int -> Element -> Element
applySort' String
id' (Char
ord Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '<') Int
col' Element
el
applySort _ el :: Element
el = Element
el

applySort' :: String -> Bool -> Int -> Element -> Element
applySort' :: String -> Bool -> Int -> Element -> Element
applySort' ('.':id' :: String
id') asc :: Bool
asc col :: Int
col el :: Element
el@Element { elementNodes :: Element -> [Node]
elementNodes = [Node]
childs }
    | (ix :: String
ix, subpath :: String
subpath) <- (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
L.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '.') String
id', Just ix' :: Int
ix' <- String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe String
ix =
        Element
el { elementNodes :: [Node]
elementNodes = Int -> (Node -> Node) -> [Node] -> [Node]
forall a. Int -> (a -> a) -> [a] -> [a]
setAt Int
ix' (String -> Node -> Node
rewriteNode String
subpath) [Node]
childs }
    | Bool
otherwise = Element
el
  where
    rewriteNode :: String -> Node -> Node
rewriteNode p :: String
p (NodeElement child :: Element
child) = Element -> Node
NodeElement (Element -> Node) -> Element -> Node
forall a b. (a -> b) -> a -> b
$ String -> Bool -> Int -> Element -> Element
applySort' String
p Bool
asc Int
col Element
child
    rewriteNode _ x :: Node
x = Node
x
applySort' "" asc :: Bool
asc col :: Int
col el :: Element
el = Bool -> Int -> Element -> Element
applySort'' Bool
asc Int
col Element
el

applySort' id' :: String
id' asc :: Bool
asc col :: Int
col el :: Element
el@Element { elementAttributes :: Element -> Map Name Text
elementAttributes = Map Name Text
attrs, elementNodes :: Element -> [Node]
elementNodes = [Node]
childs }
    | Just actual :: Text
actual <- "id" Text -> Map Text Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` (Name -> Text) -> Map Name Text -> Map Text Text
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
M.mapKeys Name -> Text
nameLocalName Map Name Text
attrs, String -> Text
pack String
id' Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
actual =
        Bool -> Int -> Element -> Element
applySort'' Bool
asc Int
col Element
el
    | Bool
otherwise = Element
el { elementNodes :: [Node]
elementNodes = (Node -> Node) -> [Node] -> [Node]
forall a b. (a -> b) -> [a] -> [b]
L.map Node -> Node
searchNode [Node]
childs }
  where
    searchNode :: Node -> Node
searchNode (NodeElement child :: Element
child) = Element -> Node
NodeElement (Element -> Node) -> Element -> Node
forall a b. (a -> b) -> a -> b
$ String -> Bool -> Int -> Element -> Element
applySort' String
id' Bool
asc Int
col Element
child
    searchNode x :: Node
x = Node
x

applySort'' :: Bool -> Int -> Element -> Element
applySort'' asc :: Bool
asc col :: Int
col el :: Element
el
    | Just sortable :: [TableRow]
sortable <- Element -> Maybe [TableRow]
table2sorttable Element
el = Element
el {
        elementNodes :: [Node]
elementNodes = [Node] -> Bool -> Int -> [Node]
forall t. (Ord t, Num t, Read t) => [Node] -> Bool -> t -> [Node]
annotateTHead [Node]
header Bool
asc Int
col [Node] -> [Node] -> [Node]
forall a. [a] -> [a] -> [a]
++
            ((TableRow -> [Node]) -> [TableRow] -> [Node]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
L.concatMap ((Element -> Node) -> [Element] -> [Node]
forall a b. (a -> b) -> [a] -> [b]
L.map Element -> Node
NodeElement ([Element] -> [Node])
-> (TableRow -> [Element]) -> TableRow -> [Node]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TableRow -> [Element]
markup) ([TableRow] -> [Node]) -> [TableRow] -> [Node]
forall a b. (a -> b) -> a -> b
$ (TableRow -> TableRow -> Ordering) -> [TableRow] -> [TableRow]
forall a. (a -> a -> Ordering) -> [a] -> [a]
L.sortBy TableRow -> TableRow -> Ordering
compareRows [TableRow]
sortable)
            [Node] -> [Node] -> [Node]
forall a. [a] -> [a] -> [a]
++ [Node]
footer
      }
    | Bool
otherwise = Element
el
  where
    compareRows :: TableRow -> TableRow -> Ordering
compareRows (TableRow a :: [Text]
a _) (TableRow b :: [Text]
b _)
        | Bool
asc = Text -> Text -> Text -> Ordering
compareAs ([Text]
a [Text] -> Int -> Text
forall a. [a] -> Int -> a
!! Int
col) ([Text]
b [Text] -> Int -> Text
forall a. [a] -> Int -> a
!! Int
col) ([Text]
comparators [Text] -> Int -> Text
forall a. [a] -> Int -> a
!! Int
col)
        | Bool
otherwise = Text -> Text -> Text -> Ordering
compareAs ([Text]
b [Text] -> Int -> Text
forall a. [a] -> Int -> a
!! Int
col) ([Text]
a [Text] -> Int -> Text
forall a. [a] -> Int -> a
!! Int
col) ([Text]
comparators [Text] -> Int -> Text
forall a. [a] -> Int -> a
!! Int
col)
    (header :: [Node]
header, _, footer :: [Node]
footer) = [Node] -> ([Node], [Element], [Node])
splitTable ([Node] -> ([Node], [Element], [Node]))
-> [Node] -> ([Node], [Element], [Node])
forall a b. (a -> b) -> a -> b
$ Element -> [Node]
elementNodes Element
el
    comparators :: [Text]
comparators = [Node] -> [Text]
tableHeadComparators [Node]
header

data TableRow = TableRow { TableRow -> [Text]
keys :: [Text], TableRow -> [Element]
markup :: [Element] }

table2sorttable :: Element -> Maybe [TableRow]
table2sorttable Element {
        elementName :: Element -> Name
elementName = Name "table" _ _,
        elementAttributes :: Element -> Map Name Text
elementAttributes = Map Name Text
attrs,
        elementNodes :: Element -> [Node]
elementNodes = [Node]
childs
    } | "-argo-unsortable" Text -> Map Name Text -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` Map Name Text
attrs, (_, body :: [Element]
body, _) <- [Node] -> ([Node], [Element], [Node])
splitTable [Node]
childs =
        [Element] -> Maybe [TableRow]
trs2sorttable [Element]
body
table2sorttable _ = Maybe [TableRow]
forall a. Maybe a
Nothing

splitTable :: [Node] -> ([Node], [Element], [Node])
splitTable :: [Node] -> ([Node], [Element], [Node])
splitTable (NodeElement el :: Element
el@Element { elementName :: Element -> Name
elementName = Name "caption" _ _}:els :: [Node]
els) =
    let (header :: [Node]
header, body :: [Element]
body, footer :: [Node]
footer) = [Node] -> ([Node], [Element], [Node])
splitTable [Node]
els in (Element -> Node
NodeElement Element
elNode -> [Node] -> [Node]
forall a. a -> [a] -> [a]
:[Node]
header, [Element]
body, [Node]
footer)
splitTable (NodeElement el :: Element
el@Element { elementName :: Element -> Name
elementName = Name "colgroup" _ _}:els :: [Node]
els) =
    let (header :: [Node]
header, body :: [Element]
body, footer :: [Node]
footer) = [Node] -> ([Node], [Element], [Node])
splitTable [Node]
els in (Element -> Node
NodeElement Element
elNode -> [Node] -> [Node]
forall a. a -> [a] -> [a]
:[Node]
header, [Element]
body, [Node]
footer)
splitTable (NodeElement el :: Element
el@Element { elementName :: Element -> Name
elementName = Name "thead" _ _}:els :: [Node]
els) =
    let (body :: [Element]
body, footer :: [Node]
footer) = [Node] -> ([Element], [Node])
splitTableBody [Node]
els in ([Element -> Node
NodeElement Element
el], [Element]
body, [Node]
footer)
splitTable (NodeElement el :: Element
el@Element { elementName :: Element -> Name
elementName = Name "tr" _ _, elementNodes :: Element -> [Node]
elementNodes = [Node]
childs}:els :: [Node]
els)
    | (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
L.all (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "th") [Name -> Text
nameLocalName (Name -> Text) -> Name -> Text
forall a b. (a -> b) -> a -> b
$ Element -> Name
elementName Element
el | NodeElement el :: Element
el <- [Node]
childs] =
        let (body :: [Element]
body, footer :: [Node]
footer) = [Node] -> ([Element], [Node])
splitTableBody [Node]
els in ([Element -> Node
NodeElement Element
el], [Element]
body, [Node]
footer)
splitTable els :: [Node]
els@(NodeElement _:_) =
    let (body :: [Element]
body, footer :: [Node]
footer) = [Node] -> ([Element], [Node])
splitTableBody [Node]
els in ([], [Element]
body, [Node]
footer)
splitTable (_:els :: [Node]
els) = [Node] -> ([Node], [Element], [Node])
splitTable [Node]
els
splitTable [] = ([], [], [])

splitTableBody :: [Node] -> ([Element], [Node])
splitTableBody :: [Node] -> ([Element], [Node])
splitTableBody (NodeElement el :: Element
el@Element { elementName :: Element -> Name
elementName = Name "tbody" _ _, elementNodes :: Element -> [Node]
elementNodes = [Node]
childs }:els :: [Node]
els) =
    ([Element
el | NodeElement el :: Element
el@Element { elementName :: Element -> Name
elementName = Name "tr" _ _ } <- [Node]
childs], [Node]
els)
splitTableBody (NodeElement el :: Element
el@Element { elementName :: Element -> Name
elementName = Name "tr" _ _ }:els :: [Node]
els) =
    let (body :: [Element]
body, footer :: [Node]
footer) = [Node] -> ([Element], [Node])
splitTableBody [Node]
els in (Element
elElement -> [Element] -> [Element]
forall a. a -> [a] -> [a]
:[Element]
body, [Node]
footer)
splitTableBody els :: [Node]
els@(NodeElement _:_) = ([], [Node]
els)
splitTableBody (_:els :: [Node]
els) = [Node] -> ([Element], [Node])
splitTableBody [Node]
els
splitTableBody [] = ([], [])

tableHeadComparators :: [Node] -> [Text]
tableHeadComparators :: [Node] -> [Text]
tableHeadComparators = (Maybe Text -> Text) -> [Maybe Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
Prelude.map (Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe "alphanumeric") ([Maybe Text] -> [Text])
-> ([Node] -> [Maybe Text]) -> [Node] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Node] -> [Maybe Text]
tableHeadComparators'
tableHeadComparators' :: [Node] -> [Maybe Text]
tableHeadComparators' :: [Node] -> [Maybe Text]
tableHeadComparators' (NodeElement el :: Element
el@Element { elementName :: Element -> Name
elementName = Name name :: Text
name _ _, elementNodes :: Element -> [Node]
elementNodes = [Node]
childs}:els :: [Node]
els)
    | Text
name Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "thead" = [Node] -> [Maybe Text]
tableHeadComparators' [Node]
childs [Maybe Text] -> [Maybe Text] -> [Maybe Text]
forall a. [Maybe a] -> [Maybe a] -> [Maybe a]
`mergeRight` [Node] -> [Maybe Text]
tableHeadComparators' [Node]
els
    | Text
name Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`L.elem` ["colgroup", "tr"] = [Node] -> [Maybe Text]
tableRowComparators [Node]
childs [Maybe Text] -> [Maybe Text] -> [Maybe Text]
forall a. [Maybe a] -> [Maybe a] -> [Maybe a]
`mergeRight` [Node] -> [Maybe Text]
tableHeadComparators' [Node]
els
    | Bool
otherwise = [Node] -> [Maybe Text]
tableHeadComparators' [Node]
els
tableHeadComparators' [] = []
tableRowComparators :: [Node] -> [Maybe Text]
tableRowComparators :: [Node] -> [Maybe Text]
tableRowComparators (NodeElement el :: Element
el@(Element (Name "col" _ _) attrs :: Map Name Text
attrs _):els :: [Node]
els) =
    let colspan :: Int
colspan = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe 1 (Name -> Map Name Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup "span" Map Name Text
attrs Maybe Text -> (Text -> Maybe Int) -> Maybe Int
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe Int) -> (Text -> String) -> Text -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
unpack)
    in Int -> Maybe Text -> [Maybe Text]
forall a. Int -> a -> [a]
Prelude.replicate Int
colspan (Name -> Map Name Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup "-argo-sortas" Map Name Text
attrs) [Maybe Text] -> [Maybe Text] -> [Maybe Text]
forall a. [a] -> [a] -> [a]
++ [Node] -> [Maybe Text]
tableRowComparators [Node]
els
tableRowComparators (NodeElement el :: Element
el@(Element (Name n :: Text
n _ _) attrs :: Map Name Text
attrs _):els :: [Node]
els) | Text
n Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`L.elem` ["td", "th"] =
    let colspan :: Int
colspan = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe 1 (Name -> Map Name Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup "colspan" Map Name Text
attrs Maybe Text -> (Text -> Maybe Int) -> Maybe Int
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe Int) -> (Text -> String) -> Text -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
unpack)
    in Int -> Maybe Text -> [Maybe Text]
forall a. Int -> a -> [a]
Prelude.replicate Int
colspan (Name -> Map Name Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup "-argo-sortas" Map Name Text
attrs) [Maybe Text] -> [Maybe Text] -> [Maybe Text]
forall a. [a] -> [a] -> [a]
++ [Node] -> [Maybe Text]
tableRowComparators [Node]
els
tableRowComparators (_:els :: [Node]
els) = [Node] -> [Maybe Text]
tableRowComparators [Node]
els
tableRowComparators [] = []
mergeRight :: [Maybe a] -> [Maybe a] -> [Maybe a]
mergeRight :: [Maybe a] -> [Maybe a] -> [Maybe a]
mergeRight (_:as :: [Maybe a]
as) (Just b :: a
b:bs :: [Maybe a]
bs) = a -> Maybe a
forall a. a -> Maybe a
Just a
b Maybe a -> [Maybe a] -> [Maybe a]
forall a. a -> [a] -> [a]
: [Maybe a] -> [Maybe a] -> [Maybe a]
forall a. [Maybe a] -> [Maybe a] -> [Maybe a]
mergeRight [Maybe a]
as [Maybe a]
bs
mergeRight (a :: Maybe a
a:as :: [Maybe a]
as) (_:bs :: [Maybe a]
bs) = Maybe a
a Maybe a -> [Maybe a] -> [Maybe a]
forall a. a -> [a] -> [a]
: [Maybe a] -> [Maybe a] -> [Maybe a]
forall a. [Maybe a] -> [Maybe a] -> [Maybe a]
mergeRight [Maybe a]
as [Maybe a]
bs
mergeRight [] bs :: [Maybe a]
bs = [Maybe a]
bs
mergeRight as :: [Maybe a]
as [] = [Maybe a]
as

annotateTHead :: [Node] -> Bool -> t -> [Node]
annotateTHead (NodeElement el :: Element
el@Element { elementName :: Element -> Name
elementName = Name "thead" _ _, elementNodes :: Element -> [Node]
elementNodes = [Node]
childs }:nodes :: [Node]
nodes) a :: Bool
a c :: t
c =
    Element -> Node
NodeElement Element
el { elementNodes :: [Node]
elementNodes = [Node] -> Bool -> t -> [Node]
annotateTHead [Node]
childs Bool
a t
c } Node -> [Node] -> [Node]
forall a. a -> [a] -> [a]
: [Node]
nodes
annotateTHead (NodeElement el :: Element
el@Element { elementName :: Element -> Name
elementName = Name "tr" _ _, elementNodes :: Element -> [Node]
elementNodes = [Node]
childs }:nodes :: [Node]
nodes) a :: Bool
a c :: t
c =
    Element -> Node
NodeElement Element
el { elementNodes :: [Node]
elementNodes = [Node] -> Bool -> t -> t -> [Node]
forall t.
(Ord t, Num t, Read t) =>
[Node] -> Bool -> t -> t -> [Node]
annotateTR [Node]
childs Bool
a t
c 0 } Node -> [Node] -> [Node]
forall a. a -> [a] -> [a]
: [Node]
nodes
annotateTHead (child :: Node
child:childs :: [Node]
childs) a :: Bool
a c :: t
c = Node
childNode -> [Node] -> [Node]
forall a. a -> [a] -> [a]
:[Node] -> Bool -> t -> [Node]
annotateTHead [Node]
childs Bool
a t
c
annotateTHead [] _ _ = []

annotateTR :: [Node] -> Bool -> t -> t -> [Node]
annotateTR (NodeElement el :: Element
el@Element { elementName :: Element -> Name
elementName = Name n :: Text
n _ _, elementAttributes :: Element -> Map Name Text
elementAttributes = Map Name Text
attrs }:nodes :: [Node]
nodes) asc :: Bool
asc col :: t
col count :: t
count
    | Text
n Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`L.elem` ["th", "td"], t
count t -> t -> Bool
forall a. Ord a => a -> a -> Bool
>= t
col =
        Element -> Node
NodeElement Element
el { elementAttributes :: Map Name Text
elementAttributes = Name -> Text -> Map Name Text -> Map Name Text
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert "aria-sort" Text
asc' Map Name Text
attrs }Node -> [Node] -> [Node]
forall a. a -> [a] -> [a]
:[Node]
nodes
    | Text
n Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`L.elem` ["th", "td"] = Element -> Node
NodeElement Element
elNode -> [Node] -> [Node]
forall a. a -> [a] -> [a]
:[Node] -> Bool -> t -> t -> [Node]
annotateTR [Node]
nodes Bool
asc t
col (t
count t -> t -> t
forall a. Num a => a -> a -> a
+ t
colspan)
  where
    colspan :: t
colspan = t -> Maybe t -> t
forall a. a -> Maybe a -> a
fromMaybe 1 (String -> Maybe t
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe t) -> Maybe String -> Maybe t
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> String
unpack (Text -> String) -> Maybe Text -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Map Text Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup "colspan" Map Text Text
attrs')
    attrs' :: Map Text Text
attrs' = (Name -> Text) -> Map Name Text -> Map Text Text
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
M.mapKeys Name -> Text
nameLocalName Map Name Text
attrs
    asc' :: Text
asc' | Bool
asc = "ascending"
        | Bool
otherwise = "descending"
annotateTR (node :: Node
node:nodes :: [Node]
nodes) a :: Bool
a c :: t
c n :: t
n = Node
nodeNode -> [Node] -> [Node]
forall a. a -> [a] -> [a]
:[Node] -> Bool -> t -> t -> [Node]
annotateTR [Node]
nodes Bool
a t
c t
n
annotateTR [] _ _ _ = []

trs2sorttable :: [Element] -> Maybe [TableRow]
trs2sorttable els :: [Element]
els@(el :: Element
el@Element { elementName :: Element -> Name
elementName = Name "tr" _ _, elementNodes :: Element -> [Node]
elementNodes = [Node]
childs }:_)
    | Just keys' :: [Text]
keys' <- [Element] -> Maybe [Text]
tds2keys [Element
el | NodeElement el :: Element
el <- [Node]
childs],
      Just (group :: [Element]
group, rest :: [Element]
rest) <- [Element] -> Integer -> Maybe ([Element], [Element])
forall t.
(Ord t, Read t, Num t, Enum t) =>
[Element] -> t -> Maybe ([Element], [Element])
groupTrs [Element]
els 1,
      Just rest' :: [TableRow]
rest' <- [Element] -> Maybe [TableRow]
trs2sorttable [Element]
rest = [TableRow] -> Maybe [TableRow]
forall a. a -> Maybe a
Just ([Text] -> [Element] -> TableRow
TableRow [Text]
keys' [Element]
group TableRow -> [TableRow] -> [TableRow]
forall a. a -> [a] -> [a]
: [TableRow]
rest')
trs2sorttable [] = [TableRow] -> Maybe [TableRow]
forall a. a -> Maybe a
Just []
trs2sorttable _ = Maybe [TableRow]
forall a. Maybe a
Nothing

tds2keys :: [Element] -> Maybe [Text]
tds2keys :: [Element] -> Maybe [Text]
tds2keys (el :: Element
el@Element {elementName :: Element -> Name
elementName = Name n :: Text
n _ _, elementAttributes :: Element -> Map Name Text
elementAttributes = Map Name Text
attrs, elementNodes :: Element -> [Node]
elementNodes = [Node]
childs }:els :: [Element]
els)
    | Text
n Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`L.elem` ["td", "th"], Just key :: Text
key <- "-argo-sortkey" Name -> Map Name Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` Map Name Text
attrs, Just rest :: [Text]
rest <- [Element] -> Maybe [Text]
tds2keys [Element]
els =
        [Text] -> Maybe [Text]
forall a. a -> Maybe a
Just (Int -> Text -> [Text]
forall a. Int -> a -> [a]
Prelude.replicate Int
colspan Text
key [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text]
rest)
    | Text
n Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`L.elem` ["td", "th"], Just rest :: [Text]
rest <- [Element] -> Maybe [Text]
tds2keys [Element]
els =
        [Text] -> Maybe [Text]
forall a. a -> Maybe a
Just (Int -> Text -> [Text]
forall a. Int -> a -> [a]
Prelude.replicate Int
colspan ([Node] -> Text
nodesText [Node]
childs) [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text]
rest)
  where
    colspan :: Int
colspan | Just n :: Text
n <- "colspan" Text -> Map Text Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` (Name -> Text) -> Map Name Text -> Map Text Text
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
M.mapKeys Name -> Text
nameLocalName Map Name Text
attrs,
            Just m :: Int
m <- String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe Int) -> String -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Text -> String
unpack Text
n = Int
m
        | Bool
otherwise = 1
tds2keys [] = [Text] -> Maybe [Text]
forall a. a -> Maybe a
Just []
tds2keys _ = Maybe [Text]
forall a. Maybe a
Nothing

groupTrs :: [Element] -> t -> Maybe ([Element], [Element])
groupTrs (el :: Element
el@Element {elementName :: Element -> Name
elementName = Name "tr" _ _}:els :: [Element]
els) n :: t
n
    | t -> Element -> t
forall a. (Ord a, Read a) => a -> Element -> a
rowRowspan t
n Element
el t -> t -> Bool
forall a. Ord a => a -> a -> Bool
<= 1 = ([Element], [Element]) -> Maybe ([Element], [Element])
forall a. a -> Maybe a
Just (Element
elElement -> [Element] -> [Element]
forall a. a -> [a] -> [a]
:[], [Element]
els)
    | Just (tail :: [Element]
tail, rest :: [Element]
rest) <- [Element] -> t -> Maybe ([Element], [Element])
groupTrs [Element]
els (t -> Maybe ([Element], [Element]))
-> t -> Maybe ([Element], [Element])
forall a b. (a -> b) -> a -> b
$ t -> t
forall a. Enum a => a -> a
pred t
n = ([Element], [Element]) -> Maybe ([Element], [Element])
forall a. a -> Maybe a
Just (Element
elElement -> [Element] -> [Element]
forall a. a -> [a] -> [a]
:[Element]
tail, [Element]
rest)
groupTrs (_:els :: [Element]
els) n :: t
n = [Element] -> t -> Maybe ([Element], [Element])
groupTrs [Element]
els t
n
groupTrs _ _ = Maybe ([Element], [Element])
forall a. Maybe a
Nothing

rowRowspan :: a -> Element -> a
rowRowspan n :: a
n Element {elementName :: Element -> Name
elementName = Name "tr" _ _, elementNodes :: Element -> [Node]
elementNodes = [Node]
childs } =
    [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
Prelude.maximum (a
n a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a
n |
            NodeElement (Element (Name name :: Text
name _ _) attrs :: Map Name Text
attrs _) <- [Node]
childs,
            Text
name Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`L.elem` ["td", "th"],
            Text
rowspan <- Maybe Text -> [Text]
forall a. Maybe a -> [a]
maybeToList ("rowspan" Text -> Map Text Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` (Name -> Text) -> Map Name Text -> Map Text Text
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
M.mapKeys Name -> Text
nameLocalName Map Name Text
attrs),
            a
n <- Maybe a -> [a]
forall a. Maybe a -> [a]
maybeToList (Maybe a -> [a]) -> Maybe a -> [a]
forall a b. (a -> b) -> a -> b
$ String -> Maybe a
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe a) -> String -> Maybe a
forall a b. (a -> b) -> a -> b
$ Text -> String
unpack Text
rowspan])


--- Utils

+++ :: Text -> Text -> Text
(+++) = Text -> Text -> Text
append
nodesText :: [Node] -> Text
nodesText :: [Node] -> Text
nodesText (NodeElement (Element _ attrs :: Map Name Text
attrs children :: [Node]
children):nodes :: [Node]
nodes) = [Node] -> Text
nodesText [Node]
children Text -> Text -> Text
+++ [Node] -> Text
nodesText [Node]
nodes
nodesText (NodeContent text :: Text
text:nodes :: [Node]
nodes) = Text
text Text -> Text -> Text
+++ [Node] -> Text
nodesText [Node]
nodes
nodesText (_:nodes :: [Node]
nodes) = [Node] -> Text
nodesText [Node]
nodes
nodesText [] = ""

setAt :: Int -> (a -> a) -> [a] -> [a]
setAt :: Int -> (a -> a) -> [a] -> [a]
setAt i :: Int
i a :: a -> a
a ls :: [a]
ls
  | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 0 = [a]
ls
  | Bool
otherwise = Int -> [a] -> [a]
forall t. (Eq t, Num t) => t -> [a] -> [a]
go Int
i [a]
ls
  where
    go :: t -> [a] -> [a]
go 0 (x :: a
x:xs :: [a]
xs) = a -> a
a a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
xs
    go n :: t
n (x :: a
x:xs :: [a]
xs) = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: t -> [a] -> [a]
go (t
nt -> t -> t
forall a. Num a => a -> a -> a
-1) [a]
xs
    go _ []     = []

pattern (:.) :: Char -> Txt.Text -> Txt.Text
pattern x $m:. :: forall r. Text -> (Char -> Text -> r) -> (Void# -> r) -> r
:. xs <- (Txt.uncons -> Just (x, xs))

infixr 5 :.

compareAs :: Text -> Text -> Text -> Ordering
--- Hueristic that readily handles both numbers & text
compareAs :: Text -> Text -> Text -> Ordering
compareAs (a :: Char
a:.as :: Text
as) (b :: Char
b:.bs :: Text
bs) "alphanumeric"
    | Char -> Bool
isDigit Char
a Bool -> Bool -> Bool
&& Char -> Bool
isDigit Char
b =
        let (a' :: Text
a', as' :: Text
as') = (Char -> Bool) -> Text -> (Text, Text)
Txt.break (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isDigit) Text
as
            (b' :: Text
b', bs' :: Text
bs') = (Char -> Bool) -> Text -> (Text, Text)
Txt.break (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isDigit) Text
bs
        in if Text -> Int
Txt.length Text
a' Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Int
Txt.length Text
b' Bool -> Bool -> Bool
&& Char
a Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
b
        then Text -> Text -> Text -> Ordering
compareAs Text
as Text
bs "alphanumeric"
        else if Text -> Int
Txt.length Text
a' Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Int
Txt.length Text
b' then Char
a Char -> Char -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` Char
b
        else Text -> Int
Txt.length Text
a' Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` Text -> Int
Txt.length Text
b'
    | Char
a Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
b = Text -> Text -> Text -> Ordering
compareAs Text
as Text
bs "alphanumeric"
    | Bool
otherwise = Char
a Char -> Char -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` Char
b
compareAs as :: Text
as bs :: Text
bs "text" = Text
as Text -> Text -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` Text
bs
compareAs as :: Text
as bs :: Text
bs "number" = Text -> Maybe Float
readInt Text
as Maybe Float -> Maybe Float -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` Text -> Maybe Float
readInt Text
bs
    where
        readInt :: Text -> Maybe Float
        readInt :: Text -> Maybe Float
readInt = String -> Maybe Float
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe Float) -> (Text -> String) -> Text -> Maybe Float
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
Prelude.filter (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`L.elem` '-'Char -> String -> String
forall a. a -> [a] -> [a]
:'.'Char -> String -> String
forall a. a -> [a] -> [a]
:['0'..'9']) (String -> String) -> (Text -> String) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
unpack
compareAs as :: Text
as bs :: Text
bs fmt :: Text
fmt = Text -> Maybe UTCTime
readTime Text
as Maybe UTCTime -> Maybe UTCTime -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` Text -> Maybe UTCTime
readTime Text
bs
    where
        readTime :: Text -> Maybe UTCTime
        readTime :: Text -> Maybe UTCTime
readTime = Bool -> TimeLocale -> String -> String -> Maybe UTCTime
forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> String -> String -> m t
parseTimeM Bool
True TimeLocale
defaultTimeLocale (Text -> String
unpack Text
fmt) (String -> Maybe UTCTime)
-> (Text -> String) -> Text -> Maybe UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
unpack