{-# 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 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 (Char
'#':Char
'-':Char
'a':Char
'r':Char
'g':Char
'o':Char
'-':Char
'%':String
anchor) Element
el
    | (String
id', Char
ord: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` [Char
'<', Char
'>']) String
anchor, Just 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
== Char
'<') Int
col' Element
el
applySort String
_ Element
el = Element
el

applySort' :: String -> Bool -> Int -> Element -> Element
applySort' :: String -> Bool -> Int -> Element -> Element
applySort' (Char
'.':String
id') Bool
asc Int
col el :: Element
el@Element { elementNodes :: Element -> [Node]
elementNodes = [Node]
childs }
    | (String
ix, 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
== Char
'.') String
id', Just 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 String
p (NodeElement 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 String
_ Node
x = Node
x
applySort' String
"" Bool
asc Int
col Element
el = Bool -> Int -> Element -> Element
applySort'' Bool
asc Int
col Element
el

applySort' String
id' Bool
asc Int
col el :: Element
el@Element { elementAttributes :: Element -> Map Name Text
elementAttributes = Map Name Text
attrs, elementNodes :: Element -> [Node]
elementNodes = [Node]
childs }
    | Just Text
actual <- Text
"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 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 Node
x = Node
x

applySort'' :: Bool -> Int -> Element -> Element
applySort'' Bool
asc Int
col Element
el
    | Just [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 [Text]
a [Element]
_) (TableRow [Text]
b [Element]
_)
        | 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)
    ([Node]
header, [Element]
_, [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 Text
"table" Maybe Text
_ Maybe Text
_,
        elementAttributes :: Element -> Map Name Text
elementAttributes = Map Name Text
attrs,
        elementNodes :: Element -> [Node]
elementNodes = [Node]
childs
    } | Text
"-argo-unsortable" Text -> Map Name Text -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` Map Name Text
attrs, ([Node]
_, [Element]
body, [Node]
_) <- [Node] -> ([Node], [Element], [Node])
splitTable [Node]
childs =
        [Element] -> Maybe [TableRow]
trs2sorttable [Element]
body
table2sorttable Element
_ = 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 Text
"caption" Maybe Text
_ Maybe Text
_}:[Node]
els) =
    let ([Node]
header, [Element]
body, [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 Text
"colgroup" Maybe Text
_ Maybe Text
_}:[Node]
els) =
    let ([Node]
header, [Element]
body, [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 Text
"thead" Maybe Text
_ Maybe Text
_}:[Node]
els) =
    let ([Element]
body, [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 Text
"tr" Maybe Text
_ Maybe Text
_, elementNodes :: Element -> [Node]
elementNodes = [Node]
childs}:[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
== Text
"th") [Name -> Text
nameLocalName (Name -> Text) -> Name -> Text
forall a b. (a -> b) -> a -> b
$ Element -> Name
elementName Element
el | NodeElement Element
el <- [Node]
childs] =
        let ([Element]
body, [Node]
footer) = [Node] -> ([Element], [Node])
splitTableBody [Node]
els in ([Element -> Node
NodeElement Element
el], [Element]
body, [Node]
footer)
splitTable els :: [Node]
els@(NodeElement Element
_:[Node]
_) =
    let ([Element]
body, [Node]
footer) = [Node] -> ([Element], [Node])
splitTableBody [Node]
els in ([], [Element]
body, [Node]
footer)
splitTable (Node
_:[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 Text
"tbody" Maybe Text
_ Maybe Text
_, elementNodes :: Element -> [Node]
elementNodes = [Node]
childs }:[Node]
els) =
    ([Element
el | NodeElement el :: Element
el@Element { elementName :: Element -> Name
elementName = Name Text
"tr" Maybe Text
_ Maybe Text
_ } <- [Node]
childs], [Node]
els)
splitTableBody (NodeElement el :: Element
el@Element { elementName :: Element -> Name
elementName = Name Text
"tr" Maybe Text
_ Maybe Text
_ }:[Node]
els) =
    let ([Element]
body, [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 Element
_:[Node]
_) = ([], [Node]
els)
splitTableBody (Node
_:[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 Text
"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 Text
name Maybe Text
_ Maybe Text
_, elementNodes :: Element -> [Node]
elementNodes = [Node]
childs}:[Node]
els)
    | Text
name Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"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` [Text
"colgroup", Text
"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 Text
"col" Maybe Text
_ Maybe Text
_) Map Name Text
attrs [Node]
_):[Node]
els) =
    let colspan :: Int
