{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
module Data.KVITable.Render.HTML
(
render
, RenderConfig(..)
, defaultRenderConfig
)
where
import qualified Data.Foldable as F
import qualified Data.List as L
import Data.Maybe ( fromMaybe, isNothing )
import Data.Text ( Text )
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import Lens.Micro ( (^.) )
import Lucid
import qualified Prettyprinter as PP
import Data.KVITable
import Data.KVITable.Render
import Prelude hiding ( lookup )
render :: PP.Pretty v => RenderConfig -> KVITable v -> Text
render :: RenderConfig -> KVITable v -> Text
render RenderConfig
cfg KVITable v
t =
let kseq :: [Text]
kseq = (Text, [Text]) -> Text
forall a b. (a, b) -> a
fst ((Text, [Text]) -> Text) -> [(Text, [Text])] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KVITable v
t KVITable v
-> Getting [(Text, [Text])] (KVITable v) [(Text, [Text])]
-> [(Text, [Text])]
forall s a. s -> Getting a s a -> a
^. Getting [(Text, [Text])] (KVITable v) [(Text, [Text])]
forall v. Lens' (KVITable v) [(Text, [Text])]
keyVals
(FmtLine
fmt, Html ()
hdr) = RenderConfig -> KVITable v -> [Text] -> (FmtLine, Html ())
forall v.
Pretty v =>
RenderConfig -> KVITable v -> [Text] -> (FmtLine, Html ())
renderHdrs RenderConfig
cfg KVITable v
t [Text]
kseq
bdy :: Html ()
bdy = RenderConfig -> FmtLine -> [Text] -> KVITable v -> Html ()
forall v.
Pretty v =>
RenderConfig -> FmtLine -> [Text] -> KVITable v -> Html ()
renderSeq RenderConfig
cfg FmtLine
fmt [Text]
kseq KVITable v
t
in Text -> Text
TL.toStrict (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Html () -> Text
forall a. Html a -> Text
renderText (Html () -> Text) -> Html () -> Text
forall a b. (a -> b) -> a -> b
$
[Attribute] -> Html () -> Html ()
forall arg result. Term arg result => arg -> result
table_ [ Text -> Attribute
class_ Text
"kvitable" ] (Html () -> Html ()) -> Html () -> Html ()
forall a b. (a -> b) -> a -> b
$
do Html () -> (Text -> Html ()) -> Maybe Text -> Html ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Html ()
forall a. Monoid a => a
mempty (Html () -> Html ()
forall arg result. Term arg result => arg -> result
caption_ (Html () -> Html ()) -> (Text -> Html ()) -> Text -> Html ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Html ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtml) (Maybe Text -> Html ()) -> Maybe Text -> Html ()
forall a b. (a -> b) -> a -> b
$ RenderConfig -> Maybe Text
Data.KVITable.Render.caption RenderConfig
cfg
[Attribute] -> Html () -> Html ()
forall arg result. Term arg result => arg -> result
thead_ [ Text -> Attribute
class_ Text
"kvitable_head" ] Html ()
hdr
[Attribute] -> Html () -> Html ()
forall arg result. Term arg result => arg -> result
tbody_ [ Text -> Attribute
class_ Text
"kvitable_body" ] Html ()
bdy
data FmtLine = FmtLine [Int]
instance Semigroup FmtLine where
(FmtLine [Int]
c1) <> :: FmtLine -> FmtLine -> FmtLine
<> (FmtLine [Int]
c2) = [Int] -> FmtLine
FmtLine ([Int] -> FmtLine) -> [Int] -> FmtLine
forall a b. (a -> b) -> a -> b
$ [Int]
c1 [Int] -> [Int] -> [Int]
forall a. Semigroup a => a -> a -> a
<> [Int]
c2
instance Monoid FmtLine where
mempty :: FmtLine
mempty = [Int] -> FmtLine
FmtLine [Int]
forall a. Monoid a => a
mempty
fmtAddColLeft :: Int -> FmtLine -> FmtLine
fmtAddColLeft :: Int -> FmtLine -> FmtLine
fmtAddColLeft Int
lspan (FmtLine [Int]
col) = [Int] -> FmtLine
FmtLine ([Int] -> FmtLine) -> [Int] -> FmtLine
forall a b. (a -> b) -> a -> b
$ Int
lspan Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
col
data FmtVal = Val Height LastInGroup Text
| Hdr Height LastInGroup Text
deriving Int -> FmtVal -> ShowS
[FmtVal] -> ShowS
FmtVal -> String
(Int -> FmtVal -> ShowS)
-> (FmtVal -> String) -> ([FmtVal] -> ShowS) -> Show FmtVal
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FmtVal] -> ShowS
$cshowList :: [FmtVal] -> ShowS
show :: FmtVal -> String
$cshow :: FmtVal -> String
showsPrec :: Int -> FmtVal -> ShowS
$cshowsPrec :: Int -> FmtVal -> ShowS
Show
type Height = Int
type LastInGroup = Bool
type RightLabel = Text
fmtRender :: FmtLine -> [FmtVal] -> Maybe RightLabel -> Html ()
fmtRender :: FmtLine -> [FmtVal] -> Maybe Text -> Html ()
fmtRender (FmtLine [Int]
cols) [FmtVal]
vals Maybe Text
mbRLabel = do
[Attribute] -> Html () -> Html ()
forall arg result. Term arg result => arg -> result
tr_ [ Text -> Attribute
class_ Text
"kvitable_tr" ] (Html () -> Html ()) -> Html () -> Html ()
forall a b. (a -> b) -> a -> b
$
let excessColCnt :: Int
excessColCnt = [Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
cols Int -> Int -> Int
forall a. Num a => a -> a -> a
- [FmtVal] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [FmtVal]
vals
cell :: (a, FmtVal) -> p
cell (a
w,Hdr Int
h LastInGroup
l Text
v) =
let a :: [[Attribute]]
a = [ [ Text -> Attribute
class_ Text
"kvitable_th" ]
, if Int
h Int -> Int -> LastInGroup
forall a. Eq a => a -> a -> LastInGroup
== Int
1 then []
else [ Text -> Attribute
rowspan_ (Text -> Attribute) -> Text -> Attribute
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
h ]
, if a
w a -> a -> LastInGroup
forall a. Eq a => a -> a -> LastInGroup
== a
1 then []
else [ Text -> Attribute
colspan_ (Text -> Attribute) -> Text -> Attribute
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ a -> String
forall a. Show a => a -> String
show a
w
, Text -> Attribute
class_ Text
" multicol" ]
, if LastInGroup
l then [ Text -> Attribute
class_ Text
" last_in_group" ] else []
]
in [Attribute] -> HtmlT m () -> p
forall arg result. Term arg result => arg -> result
th_ ([[Attribute]] -> [Attribute]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Attribute]] -> [Attribute]) -> [[Attribute]] -> [Attribute]
forall a b. (a -> b) -> a -> b
$ [[Attribute]] -> [[Attribute]]
forall a. [a] -> [a]
reverse [[Attribute]]
a) (Text -> HtmlT m ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtml Text
v)
cell (a
w,Val Int
h LastInGroup
l Text
v) =
let a :: [[Attribute]]
a = [ [ Text -> Attribute
class_ Text
"kvitable_td" ]
, if Int
h Int -> Int -> LastInGroup
forall a. Eq a => a -> a -> LastInGroup
== Int
1 then []
else [ Text -> Attribute
rowspan_ (Text -> Attribute) -> Text -> Attribute
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
h ]
, if a
w a -> a -> LastInGroup
forall a. Eq a => a -> a -> LastInGroup
== a
1 then []
else [ Text -> Attribute
colspan_ (Text -> Attribute) -> Text -> Attribute
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ a -> String
forall a. Show a => a -> String
show a
w
, Text -> Attribute
class_ Text
" multicol" ]
, if LastInGroup
l then [ Text -> Attribute
class_ Text
" last_in_group" ] else []
]
in [Attribute] -> HtmlT m () -> p
forall arg result. Term arg result => arg -> result
td_ ([[Attribute]] -> [Attribute]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Attribute]] -> [Attribute]) -> [[Attribute]] -> [Attribute]
forall a b. (a -> b) -> a -> b
$ [[Attribute]] -> [[Attribute]]
forall a. [a] -> [a]
reverse [[Attribute]]
a) (Text -> HtmlT m ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtml Text
v)
labelMark :: Html ()
labelMark = Text -> Html ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtmlRaw (Text
" ←" :: Text)
labelHtml :: Text -> Html ()
labelHtml = [Attribute] -> Html () -> Html ()
forall arg result. Term arg result => arg -> result
th_ [ Text -> Attribute
class_ Text
"rightlabel kvitable_th" ] (Html () -> Html ()) -> (Text -> Html ()) -> Text -> Html ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
(Html ()
labelMark Html () -> Html () -> Html ()
forall a. Semigroup a => a -> a -> a
<>) (Html () -> Html ()) -> (Text -> Html ()) -> Text -> Html ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
Text -> Html ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtml
in do ((Int, FmtVal) -> Html ()) -> [(Int, FmtVal)] -> Html ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Int, FmtVal) -> Html ()
forall (m :: * -> *) p (m :: * -> *) a.
(Term [Attribute] (HtmlT m () -> p),
Term [Attribute] (HtmlT m () -> p), Monad m, Monad m, Eq a, Num a,
Show a) =>
(a, FmtVal) -> p
cell ([(Int, FmtVal)] -> Html ()) -> [(Int, FmtVal)] -> Html ()
forall a b. (a -> b) -> a -> b
$ ((Int, FmtVal) -> LastInGroup)
-> [(Int, FmtVal)] -> [(Int, FmtVal)]
forall a. (a -> LastInGroup) -> [a] -> [a]
L.filter ((Int -> Int -> LastInGroup
forall a. Eq a => a -> a -> LastInGroup
/= Int
0) (Int -> LastInGroup)
-> ((Int, FmtVal) -> Int) -> (Int, FmtVal) -> LastInGroup
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, FmtVal) -> Int
forall a b. (a, b) -> a
fst) ([(Int, FmtVal)] -> [(Int, FmtVal)])
-> [(Int, FmtVal)] -> [(Int, FmtVal)]
forall a b. (a -> b) -> a -> b
$
[Int] -> [FmtVal] -> [(Int, FmtVal)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
drop Int
excessColCnt [Int]
cols) [FmtVal]
vals
Html () -> (Text -> Html ()) -> Maybe Text -> Html ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Html ()
forall a. Monoid a => a
mempty Text -> Html ()
labelHtml Maybe Text
mbRLabel
data = HdrLine FmtLine HdrVals Trailer
type HdrVals = [FmtVal]
type Trailer = Maybe Text
instance Semigroup HeaderLine where
(HdrLine FmtLine
fmt1 [FmtVal]
hv1 Maybe Text
t1) <> :: HeaderLine -> HeaderLine -> HeaderLine
<> (HdrLine FmtLine
fmt2 [FmtVal]
hv2 Maybe Text
_) =
FmtLine -> [FmtVal] -> Maybe Text -> HeaderLine
HdrLine (FmtLine
fmt1 FmtLine -> FmtLine -> FmtLine
forall a. Semigroup a => a -> a -> a
<> FmtLine
fmt2) ([FmtVal]
hv1 [FmtVal] -> [FmtVal] -> [FmtVal]
forall a. Semigroup a => a -> a -> a
<> [FmtVal]
hv2) Maybe Text
t1
hdrFmt :: HeaderLine -> FmtLine
hdrFmt :: HeaderLine -> FmtLine
hdrFmt (HdrLine FmtLine
fmt [FmtVal]
_ Maybe Text
_) = FmtLine
fmt
renderHdrs :: PP.Pretty v
=> RenderConfig -> KVITable v -> [Key]
-> ( FmtLine, Html () )
renderHdrs :: RenderConfig -> KVITable v -> [Text] -> (FmtLine, Html ())
renderHdrs RenderConfig
cfg KVITable v
t [Text]
keys =
( FmtLine
rowfmt, [Html ()] -> Html ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [ FmtLine -> [FmtVal] -> Maybe Text -> Html ()
fmtRender FmtLine
fmt [FmtVal]
hdrvals Maybe Text
trailer
| (HdrLine FmtLine
fmt [FmtVal]
hdrvals Maybe Text
trailer) <- [HeaderLine]
hrows
])
where
([HeaderLine]
hrows, FmtLine
rowfmt) = RenderConfig -> KVITable v -> [Text] -> ([HeaderLine], FmtLine)
forall v.
Pretty v =>
RenderConfig -> KVITable v -> [Text] -> ([HeaderLine], FmtLine)
hdrstep RenderConfig
cfg KVITable v
t [Text]
keys
hdrstep :: PP.Pretty v
=> RenderConfig -> KVITable v -> [Key] -> ([HeaderLine], FmtLine)
hdrstep :: RenderConfig -> KVITable v -> [Text] -> ([HeaderLine], FmtLine)
hdrstep RenderConfig
_cfg KVITable v
t [] =
( [ FmtLine -> [FmtVal] -> Maybe Text -> HeaderLine
HdrLine ([Int] -> FmtLine
FmtLine [Int
1]) [Int -> LastInGroup -> Text -> FmtVal
Hdr Int
1 LastInGroup
False (Text -> FmtVal) -> Text -> FmtVal
forall a b. (a -> b) -> a -> b
$ KVITable v
t KVITable v -> Getting Text (KVITable v) Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text (KVITable v) Text
forall v. Lens' (KVITable v) Text
valueColName] Maybe Text
forall a. Maybe a
Nothing ]
, [Int] -> FmtLine
FmtLine [Int
1]
)
hdrstep RenderConfig
cfg KVITable v
t (Text
key:[Text]
keys) =
if RenderConfig -> Maybe Text
colStackAt RenderConfig
cfg Maybe Text -> Maybe Text -> LastInGroup
forall a. Eq a => a -> a -> LastInGroup
== Text -> Maybe Text
forall a. a -> Maybe a
Just Text
key
then RenderConfig
-> KVITable v -> KeySpec -> [Text] -> ([HeaderLine], FmtLine)
forall v.
Pretty v =>
RenderConfig
-> KVITable v -> KeySpec -> [Text] -> ([HeaderLine], FmtLine)
hdrvalstep RenderConfig
cfg KVITable v
t [] (Text
keyText -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:[Text]
keys)
else
let ([HeaderLine]
nexthdrs, FmtLine
lowestfmt) = RenderConfig -> KVITable v -> [Text] -> ([HeaderLine], FmtLine)
forall v.
Pretty v =>
RenderConfig -> KVITable v -> [Text] -> ([HeaderLine], FmtLine)
hdrstep RenderConfig
cfg KVITable v
t [Text]
keys
(HdrLine FmtLine
fmt [FmtVal]
vals Maybe Text
tr) = [HeaderLine] -> HeaderLine
forall a. [a] -> a
head [HeaderLine]
nexthdrs
fmt' :: FmtLine
fmt' = Int -> FmtLine -> FmtLine
fmtAddColLeft Int
1 FmtLine
fmt
val :: FmtVal
val = Int -> LastInGroup -> Text -> FmtVal
Hdr ([HeaderLine] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [HeaderLine]
nexthdrs) LastInGroup
False Text
key
in ( (FmtLine -> [FmtVal] -> Maybe Text -> HeaderLine
HdrLine FmtLine
fmt' (FmtVal
val FmtVal -> [FmtVal] -> [FmtVal]
forall a. a -> [a] -> [a]
: [FmtVal]
vals) Maybe Text
tr) HeaderLine -> [HeaderLine] -> [HeaderLine]
forall a. a -> [a] -> [a]
: [HeaderLine] -> [HeaderLine]
forall a. [a] -> [a]
tail [HeaderLine]
nexthdrs
, Int -> FmtLine -> FmtLine
fmtAddColLeft Int
1 FmtLine
lowestfmt
)
hdrvalstep :: PP.Pretty v
=> RenderConfig -> KVITable v -> KeySpec -> [Key]
-> ([HeaderLine], FmtLine)
hdrvalstep :: RenderConfig
-> KVITable v -> KeySpec -> [Text] -> ([HeaderLine], FmtLine)
hdrvalstep RenderConfig
_ KVITable v
_ KeySpec
_ [] = String -> ([HeaderLine], FmtLine)
forall a. HasCallStack => String -> a
error String
"HTML hdrvalstep with empty keys after matching colStackAt -- impossible"
hdrvalstep RenderConfig
cfg KVITable v
t KeySpec
steppath (Text
key:[]) =
let titles :: [Text]
titles = [Text] -> [Text]
ordering ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ [Text] -> Maybe [Text] -> [Text]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [Text] -> [Text]) -> Maybe [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ Text -> [(Text, [Text])] -> Maybe [Text]
forall a b. Eq a => a -> [(a, b)] -> Maybe b
L.lookup Text
key ([(Text, [Text])] -> Maybe [Text])
-> [(Text, [Text])] -> Maybe [Text]
forall a b. (a -> b) -> a -> b
$ KVITable v
t KVITable v
-> Getting [(Text, [Text])] (KVITable v) [(Text, [Text])]
-> [(Text, [Text])]
forall s a. s -> Getting a s a -> a
^. Getting [(Text, [Text])] (KVITable v) [(Text, [Text])]
forall v. Lens' (KVITable v) [(Text, [Text])]
keyVals
ordering :: [Text] -> [Text]
ordering = if RenderConfig -> LastInGroup
sortKeyVals RenderConfig
cfg then [Text] -> [Text]
sortWithNums else [Text] -> [Text]
forall a. a -> a
id
cvalWidths :: Text -> [Int]
cvalWidths Text
kv = ((KeySpec, v) -> Int) -> [(KeySpec, v)] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (String -> Int) -> ((KeySpec, v) -> String) -> (KeySpec, v) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc Any -> String
forall a. Show a => a -> String
show (Doc Any -> String)
-> ((KeySpec, v) -> Doc Any) -> (KeySpec, v) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. v -> Doc Any
forall a ann. Pretty a => a -> Doc ann
PP.pretty (v -> Doc Any) -> ((KeySpec, v) -> v) -> (KeySpec, v) -> Doc Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (KeySpec, v) -> v
forall a b. (a, b) -> b
snd) ([(KeySpec, v)] -> [Int]) -> [(KeySpec, v)] -> [Int]
forall a b. (a -> b) -> a -> b
$
((KeySpec, v) -> LastInGroup) -> [(KeySpec, v)] -> [(KeySpec, v)]
forall a. (a -> LastInGroup) -> [a] -> [a]
L.filter ((KeySpec -> KeySpec -> LastInGroup
forall a. Eq a => [a] -> [a] -> LastInGroup
L.isSuffixOf (KeySpec
steppath KeySpec -> KeySpec -> KeySpec
forall a. Semigroup a => a -> a -> a
<> [(Text
key, Text
kv)])) (KeySpec -> LastInGroup)
-> ((KeySpec, v) -> KeySpec) -> (KeySpec, v) -> LastInGroup
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (KeySpec, v) -> KeySpec
forall a b. (a, b) -> a
fst) ([(KeySpec, v)] -> [(KeySpec, v)])
-> [(KeySpec, v)] -> [(KeySpec, v)]
forall a b. (a -> b) -> a -> b
$
KVITable v -> [Item (KVITable v)]
forall v. KVITable v -> [Item (KVITable v)]
toList KVITable v
t
cwidth :: Text -> p
cwidth Text
c = if [LastInGroup] -> LastInGroup
forall (t :: * -> *). Foldable t => t LastInGroup -> LastInGroup
and [ RenderConfig -> LastInGroup
hideBlankCols RenderConfig
cfg
, Int
0 Int -> Int -> LastInGroup
forall a. Eq a => a -> a -> LastInGroup
== ([Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ Text -> [Int]
cvalWidths Text
c) ]
then p
0
else p
1
fmt :: FmtLine
fmt = [Int] -> FmtLine
FmtLine ([Int] -> FmtLine) -> [Int] -> FmtLine
forall a b. (a -> b) -> a -> b
$ (Text -> Int) -> [Text] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Int
forall p. Num p => Text -> p
cwidth [Text]
titles
in ( [ FmtLine -> [FmtVal] -> Maybe Text -> HeaderLine
HdrLine FmtLine
fmt (Int -> LastInGroup -> Text -> FmtVal
Hdr Int
1 LastInGroup
False (Text -> FmtVal) -> [Text] -> [FmtVal]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
titles) (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
key) ], FmtLine
fmt)
hdrvalstep RenderConfig
cfg KVITable v
t KeySpec
steppath (Text
key:[Text]
keys) =
let titles :: [Text]
titles = [Text] -> [Text]
ordering ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ [Text] -> Maybe [Text] -> [Text]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [Text] -> [Text]) -> Maybe [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ Text -> [(Text, [Text])] -> Maybe [Text]
forall a b. Eq a => a -> [(a, b)] -> Maybe b
L.lookup Text
key ([(Text, [Text])] -> Maybe [Text])
-> [(Text, [Text])] -> Maybe [Text]
forall a b. (a -> b) -> a -> b
$ KVITable v
t KVITable v
-> Getting [(Text, [Text])] (KVITable v) [(Text, [Text])]
-> [(Text, [Text])]
forall s a. s -> Getting a s a -> a
^. Getting [(Text, [Text])] (KVITable v) [(Text, [Text])]
forall v. Lens' (KVITable v) [(Text, [Text])]
keyVals
ordering :: [Text] -> [Text]
ordering = if RenderConfig -> LastInGroup
sortKeyVals RenderConfig
cfg then [Text] -> [Text]
sortWithNums else [Text] -> [Text]
forall a. a -> a
id
subhdrsV :: Text -> ([HeaderLine], FmtLine)
subhdrsV Text
v = RenderConfig
-> KVITable v -> KeySpec -> [Text] -> ([HeaderLine], FmtLine)
forall v.
Pretty v =>
RenderConfig
-> KVITable v -> KeySpec -> [Text] -> ([HeaderLine], FmtLine)
hdrvalstep RenderConfig
cfg KVITable v
t (KeySpec
steppath KeySpec -> KeySpec -> KeySpec
forall a. Semigroup a => a -> a -> a
<> [(Text
key,Text
v)]) [Text]
keys
subTtlHdrs :: [ ([HeaderLine], FmtLine) ]
subTtlHdrs :: [([HeaderLine], FmtLine)]
subTtlHdrs = Text -> ([HeaderLine], FmtLine)
subhdrsV (Text -> ([HeaderLine], FmtLine))
-> [Text] -> [([HeaderLine], FmtLine)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
titles
subhdrs :: [([HeaderLine], FmtLine)]
subhdrs = if RenderConfig -> LastInGroup
hideBlankCols RenderConfig
cfg
then [([HeaderLine], FmtLine)]
subTtlHdrs
else Int -> ([HeaderLine], FmtLine) -> [([HeaderLine], FmtLine)]
forall a. Int -> a -> [a]
L.replicate ([Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
titles) (([HeaderLine], FmtLine) -> [([HeaderLine], FmtLine)])
-> ([HeaderLine], FmtLine) -> [([HeaderLine], FmtLine)]
forall a b. (a -> b) -> a -> b
$ [([HeaderLine], FmtLine)] -> ([HeaderLine], FmtLine)
forall a. [a] -> a
head [([HeaderLine], FmtLine)]
subTtlHdrs
subhdr_rollup :: [HeaderLine]
subhdr_rollup = [HeaderLine] -> HeaderLine
forall a. Semigroup a => [a] -> a
joinHdrs ([HeaderLine] -> HeaderLine) -> [[HeaderLine]] -> [HeaderLine]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[HeaderLine]] -> [[HeaderLine]]
forall a. [[a]] -> [[a]]
L.transpose (([HeaderLine], FmtLine) -> [HeaderLine]
forall a b. (a, b) -> a
fst (([HeaderLine], FmtLine) -> [HeaderLine])
-> [([HeaderLine], FmtLine)] -> [[HeaderLine]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [([HeaderLine], FmtLine)]
subhdrs)
joinHdrs :: [a] -> a
joinHdrs [a]
hl = (a -> a -> a) -> a -> [a] -> a
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl a -> a -> a
forall a. Semigroup a => a -> a -> a
(<>) ([a] -> a
forall a. [a] -> a
head [a]
hl) ([a] -> [a]
forall a. [a] -> [a]
tail [a]
hl)
superFmt :: ([HeaderLine], b) -> Int
superFmt ([HeaderLine], b)
sub = let FmtLine [Int]
subcols = HeaderLine -> FmtLine
hdrFmt (HeaderLine -> FmtLine) -> HeaderLine -> FmtLine
forall a b. (a -> b) -> a -> b
$ [HeaderLine] -> HeaderLine
forall a. [a] -> a
last ([HeaderLine] -> HeaderLine) -> [HeaderLine] -> HeaderLine
forall a b. (a -> b) -> a -> b
$ ([HeaderLine], b) -> [HeaderLine]
forall a b. (a, b) -> a
fst ([HeaderLine], b)
sub
in if [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Int]
subcols Int -> Int -> LastInGroup
forall a. Eq a => a -> a -> LastInGroup
== Int
0
then Int
0
else [Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ (Int -> LastInGroup) -> [Int] -> [Int]
forall a. (a -> LastInGroup) -> [a] -> [a]
L.filter (Int -> Int -> LastInGroup
forall a. Eq a => a -> a -> LastInGroup
/= Int
0) [Int]
subcols
topfmt :: FmtLine
topfmt = [Int] -> FmtLine
FmtLine (([HeaderLine], FmtLine) -> Int
forall b. ([HeaderLine], b) -> Int
superFmt (([HeaderLine], FmtLine) -> Int)
-> [([HeaderLine], FmtLine)] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [([HeaderLine], FmtLine)]
subhdrs)
tophdr :: HeaderLine
tophdr = FmtLine -> [FmtVal] -> Maybe Text -> HeaderLine
HdrLine FmtLine
topfmt (Int -> LastInGroup -> Text -> FmtVal
Hdr Int
1 LastInGroup
False (Text -> FmtVal) -> [Text] -> [FmtVal]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
titles) (Maybe Text -> HeaderLine) -> Maybe Text -> HeaderLine
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just Text
key
in ( HeaderLine
tophdr HeaderLine -> [HeaderLine] -> [HeaderLine]
forall a. a -> [a] -> [a]
: [HeaderLine]
subhdr_rollup, [FmtLine] -> FmtLine
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
F.fold (([HeaderLine], FmtLine) -> FmtLine
forall a b. (a, b) -> b
snd (([HeaderLine], FmtLine) -> FmtLine)
-> [([HeaderLine], FmtLine)] -> [FmtLine]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [([HeaderLine], FmtLine)]
subTtlHdrs))
renderSeq :: PP.Pretty v
=> RenderConfig -> FmtLine -> [Key] -> KVITable v -> Html ()
renderSeq :: RenderConfig -> FmtLine -> [Text] -> KVITable v -> Html ()
renderSeq RenderConfig
cfg FmtLine
fmt [Text]
keys KVITable v
t =
([FmtVal] -> Html ()) -> [[FmtVal]] -> Html ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (([FmtVal] -> Maybe Text -> Html ())
-> Maybe Text -> [FmtVal] -> Html ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip (FmtLine -> [FmtVal] -> Maybe Text -> Html ()
fmtRender FmtLine
fmt) Maybe Text
forall a. Maybe a
Nothing) ([[FmtVal]] -> Html ()) -> [[FmtVal]] -> Html ()
forall a b. (a -> b) -> a -> b
$ [Text] -> KeySpec -> [[FmtVal]]
htmlRows [Text]
keys []
where
mkVal :: v -> FmtVal
mkVal = Int -> LastInGroup -> Text -> FmtVal
Val Int
1 LastInGroup
False (Text -> FmtVal) -> (v -> Text) -> v -> FmtVal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text) -> (v -> String) -> v -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc Any -> String
forall a. Show a => a -> String
show (Doc Any -> String) -> (v -> Doc Any) -> v -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. v -> Doc Any
forall a ann. Pretty a => a -> Doc ann
PP.pretty
htmlRows :: [Key] -> KeySpec -> [ [FmtVal] ]
htmlRows :: [Text] -> KeySpec -> [[FmtVal]]
htmlRows [] KeySpec
path =
let v :: Maybe v
v = KeySpec -> KVITable v -> Maybe v
forall v. KeySpec -> KVITable v -> Maybe v
lookup KeySpec
path KVITable v
t
skip :: LastInGroup
skip = case Maybe v
v of
Maybe v
Nothing -> RenderConfig -> LastInGroup
hideBlankRows RenderConfig
cfg
Just v
_ -> LastInGroup
False
row :: FmtVal
row = FmtVal -> (v -> FmtVal) -> Maybe v -> FmtVal
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Int -> LastInGroup -> Text -> FmtVal
Val Int
1 LastInGroup
False Text
"") v -> FmtVal
mkVal Maybe v
v
in if LastInGroup
skip then [] else [ [FmtVal
row] ]
htmlRows (Text
key:[Text]
kseq) KeySpec
path
| RenderConfig -> Maybe Text
colStackAt RenderConfig
cfg Maybe Text -> Maybe Text -> LastInGroup
forall a. Eq a => a -> a -> LastInGroup
== Text -> Maybe Text
forall a. a -> Maybe a
Just Text
key =
let filterOrDefaultBlankRows :: [[Maybe FmtVal]] -> [[FmtVal]]
filterOrDefaultBlankRows =
([Maybe FmtVal] -> [FmtVal]) -> [[Maybe FmtVal]] -> [[FmtVal]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Maybe FmtVal -> FmtVal) -> [Maybe FmtVal] -> [FmtVal]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FmtVal -> (FmtVal -> FmtVal) -> Maybe FmtVal -> FmtVal
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Int -> LastInGroup -> Text -> FmtVal
Val Int
1 LastInGroup
False Text
"") FmtVal -> FmtVal
forall a. a -> a
id)) ([[Maybe FmtVal]] -> [[FmtVal]])
-> ([[Maybe FmtVal]] -> [[Maybe FmtVal]])
-> [[Maybe FmtVal]]
-> [[FmtVal]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
if RenderConfig -> LastInGroup
hideBlankRows RenderConfig
cfg
then ([Maybe FmtVal] -> LastInGroup)
-> [[Maybe FmtVal]] -> [[Maybe FmtVal]]
forall a. (a -> LastInGroup) -> [a] -> [a]
L.filter (LastInGroup -> LastInGroup
not (LastInGroup -> LastInGroup)
-> ([Maybe FmtVal] -> LastInGroup) -> [Maybe FmtVal] -> LastInGroup
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe FmtVal -> LastInGroup) -> [Maybe FmtVal] -> LastInGroup
forall (t :: * -> *) a.
Foldable t =>
(a -> LastInGroup) -> t a -> LastInGroup
all Maybe FmtVal -> LastInGroup
forall a. Maybe a -> LastInGroup
isNothing)
else [[Maybe FmtVal]] -> [[Maybe FmtVal]]
forall a. a -> a
id
in [[Maybe FmtVal]] -> [[FmtVal]]
filterOrDefaultBlankRows ([[Maybe FmtVal]] -> [[FmtVal]]) -> [[Maybe FmtVal]] -> [[FmtVal]]
forall a b. (a -> b) -> a -> b
$
[ [Text] -> KeySpec -> [Maybe FmtVal]
multivalRows (Text
keyText -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:[Text]
kseq) KeySpec
path ]
| LastInGroup
otherwise =
let keyvals :: [Text]
keyvals = [Text] -> [Text]
ordering ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ [Text] -> Maybe [Text] -> [Text]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [Text] -> [Text]) -> Maybe [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ Text -> [(Text, [Text])] -> Maybe [Text]
forall a b. Eq a => a -> [(a, b)] -> Maybe b
L.lookup Text
key ([(Text, [Text])] -> Maybe [Text])
-> [(Text, [Text])] -> Maybe [Text]
forall a b. (a -> b) -> a -> b
$ KVITable v
t KVITable v
-> Getting [(Text, [Text])] (KVITable v) [(Text, [Text])]
-> [(Text, [Text])]
forall s a. s -> Getting a s a -> a
^. Getting [(Text, [Text])] (KVITable v) [(Text, [Text])]
forall v. Lens' (KVITable v) [(Text, [Text])]
keyVals
ordering :: [Text] -> [Text]
ordering = if RenderConfig -> LastInGroup
sortKeyVals RenderConfig
cfg then [Text] -> [Text]
sortWithNums else [Text] -> [Text]
forall a. a -> a
id
subrows :: Text -> [[FmtVal]]
subrows Text
keyval = [Text] -> KeySpec -> [[FmtVal]]
htmlRows [Text]
kseq (KeySpec -> [[FmtVal]]) -> KeySpec -> [[FmtVal]]
forall a b. (a -> b) -> a -> b
$ KeySpec
path KeySpec -> KeySpec -> KeySpec
forall a. Semigroup a => a -> a -> a
<> [(Text
key,Text
keyval)]
endOfGroup :: LastInGroup
endOfGroup = Text
key Text -> [Text] -> LastInGroup
forall (t :: * -> *) a.
(Foldable t, Eq a) =>
a -> t a -> LastInGroup
`elem` RenderConfig -> [Text]
rowGroup RenderConfig
cfg
addSubrows :: [[FmtVal]] -> Text -> [[FmtVal]]
addSubrows [[FmtVal]]
ret Text
keyval =
let sr :: [[FmtVal]]
sr = Text -> [[FmtVal]]
subrows Text
keyval
in [[FmtVal]]
ret [[FmtVal]] -> [[FmtVal]] -> [[FmtVal]]
forall a. Semigroup a => a -> a -> a
<> (([[FmtVal]], Maybe Text) -> [[FmtVal]]
forall a b. (a, b) -> a
fst (([[FmtVal]], Maybe Text) -> [[FmtVal]])
-> ([[FmtVal]], Maybe Text) -> [[FmtVal]]
forall a b. (a -> b) -> a -> b
$
(([[FmtVal]], Maybe Text)
-> (LastInGroup, [FmtVal]) -> ([[FmtVal]], Maybe Text))
-> ([[FmtVal]], Maybe Text)
-> [(LastInGroup, [FmtVal])]
-> ([[FmtVal]], Maybe Text)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (Int
-> ([[FmtVal]], Maybe Text)
-> (LastInGroup, [FmtVal])
-> ([[FmtVal]], Maybe Text)
leftAdd ([[FmtVal]] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[FmtVal]]
sr)) ([],Text -> Maybe Text
forall a. a -> Maybe a
Just Text
keyval) ([(LastInGroup, [FmtVal])] -> ([[FmtVal]], Maybe Text))
-> [(LastInGroup, [FmtVal])] -> ([[FmtVal]], Maybe Text)
forall a b. (a -> b) -> a -> b
$
[(LastInGroup, [FmtVal])] -> [(LastInGroup, [FmtVal])]
forall a. [a] -> [a]
reverse ([(LastInGroup, [FmtVal])] -> [(LastInGroup, [FmtVal])])
-> [(LastInGroup, [FmtVal])] -> [(LastInGroup, [FmtVal])]
forall a b. (a -> b) -> a -> b
$ [LastInGroup] -> [[FmtVal]] -> [(LastInGroup, [FmtVal])]
forall a b. [a] -> [b] -> [(a, b)]
zip (LastInGroup
endOfGroupLastInGroup -> [LastInGroup] -> [LastInGroup]
forall a. a -> [a] -> [a]
: LastInGroup -> [LastInGroup]
forall a. a -> [a]
L.repeat LastInGroup
False) ([[FmtVal]] -> [(LastInGroup, [FmtVal])])
-> [[FmtVal]] -> [(LastInGroup, [FmtVal])]
forall a b. (a -> b) -> a -> b
$ [[FmtVal]] -> [[FmtVal]]
forall a. [a] -> [a]
reverse [[FmtVal]]
sr)
leftAdd :: Int
-> ([[FmtVal]], Maybe Text)
-> (LastInGroup, [FmtVal])
-> ([[FmtVal]], Maybe Text)
leftAdd Int
nrows ([[FmtVal]]
acc,Maybe Text
mb'kv) (LastInGroup
endGrp, [FmtVal]
subrow) =
let sr :: [FmtVal]
sr = LastInGroup -> FmtVal -> FmtVal
setValGrouping LastInGroup
endGrp (FmtVal -> FmtVal) -> [FmtVal] -> [FmtVal]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FmtVal]
subrow
setValGrouping :: LastInGroup -> FmtVal -> FmtVal
setValGrouping LastInGroup
g (Val Int
h LastInGroup
g' Text
v) = Int -> LastInGroup -> Text -> FmtVal
Val Int
h (LastInGroup
g LastInGroup -> LastInGroup -> LastInGroup
|| LastInGroup
g') Text
v
setValGrouping LastInGroup
g (Hdr Int
h LastInGroup
g' Text
v) = Int -> LastInGroup -> Text -> FmtVal
Hdr Int
h (LastInGroup
g LastInGroup -> LastInGroup -> LastInGroup
|| LastInGroup
g') Text
v
in ( [[FmtVal]]
acc [[FmtVal]] -> [[FmtVal]] -> [[FmtVal]]
forall a. Semigroup a => a -> a -> a
<> [ (case Maybe Text
mb'kv of
Maybe Text
Nothing -> [FmtVal]
sr
Just Text
kv -> let w :: Int
w = if RenderConfig -> LastInGroup
rowRepeat RenderConfig
cfg
then Int
1
else Int
nrows
in Int -> LastInGroup -> Text -> FmtVal
Hdr Int
w LastInGroup
endOfGroup Text
kv FmtVal -> [FmtVal] -> [FmtVal]
forall a. a -> [a] -> [a]
: [FmtVal]
sr
) ]
, if RenderConfig -> LastInGroup
rowRepeat RenderConfig
cfg then Maybe Text
mb'kv else Maybe Text
forall a. Maybe a
Nothing)
in ([[FmtVal]] -> Text -> [[FmtVal]])
-> [[FmtVal]] -> [Text] -> [[FmtVal]]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl [[FmtVal]] -> Text -> [[FmtVal]]
addSubrows [] [Text]
keyvals
multivalRows :: [Text] -> KeySpec -> [Maybe FmtVal]
multivalRows [] KeySpec
_ = String -> [Maybe FmtVal]
forall a. HasCallStack => String -> a
error String
"HTML multivalRows cannot be called with no keys!"
multivalRows (Text
key:[]) KeySpec
path =
let keyvals :: [Text]
keyvals = [Text] -> [Text]
ordering ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ [Text] -> Maybe [Text] -> [Text]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [Text] -> [Text]) -> Maybe [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ Text -> [(Text, [Text])] -> Maybe [Text]
forall a b. Eq a => a -> [(a, b)] -> Maybe b
L.lookup Text
key ([(Text, [Text])] -> Maybe [Text])
-> [(Text, [Text])] -> Maybe [Text]
forall a b. (a -> b) -> a -> b
$ KVITable v
t KVITable v
-> Getting [(Text, [Text])] (KVITable v) [(Text, [Text])]
-> [(Text, [Text])]
forall s a. s -> Getting a s a -> a
^. Getting [(Text, [Text])] (KVITable v) [(Text, [Text])]
forall v. Lens' (KVITable v) [(Text, [Text])]
keyVals
ordering :: [Text] -> [Text]
ordering = if RenderConfig -> LastInGroup
sortKeyVals RenderConfig
cfg then [Text] -> [Text]
sortWithNums else [Text] -> [Text]
forall a. a -> a
id
in (\Text
v -> v -> FmtVal
mkVal (v -> FmtVal) -> Maybe v -> Maybe FmtVal
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeySpec -> KVITable v -> Maybe v
forall v. KeySpec -> KVITable v -> Maybe v
lookup (KeySpec
path KeySpec -> KeySpec -> KeySpec
forall a. Semigroup a => a -> a -> a
<> [(Text
key,Text
v)]) KVITable v
t) (Text -> Maybe FmtVal) -> [Text] -> [Maybe FmtVal]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
keyvals
multivalRows (Text
key:[Text]
kseq) KeySpec
path =
let keyvals :: [Text]
keyvals = [Text] -> [Text]
ordering ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ [Text] -> Maybe [Text] -> [Text]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [Text] -> [Text]) -> Maybe [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ Text -> [(Text, [Text])] -> Maybe [Text]
forall a b. Eq a => a -> [(a, b)] -> Maybe b
L.lookup Text
key ([(Text, [Text])] -> Maybe [Text])
-> [(Text, [Text])] -> Maybe [Text]
forall a b. (a -> b) -> a -> b
$ KVITable v
t KVITable v
-> Getting [(Text, [Text])] (KVITable v) [(Text, [Text])]
-> [(Text, [Text])]
forall s a. s -> Getting a s a -> a
^. Getting [(Text, [Text])] (KVITable v) [(Text, [Text])]
forall v. Lens' (KVITable v) [(Text, [Text])]
keyVals
ordering :: [Text] -> [Text]
ordering = if RenderConfig -> LastInGroup
sortKeyVals RenderConfig
cfg then [Text] -> [Text]
sortWithNums else [Text] -> [Text]
forall a. a -> a
id
in (Text -> [Maybe FmtVal]) -> [Text] -> [Maybe FmtVal]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\Text
v -> [Text] -> KeySpec -> [Maybe FmtVal]
multivalRows [Text]
kseq (KeySpec
path KeySpec -> KeySpec -> KeySpec
forall a. Semigroup a => a -> a -> a
<> [(Text
key,Text
v)])) [Text]
keyvals