colspan = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
1 (Name -> Map Name Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
"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 Name
"-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 Text
n Maybe Text
_ Maybe Text
_) Map Name Text
attrs [Node]
_):[Node]
els) | Text
n Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`L.elem` [Text
"td", Text
"th"] =
    let colspan :: Int
colspan = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
1 (Name -> Map Name Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
"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 Name
"-argo-sortas" Map Name Text
attrs) [Maybe Text] -> [Maybe Text] -> [Maybe Text]
forall a. [a] -> [a] -> [a]
++ [Node] -> [Maybe Text]
tableRowComparators [Node]
els
tableRowComparators (Node
_:[Node]
els) = [Node] -> [Maybe Text]
tableRowComparators [Node]
els
tableRowComparators [] = []
mergeRight :: [Maybe a] -> [Maybe a] -> [Maybe a]
mergeRight :: forall a. [Maybe a] -> [Maybe a] -> [Maybe a]
mergeRight (Maybe a
_:[Maybe a]
as) (Just a
b:[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 (Maybe a
a:[Maybe a]
as) (Maybe a
_:[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 [] [Maybe a]
bs = [Maybe a]
bs
mergeRight [Maybe a]
as [] = [Maybe a]
as

annotateTHead :: [Node] -> Bool -> t -> [Node]
annotateTHead (NodeElement el :: Element
el@Element { elementName :: Element -> Name
elementName = Name Text
"thead" Maybe Text
_ Maybe Text
_, elementNodes :: Element -> [Node]
elementNodes = [Node]
childs }:[Node]
nodes) Bool
a 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 Text
"tr" Maybe Text
_ Maybe Text
_, elementNodes :: Element -> [Node]
elementNodes = [Node]
childs }:[Node]
nodes) Bool
a 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 t
0 } Node -> [Node] -> [Node]
forall a. a -> [a] -> [a]
: [Node]
nodes
annotateTHead (Node
child:[Node]
childs) Bool
a t
c = Node
childNode -> [Node] -> [Node]
forall a. a -> [a] -> [a]
:[Node] -> Bool -> t -> [Node]
annotateTHead [Node]
childs Bool
a t
c
annotateTHead [] Bool
_ t
_ = []

annotateTR :: [Node] -> Bool -> t -> t -> [Node]
annotateTR (NodeElement el :: Element
el@Element { elementName :: Element -> Name
elementName = Name Text
n Maybe Text
_ Maybe Text
_, elementAttributes :: Element -> Map Name Text
elementAttributes = Map Name Text
attrs }:[Node]
nodes) Bool
asc t
col t
count
    | Text
n Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`L.elem` [Text
"th", Text
"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 Name
"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` [Text
"th", Text
"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 t
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 Text
"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 = Text
"ascending"
        | Bool
otherwise = Text
"descending"
annotateTR (Node
node:[Node]
nodes) Bool
a t
c 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 [] Bool
_ t
_ t
_ = []

trs2sorttable :: [Element] -> Maybe [TableRow]
trs2sorttable els :: [Element]
els@(el :: Element
el@Element { elementName :: Element -> Name
elementName = Name Text
"tr" Maybe Text
_ Maybe Text
_, elementNodes :: Element -> [Node]
elementNodes = [Node]
childs }:[Element]
_)
    | Just [Text]
keys' <- [Element] -> Maybe [Text]
tds2keys [Element
el | NodeElement Element
el <- [Node]
childs],
      Just ([Element]
group, [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 Integer
1,
      Just [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 [Element]
_ = 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 Text
n Maybe Text
_ Maybe Text
_, elementAttributes :: Element -> Map Name Text
elementAttributes = Map Name Text
attrs, elementNodes :: Element -> [Node]
elementNodes = [Node]
childs }:[Element]
els)
    | Text
n Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`L.elem` [Text
"td", Text
"th"], Just Text
key <- Name
"-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 [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` [Text
"td", Text
"th"], Just [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 Text
n <- Text
"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 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 = Int
1
tds2keys [] = [Text] -> Maybe [Text]
forall a. a -> Maybe a
Just []
tds2keys [Element]
_ = Maybe [Text]
forall a. Maybe a
Nothing

groupTrs :: [Element] -> t -> Maybe ([Element], [Element])
groupTrs (el :: Element
el@Element {elementName :: Element -> Name
elementName = Name Text
"tr" Maybe Text
_ Maybe Text
_}:[Element]
els) 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
<= t
1 = ([Element], [Element]) -> Maybe ([Element], [Element])
forall a. a -> Maybe a
Just (Element
elElement -> [Element] -> [Element]
forall a. a -> [a] -> [a]
:[], [Element]
els)
    | Just ([Element]
tail, [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 (Element
_:[Element]
els) t
n = [Element] -> t -> Maybe ([Element], [Element])
groupTrs [Element]
els t
n
groupTrs [Element]
_ t
_ = Maybe ([Element], [Element])
forall a. Maybe a
Nothing

rowRowspan :: a -> Element -> a
rowRowspan a
n Element {elementName :: Element -> Name
elementName = Name Text
"tr" Maybe Text
_ Maybe Text
_, 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 Text
name Maybe Text
_ Maybe Text
_) Map Name Text
attrs [Node]
_) <- [Node]
childs,
            Text
name Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`L.elem` [Text
"td", Text
"th"],
            Text
rowspan <- Maybe Text -> [Text]
forall a. Maybe a -> [a]
maybeToList (Text
"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 Name
_ Map Name Text
attrs [Node]
children):[Node]
nodes) = [Node] -> Text
nodesText [Node]
children Text -> Text -> Text
+++ [Node] -> Text
nodesText [Node]
nodes
nodesText (NodeContent Text
text:[Node]
nodes) = Text
text Text -> Text -> Text
+++ [Node] -> Text
nodesText [Node]
nodes
nodesText (Node
_:[Node]
nodes) = [Node] -> Text
nodesText [Node]
nodes
nodesText [] = Text
""

setAt :: Int -> (a -> a) -> [a] -> [a]
setAt :: forall a. Int -> (a -> a) -> [a] -> [a]
setAt Int
i a -> a
a [a]
ls
  | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
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 t
0 (a
x:[a]
xs) = a -> a
a a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
xs
    go t
n (a
x:[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
-t
1) [a]
xs
    go t
_ []     = []

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 (Char
a:.Text
as) (Char
b:.Text
bs) Text
"alphanumeric"
    | Char -> Bool
isDigit Char
a Bool -> Bool -> Bool
&& Char -> Bool
isDigit Char
b =
        let (Text
a', 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
            (Text
b', 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 Text
"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 Text
"alphanumeric"
    | Bool
otherwise = Char
a Char -> Char -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` Char
b
compareAs Text
as Text
bs Text
"text" = Text
as Text -> Text -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` Text
bs
compareAs Text
as Text
bs Text
"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
'-'Char -> String -> String
forall a. a -> [a] -> [a]
:Char
'.'Char -> String -> String
forall a. a -> [a] -> [a]
:[Char
'0'..Char
'9']) (String -> String) -> (Text -> String) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
unpack
compareAs Text
as Text
bs 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