{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

-- | This module provides the 'KVITable' 'render' function for
-- rendering the table in a HTML table format.  The various HTML table
-- entries have class designators that allow the user to provide CSS
-- to adjust the appearance of the table.

module Data.KVITable.Render.HTML
  (
    render
    -- re-export Render definitions to save the caller an additional import
  , RenderConfig(..)
  , defaultRenderConfig
  )
where

import qualified Data.Foldable as F
import qualified Data.List as L
import           Data.List.NonEmpty ( NonEmpty( (:|) ) )
import qualified Data.List.NonEmpty as NEL
import           Data.Maybe ( isNothing )
import           Data.Name ( Named, HTMLStyle, UTF8, convertName
                           , convertStyle, nameText )
import           Data.String ( fromString )
import           Data.Text ( Text )
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import           Lens.Micro ( (^.) )
import           Lucid
import           Numeric.Natural
import           Text.Sayable

import           Data.KVITable as KVIT
import           Data.KVITable.Internal.Helpers
import           Data.KVITable.Render
import           Data.KVITable.Render.Internal

import           Prelude hiding ( lookup )


-- | Renders the specified table in HTML format, using the specified
-- 'RenderConfig' controls.  The output is only the @<table>@
-- definition; it is intended to be embedded in a larger HTML
-- document.

render :: Sayable "html" v => RenderConfig -> KVITable v -> Text
render :: forall v. Sayable "html" v => RenderConfig -> KVITable v -> Text
render RenderConfig
cfg KVITable v
t =
  let kmap :: (TblHdrs, TblHdrs)
kmap = RenderConfig -> KeyVals -> (TblHdrs, TblHdrs)
renderingKeyVals RenderConfig
cfg (KeyVals -> (TblHdrs, TblHdrs)) -> KeyVals -> (TblHdrs, TblHdrs)
forall a b. (a -> b) -> a -> b
$ KVITable v
t KVITable v -> Getting KeyVals (KVITable v) KeyVals -> KeyVals
forall s a. s -> Getting a s a -> a
^. Getting KeyVals (KVITable v) KeyVals
forall v (f :: * -> *).
Functor f =>
(KeyVals -> f KeyVals) -> KVITable v -> f (KVITable v)
keyVals
      (FmtLine
fmt, HtmlT Identity ()
hdr) = RenderConfig
-> (TblHdrs, TblHdrs) -> KVITable v -> (FmtLine, HtmlT Identity ())
forall v.
Sayable "html" v =>
RenderConfig
-> (TblHdrs, TblHdrs) -> KVITable v -> (FmtLine, HtmlT Identity ())
renderHdrs RenderConfig
cfg (TblHdrs, TblHdrs)
kmap KVITable v
t
      bdy :: HtmlT Identity ()
bdy = RenderConfig
-> FmtLine -> (TblHdrs, TblHdrs) -> KVITable v -> HtmlT Identity ()
forall v.
Sayable "html" v =>
RenderConfig
-> FmtLine -> (TblHdrs, TblHdrs) -> KVITable v -> HtmlT Identity ()
renderSeq RenderConfig
cfg FmtLine
fmt (TblHdrs, TblHdrs)
kmap KVITable v
t
  in Text -> Text
TL.toStrict (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ HtmlT Identity () -> Text
forall a. Html a -> Text
renderText (HtmlT Identity () -> Text) -> HtmlT Identity () -> Text
forall a b. (a -> b) -> a -> b
$
     [Attribute] -> HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
table_ [ Text -> Attribute
class_ Text
"kvitable" ] (HtmlT Identity () -> HtmlT Identity ())
-> HtmlT Identity () -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$
     do HtmlT Identity ()
-> (Name "caption" -> HtmlT Identity ())
-> Maybe (Name "caption")
-> HtmlT Identity ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe HtmlT Identity ()
forall a. Monoid a => a
mempty (HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
caption_ (HtmlT Identity () -> HtmlT Identity ())
-> (Name "caption" -> HtmlT Identity ())
-> Name "caption"
-> HtmlT Identity ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Named HTMLStyle "caption" -> HtmlT Identity ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
forall (m :: * -> *).
Monad m =>
Named HTMLStyle "caption" -> HtmlT m ()
toHtml (Named HTMLStyle "caption" -> HtmlT Identity ())
-> (Name "caption" -> Named HTMLStyle "caption")
-> Name "caption"
-> HtmlT Identity ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (inpStyle :: Symbol) (outStyle :: Symbol)
       (nameTy :: Symbol).
ConvertNameStyle inpStyle outStyle nameTy =>
Named inpStyle nameTy -> Named outStyle nameTy
convertStyle @UTF8 @HTMLStyle)
          (Maybe (Name "caption") -> HtmlT Identity ())
-> Maybe (Name "caption") -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$ RenderConfig -> Maybe (Name "caption")
Data.KVITable.Render.caption RenderConfig
cfg
        [Attribute] -> HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
thead_ [ Text -> Attribute
class_ Text
"kvitable_head" ] HtmlT Identity ()
hdr
        [Attribute] -> HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
tbody_ [ Text -> Attribute
class_ Text
"kvitable_body" ] HtmlT Identity ()
bdy


instance ToHtml (Named HTMLStyle nameOf) where
  toHtml :: forall (m :: * -> *).
Monad m =>
Named HTMLStyle nameOf -> HtmlT m ()
toHtml = Text -> HtmlT m ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
forall (m :: * -> *). Monad m => Text -> HtmlT m ()
toHtmlRaw (Text -> HtmlT m ())
-> (Named HTMLStyle nameOf -> Text)
-> Named HTMLStyle nameOf
-> HtmlT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Named HTMLStyle nameOf -> Text
forall (nm :: Symbol). Named HTMLStyle nm -> Text
forall (style :: Symbol) (nm :: Symbol).
NameText style =>
Named style nm -> Text
nameText
  -- Note: toHtml uses toHtmlRaw because Named HTMLStyle is already escaped
  toHtmlRaw :: forall (m :: * -> *).
Monad m =>
Named HTMLStyle nameOf -> HtmlT m ()
toHtmlRaw = Text -> HtmlT m ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
forall (m :: * -> *). Monad m => Text -> HtmlT m ()
toHtmlRaw (Text -> HtmlT m ())
-> (Named HTMLStyle nameOf -> Text)
-> Named HTMLStyle nameOf
-> HtmlT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Named HTMLStyle nameOf -> Text
forall (nm :: Symbol). Named HTMLStyle nm -> Text
forall (style :: Symbol) (nm :: Symbol).
NameText style =>
Named style nm -> Text
nameText

----------------------------------------------------------------------

data FmtLine = FmtLine [Natural]  -- colspans, length is # columns

instance Semigroup FmtLine where
  (FmtLine [Natural]
c1) <> :: FmtLine -> FmtLine -> FmtLine
<> (FmtLine [Natural]
c2) = [Natural] -> FmtLine
FmtLine ([Natural] -> FmtLine) -> [Natural] -> FmtLine
forall a b. (a -> b) -> a -> b
$ [Natural]
c1 [Natural] -> [Natural] -> [Natural]
forall a. Semigroup a => a -> a -> a
<> [Natural]
c2

instance Monoid FmtLine where
  mempty :: FmtLine
mempty = [Natural] -> FmtLine
FmtLine [Natural]
forall a. Monoid a => a
mempty

fmtAddColLeft :: Natural -> FmtLine -> FmtLine
fmtAddColLeft :: Natural -> FmtLine -> FmtLine
fmtAddColLeft Natural
lspan (FmtLine [Natural]
col) = [Natural] -> FmtLine
FmtLine ([Natural] -> FmtLine) -> [Natural] -> FmtLine
forall a b. (a -> b) -> a -> b
$ Natural
lspan Natural -> [Natural] -> [Natural]
forall a. a -> [a] -> [a]
: [Natural]
col

data FmtVal = Val Span LastInGroup Bool Text
            | Hdr Span LastInGroup (Named HTMLStyle "column header")
data Span = Singular | Cols Width | Rows Height
type Height = Natural
type Width = Natural
type LastInGroup = Bool
type RightLabel = Named HTMLStyle "column header"

fmtRender :: FmtLine -> Maybe RightLabel -> [FmtVal] -> Html ()
fmtRender :: FmtLine
-> Maybe (Named HTMLStyle "column header")
-> [FmtVal]
-> HtmlT Identity ()
fmtRender (FmtLine [Natural]
cols) Maybe (Named HTMLStyle "column header")
mbRLabel [FmtVal]
vals = do
  [Attribute] -> HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
tr_ [ Text -> Attribute
class_ Text
"kvitable_tr" ] (HtmlT Identity () -> HtmlT Identity ())
-> HtmlT Identity () -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$
    let excessColCnt :: Int
excessColCnt = [Natural] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Natural]
cols Int -> Int -> Int
forall a. Num a => a -> a -> a
- [FmtVal] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [FmtVal]
vals
        cell :: (Natural, FmtVal) -> t
cell (Natural
w,Hdr Span
h LastInGroup
l Named HTMLStyle "column header"
v) =
          let a :: [[Attribute]]
a = [ [ Text -> Attribute
class_ Text
"kvitable_th" ]
                  , case Span
h of
                      Span
Singular -> [Attribute]
forall a. Monoid a => a
mempty
                      Cols Natural
n -> if Natural
w Natural -> Natural -> LastInGroup
forall a. Eq a => a -> a -> LastInGroup
== Natural
1 LastInGroup -> LastInGroup -> LastInGroup
&& Natural
n Natural -> Natural -> LastInGroup
forall a. Eq a => a -> a -> LastInGroup
== Natural
1
                                then [Attribute]
forall a. Monoid a => a
mempty
                                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
$ Natural -> String
forall a. Show a => a -> String
show (Natural
nNatural -> Natural -> Natural
forall a. Num a => a -> a -> a
*Natural
w)
                                     , Text -> Attribute
class_ Text
" multicol"
                                     ]
                      Rows Natural
1 -> [Attribute]
forall a. Monoid a => a
mempty
                      Rows Natural
n -> [ 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
$ Natural -> String
forall a. Show a => a -> String
show Natural
n ]
                  , if Natural
w Natural -> Natural -> LastInGroup
forall a. Eq a => a -> a -> LastInGroup
== Natural
1
                       LastInGroup -> LastInGroup -> LastInGroup
|| case Span
h of
                            Cols Natural
n | Natural
n Natural -> Natural -> LastInGroup
forall a. Ord a => a -> a -> LastInGroup
> Natural
1 -> LastInGroup
True
                            Span
_ -> LastInGroup
False
                    then [Attribute]
forall a. Monoid a => a
mempty
                    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
$ Natural -> String
forall a. Show a => a -> String
show Natural
w
                         , Text -> Attribute
class_ Text
" multicol" ]
                  , if LastInGroup
l then [ Text -> Attribute
class_ Text
" last_in_group" ] else [Attribute]
forall a. Monoid a => a
mempty
                  ]
          in [Attribute] -> t -> t
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) (arg -> t
forall arg result. Term arg result => arg -> result
div_ (arg -> t) -> arg -> t
forall a b. (a -> b) -> a -> b
$ HtmlT m () -> arg
forall arg result. Term arg result => arg -> result
span_ (HtmlT m () -> arg) -> HtmlT m () -> arg
forall a b. (a -> b) -> a -> b
$ Named HTMLStyle "column header" -> HtmlT m ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
forall (m :: * -> *).
Monad m =>
Named HTMLStyle "column header" -> HtmlT m ()
toHtml Named HTMLStyle "column header"
v)
        cell (Natural
w,Val Span
h LastInGroup
l LastInGroup
i Text
v) =
          let a :: [[Attribute]]
a = [ [ Text -> Attribute
class_ Text
"kvitable_td" ]
                  , case Span
h of
                      Span
Singular -> [Attribute]
forall a. Monoid a => a
mempty
                      Cols Natural
1 -> [Attribute]
forall a. Monoid a => a
mempty
                      Cols Natural
n -> [ 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
$ Natural -> String
forall a. Show a => a -> String
show Natural
n ]
                      Rows Natural
1 -> [Attribute]
forall a. Monoid a => a
mempty
                      Rows Natural
n -> [ 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
$ Natural -> String
forall a. Show a => a -> String
show Natural
n ]
                  , if Natural
w Natural -> Natural -> LastInGroup
forall a. Eq a => a -> a -> LastInGroup
== Natural
1 then [Attribute]
forall a. Monoid a => a
mempty
                    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
$ Natural -> String
forall a. Show a => a -> String
show Natural
w
                         , Text -> Attribute
class_ Text
" multicol" ]
                  , if LastInGroup
l then [ Text -> Attribute
class_ Text
" last_in_group" ] else [Attribute]
forall a. Monoid a => a
mempty
                  ]
          in [Attribute] -> HtmlT m () -> t
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) (HtmlT m () -> t) -> HtmlT m () -> t
forall a b. (a -> b) -> a -> b
$ if LastInGroup
i then HtmlT m () -> HtmlT m ()
forall arg result. Term arg result => arg -> result
i_ (Text -> HtmlT m ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
forall (m :: * -> *). Monad m => Text -> HtmlT m ()
toHtml Text
v) else Text -> HtmlT m ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
forall (m :: * -> *). Monad m => Text -> HtmlT m ()
toHtml Text
v
        labelMark :: HtmlT Identity ()
labelMark = Text -> HtmlT Identity ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
forall (m :: * -> *). Monad m => Text -> HtmlT m ()
toHtmlRaw (Text
"&nbsp;&larr;" :: Text)
        labelHtml :: Named HTMLStyle "column header" -> HtmlT Identity ()
labelHtml = [Attribute] -> HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
th_ [ Text -> Attribute
class_ Text
"rightlabel kvitable_th" ] (HtmlT Identity () -> HtmlT Identity ())
-> (Named HTMLStyle "column header" -> HtmlT Identity ())
-> Named HTMLStyle "column header"
-> HtmlT Identity ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                    (HtmlT Identity ()
labelMark HtmlT Identity () -> HtmlT Identity () -> HtmlT Identity ()
forall a. Semigroup a => a -> a -> a
<>) (HtmlT Identity () -> HtmlT Identity ())
-> (Named HTMLStyle "column header" -> HtmlT Identity ())
-> Named HTMLStyle "column header"
-> HtmlT Identity ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                    Named HTMLStyle "column header" -> HtmlT Identity ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
forall (m :: * -> *).
Monad m =>
Named HTMLStyle "column header" -> HtmlT m ()
toHtml
    in do ((Natural, FmtVal) -> HtmlT Identity ())
-> [(Natural, FmtVal)] -> HtmlT Identity ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Natural, FmtVal) -> HtmlT Identity ()
forall {arg} {t} {m :: * -> *} {t} {m :: * -> *}.
(Term arg t, Term (HtmlT m ()) arg, Term [Attribute] (t -> t),
 Term [Attribute] (HtmlT m () -> t), Monad m, Monad m) =>
(Natural, FmtVal) -> t
cell ([(Natural, FmtVal)] -> HtmlT Identity ())
-> [(Natural, FmtVal)] -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$ ((Natural, FmtVal) -> LastInGroup)
-> [(Natural, FmtVal)] -> [(Natural, FmtVal)]
forall a. (a -> LastInGroup) -> [a] -> [a]
L.filter ((Natural -> Natural -> LastInGroup
forall a. Eq a => a -> a -> LastInGroup
/= Natural
0) (Natural -> LastInGroup)
-> ((Natural, FmtVal) -> Natural)
-> (Natural, FmtVal)
-> LastInGroup
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Natural, FmtVal) -> Natural
forall a b. (a, b) -> a
fst) ([(Natural, FmtVal)] -> [(Natural, FmtVal)])
-> [(Natural, FmtVal)] -> [(Natural, FmtVal)]
forall a b. (a -> b) -> a -> b
$
            [Natural] -> [FmtVal] -> [(Natural, FmtVal)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Int -> [Natural] -> [Natural]
forall a. Int -> [a] -> [a]
drop Int
excessColCnt [Natural]
cols) [FmtVal]
vals
          HtmlT Identity ()
-> (Named HTMLStyle "column header" -> HtmlT Identity ())
-> Maybe (Named HTMLStyle "column header")
-> HtmlT Identity ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe HtmlT Identity ()
forall a. Monoid a => a
mempty Named HTMLStyle "column header" -> HtmlT Identity ()
labelHtml Maybe (Named HTMLStyle "column header")
mbRLabel


----------------------------------------------------------------------

data HeaderLine = HdrLine FmtLine HdrVals Trailer
type HdrVals = [FmtVal]
type Trailer = Maybe RightLabel

instance Semigroup HeaderLine where
  (HdrLine FmtLine
fmt1 [FmtVal]
hv1 Maybe (Named HTMLStyle "column header")
t1) <> :: HeaderLine -> HeaderLine -> HeaderLine
<> (HdrLine FmtLine
fmt2 [FmtVal]
hv2 Maybe (Named HTMLStyle "column header")
_) =
    FmtLine
-> [FmtVal]
-> Maybe (Named HTMLStyle "column header")
-> 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 (Named HTMLStyle "column header")
t1

hdrFmt :: HeaderLine -> FmtLine
hdrFmt :: HeaderLine -> FmtLine
hdrFmt (HdrLine FmtLine
fmt [FmtVal]
_ Maybe (Named HTMLStyle "column header")
_) = FmtLine
fmt

renderHdrs :: Sayable "html" v
           => RenderConfig
           -> (TblHdrs, TblHdrs)
           -> KVITable v
           -> ( FmtLine, Html () )
renderHdrs :: forall v.
Sayable "html" v =>
RenderConfig
-> (TblHdrs, TblHdrs) -> KVITable v -> (FmtLine, HtmlT Identity ())
renderHdrs RenderConfig
cfg (TblHdrs, TblHdrs)
kmap KVITable v
t = ( FmtLine
rowfmt, NonEmpty (HtmlT Identity ()) -> HtmlT Identity ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ NonEmpty (HtmlT Identity ())
hdrs )
  where
    hdrs :: NonEmpty (HtmlT Identity ())
hdrs = (HeaderLine -> HtmlT Identity ())
-> NonEmpty HeaderLine -> NonEmpty (HtmlT Identity ())
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HeaderLine -> HtmlT Identity ()
renderHdr NonEmpty HeaderLine
hrows
    (NonEmpty HeaderLine
hrows, FmtLine
rowfmt) = RenderConfig
-> KVITable v
-> (TblHdrs, TblHdrs)
-> (NonEmpty HeaderLine, FmtLine)
forall v.
Sayable "html" v =>
RenderConfig
-> KVITable v
-> (TblHdrs, TblHdrs)
-> (NonEmpty HeaderLine, FmtLine)
hdrstep RenderConfig
cfg KVITable v
t (TblHdrs, TblHdrs)
kmap
    renderHdr :: HeaderLine -> HtmlT Identity ()
renderHdr (HdrLine FmtLine
fmt [FmtVal]
hdrvals Maybe (Named HTMLStyle "column header")
trailer) = FmtLine
-> Maybe (Named HTMLStyle "column header")
-> [FmtVal]
-> HtmlT Identity ()
fmtRender FmtLine
fmt Maybe (Named HTMLStyle "column header")
trailer [FmtVal]
hdrvals

hdrstep :: Sayable "html" v
        => RenderConfig
        -> KVITable v
        -> (TblHdrs, TblHdrs)
        -> (NEL.NonEmpty HeaderLine, FmtLine)
hdrstep :: forall v.
Sayable "html" v =>
RenderConfig
-> KVITable v
-> (TblHdrs, TblHdrs)
-> (NonEmpty HeaderLine, FmtLine)
hdrstep RenderConfig
_cfg KVITable v
t ([], []) =
  let hdr :: FmtVal
hdr = Span -> LastInGroup -> Named HTMLStyle "column header" -> FmtVal
Hdr Span
Singular LastInGroup
False (Named HTMLStyle "column header" -> FmtVal)
-> Named HTMLStyle "column header" -> FmtVal
forall a b. (a -> b) -> a -> b
$ KVITable v
t KVITable v
-> Getting
     (Named HTMLStyle "column header")
     (KVITable v)
     (Named HTMLStyle "column header")
-> Named HTMLStyle "column header"
forall s a. s -> Getting a s a -> a
^. Getting
  (Named HTMLStyle "column header")
  (KVITable v)
  (Named HTMLStyle "column header")
forall v (f :: * -> *).
Functor f =>
(Named HTMLStyle "column header"
 -> f (Named HTMLStyle "column header"))
-> KVITable v -> f (KVITable v)
valueColName
      one :: [Natural]
one = Natural -> [Natural]
forall e. e -> [e]
single Natural
1
  in ( FmtLine
-> [FmtVal]
-> Maybe (Named HTMLStyle "column header")
-> HeaderLine
HdrLine ([Natural] -> FmtLine
FmtLine [Natural]
one) (FmtVal -> [FmtVal]
forall e. e -> [e]
single FmtVal
hdr) Maybe (Named HTMLStyle "column header")
forall a. Maybe a
Nothing HeaderLine -> [HeaderLine] -> NonEmpty HeaderLine
forall a. a -> [a] -> NonEmpty a
:| [HeaderLine]
forall a. Monoid a => a
mempty
     , [Natural] -> FmtLine
FmtLine [Natural]
one
     )
hdrstep RenderConfig
cfg KVITable v
t ([], TblHdrs
colKeys) =
  RenderConfig
-> KVITable v
-> TblHdrs
-> KeySpec
-> (NonEmpty HeaderLine, FmtLine)
forall v.
Sayable "html" v =>
RenderConfig
-> KVITable v
-> TblHdrs
-> KeySpec
-> (NonEmpty HeaderLine, FmtLine)
hdrvalstep RenderConfig
cfg KVITable v
t TblHdrs
colKeys KeySpec
forall a. Monoid a => a
mempty -- switch to column stacking mode
hdrstep RenderConfig
cfg KVITable v
t ((Key
key,[TblHdr]
_) : TblHdrs
keys, TblHdrs
colKeys) =
  let (HeaderLine
nexthdr0 :| [HeaderLine]
nexthdrs, FmtLine
lowestfmt) = RenderConfig
-> KVITable v
-> (TblHdrs, TblHdrs)
-> (NonEmpty HeaderLine, FmtLine)
forall v.
Sayable "html" v =>
RenderConfig
-> KVITable v
-> (TblHdrs, TblHdrs)
-> (NonEmpty HeaderLine, FmtLine)
hdrstep RenderConfig
cfg KVITable v
t (TblHdrs
keys, TblHdrs
colKeys)
      (HdrLine FmtLine
fmt [FmtVal]
vals Maybe (Named HTMLStyle "column header")
tr) = HeaderLine
nexthdr0
      fmt' :: FmtLine
fmt' = Natural -> FmtLine -> FmtLine
fmtAddColLeft Natural
1 FmtLine
fmt
      val :: FmtVal
val = Span -> LastInGroup -> Named HTMLStyle "column header" -> FmtVal
Hdr (Natural -> Span
Rows (Natural -> Span) -> Natural -> Span
forall a b. (a -> b) -> a -> b
$ [HeaderLine] -> Natural
forall (t :: * -> *) a. Foldable t => t a -> Natural
nLength [HeaderLine]
nexthdrs Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+ Natural
1) LastInGroup
False
            (Named HTMLStyle "column header" -> FmtVal)
-> Named HTMLStyle "column header" -> FmtVal
forall a b. (a -> b) -> a -> b
$ Named UTF8 "column header" -> Named HTMLStyle "column header"
forall (inpStyle :: Symbol) (outStyle :: Symbol)
       (nameTy :: Symbol).
ConvertNameStyle inpStyle outStyle nameTy =>
Named inpStyle nameTy -> Named outStyle nameTy
convertStyle (Named UTF8 "column header" -> Named HTMLStyle "column header")
-> Named UTF8 "column header" -> Named HTMLStyle "column header"
forall a b. (a -> b) -> a -> b
$ Key -> Named UTF8 "column header"
forall (style :: Symbol) (origTy :: Symbol) (newTy :: Symbol).
ConvertName style origTy newTy =>
Named style origTy -> Named style newTy
convertName Key
key
  in ( (FmtLine
-> [FmtVal]
-> Maybe (Named HTMLStyle "column header")
-> HeaderLine
HdrLine FmtLine
fmt' (FmtVal
val FmtVal -> [FmtVal] -> [FmtVal]
forall a. a -> [a] -> [a]
: [FmtVal]
vals) Maybe (Named HTMLStyle "column header")
tr) HeaderLine -> [HeaderLine] -> NonEmpty HeaderLine
forall a. a -> [a] -> NonEmpty a
:| [HeaderLine]
nexthdrs
     , Natural -> FmtLine -> FmtLine
fmtAddColLeft Natural
1 FmtLine
lowestfmt
     )

hdrvalstep :: Sayable "html" v
           => RenderConfig
           -> KVITable v
           -> TblHdrs
           -> KeySpec
           -> (NEL.NonEmpty HeaderLine, FmtLine)
hdrvalstep :: forall v.
Sayable "html" v =>
RenderConfig
-> KVITable v
-> TblHdrs
-> KeySpec
-> (NonEmpty HeaderLine, FmtLine)
hdrvalstep RenderConfig
_ KVITable v
_ [] KeySpec
_ = String -> (NonEmpty HeaderLine, FmtLine)
forall a. HasCallStack => String -> a
error String
"HTML hdrvalstep with empty keys after matching colStackAt -- impossible"
hdrvalstep RenderConfig
cfg KVITable v
t ((Key
key, [TblHdr]
titles) : []) KeySpec
steppath =
  let cvalWidths :: KeyVal -> [Int]
cvalWidths KeyVal
kv = ((KeySpec, v) -> Int) -> [(KeySpec, v)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> Int
forall a. [a] -> 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
. forall (saytag :: Symbol) a. Sayable saytag a => a -> String
sez @"html" (v -> String) -> ((KeySpec, v) -> v) -> (KeySpec, v) -> String
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 -> (Key, KeyVal) -> KeySpec
forall a. [a] -> a -> [a]
snoc KeySpec
steppath (Key
key, KeyVal
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)]
KVIT.toList KVITable v
t
      cwidth :: TblHdr -> Natural
cwidth = \case
        V KeyVal
c -> if RenderConfig -> LastInGroup
hideBlankCols RenderConfig
cfg LastInGroup -> LastInGroup -> LastInGroup
&& Int
0 Int -> Int -> LastInGroup
forall a. Eq a => a -> a -> LastInGroup
== ([Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ KeyVal -> [Int]
cvalWidths KeyVal
c) then Natural
0 else Natural
1
        AndMore Natural
_ -> Natural
1
      fmt :: FmtLine
fmt = [Natural] -> FmtLine
FmtLine (TblHdr -> Natural
cwidth (TblHdr -> Natural) -> [TblHdr] -> [Natural]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TblHdr]
titles)
      hdr :: [FmtVal]
hdr = Span -> LastInGroup -> Named HTMLStyle "column header" -> FmtVal
Hdr Span
Singular LastInGroup
False (Named HTMLStyle "column header" -> FmtVal)
-> (TblHdr -> Named HTMLStyle "column header") -> TblHdr -> FmtVal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TblHdr -> Named HTMLStyle "column header"
toHdrText (TblHdr -> FmtVal) -> [TblHdr] -> [FmtVal]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TblHdr]
titles
      k :: Named HTMLStyle "column header"
k = forall (inpStyle :: Symbol) (outStyle :: Symbol)
       (nameTy :: Symbol).
ConvertNameStyle inpStyle outStyle nameTy =>
Named inpStyle nameTy -> Named outStyle nameTy
convertStyle @UTF8 @HTMLStyle (Named UTF8 "column header" -> Named HTMLStyle "column header")
-> Named UTF8 "column header" -> Named HTMLStyle "column header"
forall a b. (a -> b) -> a -> b
$ Key -> Named UTF8 "column header"
forall (style :: Symbol) (origTy :: Symbol) (newTy :: Symbol).
ConvertName style origTy newTy =>
Named style origTy -> Named style newTy
convertName Key
key
  in ( FmtLine
-> [FmtVal]
-> Maybe (Named HTMLStyle "column header")
-> HeaderLine
HdrLine FmtLine
fmt [FmtVal]
hdr (Named HTMLStyle "column header"
-> Maybe (Named HTMLStyle "column header")
forall a. a -> Maybe a
Just Named HTMLStyle "column header"
k) HeaderLine -> [HeaderLine] -> NonEmpty HeaderLine
forall a. a -> [a] -> NonEmpty a
:| [HeaderLine]
forall a. Monoid a => a
mempty, FmtLine
fmt)
hdrvalstep RenderConfig
_cfg KVITable v
_t ((Key
_key, []) : TblHdrs
_keys) KeySpec
_steppath = String -> (NonEmpty HeaderLine, FmtLine)
forall a. HasCallStack => String -> a
error String
"cannot happen"
hdrvalstep RenderConfig
cfg KVITable v
t ((Key
key, TblHdr
ttl:[TblHdr]
ttls) : TblHdrs
keys) KeySpec
steppath =
  let
    titles :: NonEmpty TblHdr
titles = TblHdr
ttl TblHdr -> [TblHdr] -> NonEmpty TblHdr
forall a. a -> [a] -> NonEmpty a
:| [TblHdr]
ttls
    subhdrsV :: TblHdr -> (NonEmpty HeaderLine, FmtLine)
subhdrsV TblHdr
v = RenderConfig
-> KVITable v
-> TblHdrs
-> KeySpec
-> (NonEmpty HeaderLine, FmtLine)
forall v.
Sayable "html" v =>
RenderConfig
-> KVITable v
-> TblHdrs
-> KeySpec
-> (NonEmpty HeaderLine, FmtLine)
hdrvalstep RenderConfig
cfg KVITable v
t TblHdrs
keys (case TblHdr
v of
                                          V KeyVal
kv -> KeySpec -> (Key, KeyVal) -> KeySpec
forall a. [a] -> a -> [a]
snoc KeySpec
steppath (Key
key,KeyVal
kv)
                                          TblHdr
_ -> KeySpec
steppath
                                       )
    subTtlHdrs :: NEL.NonEmpty (NEL.NonEmpty HeaderLine, FmtLine)
    subTtlHdrs :: NonEmpty (NonEmpty HeaderLine, FmtLine)
subTtlHdrs = TblHdr -> (NonEmpty HeaderLine, FmtLine)
subhdrsV (TblHdr -> (NonEmpty HeaderLine, FmtLine))
-> NonEmpty TblHdr -> NonEmpty (NonEmpty HeaderLine, FmtLine)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty TblHdr
titles
    subhdrs :: NEL.NonEmpty (NEL.NonEmpty HeaderLine, FmtLine)
    subhdrs :: NonEmpty (NonEmpty HeaderLine, FmtLine)
subhdrs = if RenderConfig -> LastInGroup
hideBlankCols RenderConfig
cfg
              then NonEmpty (NonEmpty HeaderLine, FmtLine)
subTtlHdrs
              else
                -- Want to repeat the first element of subTtlHdrs to get a
                -- NonEmpty the same length as titles.  Both titles and
                -- subTtlHdrs are NonEmpty, but NonEmpty has no replicate
                -- function.
                let n :: Int
n = NonEmpty TblHdr -> Int
forall a. NonEmpty a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length NonEmpty TblHdr
titles -- >= 1 because titles is NonEmpty
                    e :: (NonEmpty HeaderLine, FmtLine)
e = NonEmpty (NonEmpty HeaderLine, FmtLine)
-> (NonEmpty HeaderLine, FmtLine)
forall a. NonEmpty a -> a
NEL.head NonEmpty (NonEmpty HeaderLine, FmtLine)
subTtlHdrs
                    tail' :: [(NonEmpty HeaderLine, FmtLine)]
tail' = Int
-> NonEmpty (NonEmpty HeaderLine, FmtLine)
-> [(NonEmpty HeaderLine, FmtLine)]
forall a. Int -> NonEmpty a -> [a]
NEL.take (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) (NonEmpty (NonEmpty HeaderLine, FmtLine)
 -> [(NonEmpty HeaderLine, FmtLine)])
-> NonEmpty (NonEmpty HeaderLine, FmtLine)
-> [(NonEmpty HeaderLine, FmtLine)]
forall a b. (a -> b) -> a -> b
$ (NonEmpty HeaderLine, FmtLine)
-> NonEmpty (NonEmpty HeaderLine, FmtLine)
forall a. a -> NonEmpty a
NEL.repeat (NonEmpty HeaderLine, FmtLine)
e
                in (NonEmpty HeaderLine, FmtLine)
e (NonEmpty HeaderLine, FmtLine)
-> [(NonEmpty HeaderLine, FmtLine)]
-> NonEmpty (NonEmpty HeaderLine, FmtLine)
forall a. a -> [a] -> NonEmpty a
:| [(NonEmpty HeaderLine, FmtLine)]
tail'
    subhdr_rollup :: NonEmpty HeaderLine
subhdr_rollup = NonEmpty HeaderLine -> HeaderLine
joinHdrs (NonEmpty HeaderLine -> HeaderLine)
-> NonEmpty (NonEmpty HeaderLine) -> NonEmpty HeaderLine
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (NonEmpty HeaderLine) -> NonEmpty (NonEmpty HeaderLine)
forall a. NonEmpty (NonEmpty a) -> NonEmpty (NonEmpty a)
NEL.transpose ((NonEmpty HeaderLine, FmtLine) -> NonEmpty HeaderLine
forall a b. (a, b) -> a
fst ((NonEmpty HeaderLine, FmtLine) -> NonEmpty HeaderLine)
-> NonEmpty (NonEmpty HeaderLine, FmtLine)
-> NonEmpty (NonEmpty HeaderLine)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (NonEmpty HeaderLine, FmtLine)
subhdrs)
    joinHdrs :: NEL.NonEmpty HeaderLine -> HeaderLine
    joinHdrs :: NonEmpty HeaderLine -> HeaderLine
joinHdrs (HeaderLine
hl0 :| [HeaderLine]
hls) = (HeaderLine -> HeaderLine -> HeaderLine)
-> HeaderLine -> [HeaderLine] -> HeaderLine
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl HeaderLine -> HeaderLine -> HeaderLine
forall a. Semigroup a => a -> a -> a
(<>) HeaderLine
hl0 [HeaderLine]
hls
    superFmt :: (NEL.NonEmpty HeaderLine, FmtLine) -> Natural
    superFmt :: (NonEmpty HeaderLine, FmtLine) -> Natural
superFmt (NonEmpty HeaderLine, FmtLine)
sub = let FmtLine [Natural]
subcols = HeaderLine -> FmtLine
hdrFmt (HeaderLine -> FmtLine) -> HeaderLine -> FmtLine
forall a b. (a -> b) -> a -> b
$ NonEmpty HeaderLine -> HeaderLine
forall a. NonEmpty a -> a
NEL.last (NonEmpty HeaderLine -> HeaderLine)
-> NonEmpty HeaderLine -> HeaderLine
forall a b. (a -> b) -> a -> b
$ (NonEmpty HeaderLine, FmtLine) -> NonEmpty HeaderLine
forall a b. (a, b) -> a
fst (NonEmpty HeaderLine, FmtLine)
sub
                   in if [Natural] -> Natural
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Natural]
subcols Natural -> Natural -> LastInGroup
forall a. Eq a => a -> a -> LastInGroup
== Natural
0
                      then Natural
0
                      else [Natural] -> Natural
forall (t :: * -> *) a. Foldable t => t a -> Natural
nLength ([Natural] -> Natural) -> [Natural] -> Natural
forall a b. (a -> b) -> a -> b
$ (Natural -> LastInGroup) -> [Natural] -> [Natural]
forall a. (a -> LastInGroup) -> [a] -> [a]
L.filter (Natural -> Natural -> LastInGroup
forall a. Eq a => a -> a -> LastInGroup
/= Natural
0) [Natural]
subcols
    topfmt :: FmtLine
topfmt = [Natural] -> FmtLine
FmtLine ([Natural] -> FmtLine) -> [Natural] -> FmtLine
forall a b. (a -> b) -> a -> b
$ NonEmpty Natural -> [Natural]
forall a. NonEmpty a -> [a]
NEL.toList ((NonEmpty HeaderLine, FmtLine) -> Natural
superFmt ((NonEmpty HeaderLine, FmtLine) -> Natural)
-> NonEmpty (NonEmpty HeaderLine, FmtLine) -> NonEmpty Natural
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (NonEmpty HeaderLine, FmtLine)
subhdrs)
    tophdr :: HeaderLine
tophdr = let h :: NonEmpty FmtVal
h = Span -> LastInGroup -> Named HTMLStyle "column header" -> FmtVal
Hdr Span
Singular LastInGroup
False (Named HTMLStyle "column header" -> FmtVal)
-> (TblHdr -> Named HTMLStyle "column header") -> TblHdr -> FmtVal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TblHdr -> Named HTMLStyle "column header"
toHdrText (TblHdr -> FmtVal) -> NonEmpty TblHdr -> NonEmpty FmtVal
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty TblHdr
titles
                 tr :: Named HTMLStyle "column header"
tr = forall (inpStyle :: Symbol) (outStyle :: Symbol)
       (nameTy :: Symbol).
ConvertNameStyle inpStyle outStyle nameTy =>
Named inpStyle nameTy -> Named outStyle nameTy
convertStyle @UTF8 @HTMLStyle (Named UTF8 "column header" -> Named HTMLStyle "column header")
-> Named UTF8 "column header" -> Named HTMLStyle "column header"
forall a b. (a -> b) -> a -> b
$ Key -> Named UTF8 "column header"
forall (style :: Symbol) (origTy :: Symbol) (newTy :: Symbol).
ConvertName style origTy newTy =>
Named style origTy -> Named style newTy
convertName Key
key
             in FmtLine
-> [FmtVal]
-> Maybe (Named HTMLStyle "column header")
-> HeaderLine
HdrLine FmtLine
topfmt (NonEmpty FmtVal -> [FmtVal]
forall a. NonEmpty a -> [a]
NEL.toList NonEmpty FmtVal
h) (Maybe (Named HTMLStyle "column header") -> HeaderLine)
-> Maybe (Named HTMLStyle "column header") -> HeaderLine
forall a b. (a -> b) -> a -> b
$ Named HTMLStyle "column header"
-> Maybe (Named HTMLStyle "column header")
forall a. a -> Maybe a
Just Named HTMLStyle "column header"
tr
  in ( HeaderLine -> NonEmpty HeaderLine -> NonEmpty HeaderLine
forall a. a -> NonEmpty a -> NonEmpty a
NEL.cons HeaderLine
tophdr NonEmpty HeaderLine
subhdr_rollup, NonEmpty FmtLine -> FmtLine
forall m. Monoid m => NonEmpty m -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
F.fold ((NonEmpty HeaderLine, FmtLine) -> FmtLine
forall a b. (a, b) -> b
snd ((NonEmpty HeaderLine, FmtLine) -> FmtLine)
-> NonEmpty (NonEmpty HeaderLine, FmtLine) -> NonEmpty FmtLine
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (NonEmpty HeaderLine, FmtLine)
subTtlHdrs))


toHdrText :: TblHdr -> Named HTMLStyle "column header"
toHdrText :: TblHdr -> Named HTMLStyle "column header"
toHdrText TblHdr
th = case TblHdr -> Either Natural (Named HTMLStyle "column header")
toHdrText' TblHdr
th of
                 Right Named HTMLStyle "column header"
t -> Named HTMLStyle "column header"
t
                 Left Natural
n -> String -> Named HTMLStyle "column header"
forall a. IsString a => String -> a
fromString (String -> Named HTMLStyle "column header")
-> String -> Named HTMLStyle "column header"
forall a b. (a -> b) -> a -> b
$ forall (saytag :: Symbol) a. Sayable saytag a => a -> String
sez @"html" (Saying "html" -> String) -> Saying "html" -> String
forall a b. (a -> b) -> a -> b
$ Text -> Text
t'Text
"{+" Text -> Natural -> Saying "html"
forall (saytag :: Symbol) m n.
(Sayable saytag m, Sayable saytag n) =>
m -> n -> Saying saytag
&+ Natural
n Saying "html" -> Char -> Saying "html"
forall (saytag :: Symbol) m n.
(Sayable saytag m, Sayable saytag n) =>
m -> n -> Saying saytag
&+ Char
'}'

toHdrText' :: TblHdr -> Either Natural (Named HTMLStyle "column header")
toHdrText' :: TblHdr -> Either Natural (Named HTMLStyle "column header")
toHdrText' = \case
  V KeyVal
kv -> Named HTMLStyle "column header"
-> Either Natural (Named HTMLStyle "column header")
forall a b. b -> Either a b
Right (Named HTMLStyle "column header"
 -> Either Natural (Named HTMLStyle "column header"))
-> Named HTMLStyle "column header"
-> Either Natural (Named HTMLStyle "column header")
forall a b. (a -> b) -> a -> b
$ forall (inpStyle :: Symbol) (outStyle :: Symbol)
       (nameTy :: Symbol).
ConvertNameStyle inpStyle outStyle nameTy =>
Named inpStyle nameTy -> Named outStyle nameTy
convertStyle @UTF8 @HTMLStyle (Named UTF8 "column header" -> Named HTMLStyle "column header")
-> Named UTF8 "column header" -> Named HTMLStyle "column header"
forall a b. (a -> b) -> a -> b
$ KeyVal -> Named UTF8 "column header"
forall (style :: Symbol) (origTy :: Symbol) (newTy :: Symbol).
ConvertName style origTy newTy =>
Named style origTy -> Named style newTy
convertName KeyVal
kv
  AndMore Natural
n -> Natural -> Either Natural (Named HTMLStyle "column header")
forall a b. a -> Either a b
Left Natural
n

----------------------------------------------------------------------

renderSeq :: Sayable "html" v
          => RenderConfig -> FmtLine
          -> (TblHdrs, TblHdrs)
          -> KVITable v
          -> Html ()
renderSeq :: forall v.
Sayable "html" v =>
RenderConfig
-> FmtLine -> (TblHdrs, TblHdrs) -> KVITable v -> HtmlT Identity ()
renderSeq RenderConfig
cfg FmtLine
fmt (TblHdrs, TblHdrs)
kmap KVITable v
t =
  let lst :: [[FmtVal]]
lst = (TblHdrs, TblHdrs) -> KeySpec -> [[FmtVal]]
htmlRows (TblHdrs, TblHdrs)
kmap KeySpec
forall a. Monoid a => a
mempty
      rndr :: [FmtVal] -> HtmlT Identity ()
rndr = FmtLine
-> Maybe (Named HTMLStyle "column header")
-> [FmtVal]
-> HtmlT Identity ()
fmtRender FmtLine
fmt Maybe (Named HTMLStyle "column header")
forall a. Maybe a
Nothing
  in [HtmlT Identity ()] -> HtmlT Identity ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ (([FmtVal] -> HtmlT Identity ())
-> [[FmtVal]] -> [HtmlT Identity ()]
forall a b. (a -> b) -> [a] -> [b]
each [FmtVal] -> HtmlT Identity ()
rndr [[FmtVal]]
lst)
  where
    each :: (a -> b) -> [a] -> [b]
each = (a -> b) -> [a] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map

    filterBlank :: [[Maybe a]] -> [[Maybe a]]
filterBlank = if RenderConfig -> LastInGroup
hideBlankRows RenderConfig
cfg
                  then ([Maybe a] -> LastInGroup) -> [[Maybe a]] -> [[Maybe a]]
forall a. (a -> LastInGroup) -> [a] -> [a]
L.filter (LastInGroup -> LastInGroup
not (LastInGroup -> LastInGroup)
-> ([Maybe a] -> LastInGroup) -> [Maybe a] -> LastInGroup
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe a -> LastInGroup) -> [Maybe a] -> LastInGroup
forall (t :: * -> *) a.
Foldable t =>
(a -> LastInGroup) -> t a -> LastInGroup
all Maybe a -> LastInGroup
forall a. Maybe a -> LastInGroup
isNothing)
                  else [[Maybe a]] -> [[Maybe a]]
forall a. a -> a
id

    mkVal :: v -> FmtVal
mkVal = Span -> LastInGroup -> LastInGroup -> Text -> FmtVal
Val Span
Singular LastInGroup
False 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
. forall (saytag :: Symbol) a. Sayable saytag a => a -> String
sez @"html"

    htmlRows :: (TblHdrs, TblHdrs) -> KeySpec -> [ [FmtVal] ]
    htmlRows :: (TblHdrs, TblHdrs) -> 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 (Span -> LastInGroup -> LastInGroup -> Text -> FmtVal
Val Span
Singular LastInGroup
False LastInGroup
False Text
"") v -> FmtVal
mkVal Maybe v
v
      in if LastInGroup
skip then [[FmtVal]]
forall a. Monoid a => a
mempty else [FmtVal] -> [[FmtVal]]
forall e. e -> [e]
single ([FmtVal] -> [[FmtVal]]) -> [FmtVal] -> [[FmtVal]]
forall a b. (a -> b) -> a -> b
$ FmtVal -> [FmtVal]
forall e. e -> [e]
single FmtVal
row
    htmlRows ([], TblHdrs
colKeyMap) KeySpec
path =
          let filterOrDefaultBlankRows :: [[Maybe FmtVal]] -> [[FmtVal]]
filterOrDefaultBlankRows =
                ([Maybe FmtVal] -> [FmtVal]) -> [[Maybe FmtVal]] -> [[FmtVal]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Maybe FmtVal -> FmtVal) -> [Maybe FmtVal] -> [FmtVal]
forall a b. (a -> b) -> [a] -> [b]
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 (Span -> LastInGroup -> LastInGroup -> Text -> FmtVal
Val Span
Singular LastInGroup
False 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
. [[Maybe FmtVal]] -> [[Maybe FmtVal]]
forall {a}. [[Maybe a]] -> [[Maybe a]]
filterBlank
          in [[Maybe FmtVal]] -> [[FmtVal]]
filterOrDefaultBlankRows ([[Maybe FmtVal]] -> [[FmtVal]]) -> [[Maybe FmtVal]] -> [[FmtVal]]
forall a b. (a -> b) -> a -> b
$ [Maybe FmtVal] -> [[Maybe FmtVal]]
forall e. e -> [e]
single ([Maybe FmtVal] -> [[Maybe FmtVal]])
-> [Maybe FmtVal] -> [[Maybe FmtVal]]
forall a b. (a -> b) -> a -> b
$ TblHdrs -> KeySpec -> [Maybe FmtVal]
multivalRows TblHdrs
colKeyMap KeySpec
path
    htmlRows ((Key
key,[TblHdr]
keyvals) : TblHdrs
kseq, TblHdrs
colKeyMap) KeySpec
path =
      let subrows :: TblHdr -> [[FmtVal]]
subrows = \case
            V KeyVal
keyval -> (TblHdrs, TblHdrs) -> KeySpec -> [[FmtVal]]
htmlRows (TblHdrs
kseq, TblHdrs
colKeyMap) (KeySpec -> [[FmtVal]]) -> KeySpec -> [[FmtVal]]
forall a b. (a -> b) -> a -> b
$ KeySpec -> (Key, KeyVal) -> KeySpec
forall a. [a] -> a -> [a]
snoc KeySpec
path (Key
key,KeyVal
keyval)
            TblHdr
_ -> [ [Span -> LastInGroup -> LastInGroup -> Text -> FmtVal
Val (Natural -> Span
Cols Natural
nCols) LastInGroup
True LastInGroup
True Text
"more"] ]
          nCols :: Natural
nCols = [Natural] -> Natural
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
product ( [TblHdr] -> Natural
forall (t :: * -> *) a. Foldable t => t a -> Natural
nLength ([TblHdr] -> Natural)
-> ((Key, [TblHdr]) -> [TblHdr]) -> (Key, [TblHdr]) -> Natural
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key, [TblHdr]) -> [TblHdr]
forall a b. (a, b) -> b
snd ((Key, [TblHdr]) -> Natural) -> TblHdrs -> [Natural]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TblHdrs
colKeyMap )
          nHdrs :: Natural
nHdrs = TblHdrs -> Natural
forall (t :: * -> *) a. Foldable t => t a -> Natural
nLength TblHdrs
kseq Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+ Natural
1
          endOfGroup :: LastInGroup
endOfGroup = Key
key Key -> [Key] -> LastInGroup
forall a. Eq a => a -> [a] -> LastInGroup
forall (t :: * -> *) a.
(Foldable t, Eq a) =>
a -> t a -> LastInGroup
`elem` RenderConfig -> [Key]
rowGroup RenderConfig
cfg
          genSubrows :: TblHdr -> [[FmtVal]]
genSubrows TblHdr
keyval =
            let sr :: [[FmtVal]]
sr = TblHdr -> [[FmtVal]]
subrows TblHdr
keyval
                kv :: Either Natural (Named HTMLStyle "column header")
kv = TblHdr -> Either Natural (Named HTMLStyle "column header")
toHdrText' TblHdr
keyval
            in ([[FmtVal]],
 Maybe (Either Natural (Named HTMLStyle "column header")))
-> [[FmtVal]]
forall a b. (a, b) -> a
fst
               (([[FmtVal]],
  Maybe (Either Natural (Named HTMLStyle "column header")))
 -> [[FmtVal]])
-> ([[FmtVal]],
    Maybe (Either Natural (Named HTMLStyle "column header")))
-> [[FmtVal]]
forall a b. (a -> b) -> a -> b
$ (([[FmtVal]],
  Maybe (Either Natural (Named HTMLStyle "column header")))
 -> (LastInGroup, [FmtVal])
 -> ([[FmtVal]],
     Maybe (Either Natural (Named HTMLStyle "column header"))))
-> ([[FmtVal]],
    Maybe (Either Natural (Named HTMLStyle "column header")))
-> [(LastInGroup, [FmtVal])]
-> ([[FmtVal]],
    Maybe (Either Natural (Named HTMLStyle "column header")))
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (Natural
-> ([[FmtVal]],
    Maybe (Either Natural (Named HTMLStyle "column header")))
-> (LastInGroup, [FmtVal])
-> ([[FmtVal]],
    Maybe (Either Natural (Named HTMLStyle "column header")))
forall {a}.
Sayable "html" a =>
Natural
-> ([[FmtVal]], Maybe (Either a (Named HTMLStyle "column header")))
-> (LastInGroup, [FmtVal])
-> ([[FmtVal]], Maybe (Either a (Named HTMLStyle "column header")))
leftAdd ([[FmtVal]] -> Natural
forall (t :: * -> *) a. Foldable t => t a -> Natural
nLength [[FmtVal]]
sr)) ([[FmtVal]]
forall a. Monoid a => a
mempty, Either Natural (Named HTMLStyle "column header")
-> Maybe (Either Natural (Named HTMLStyle "column header"))
forall a. a -> Maybe a
Just Either Natural (Named HTMLStyle "column header")
kv)
               ([(LastInGroup, [FmtVal])]
 -> ([[FmtVal]],
     Maybe (Either Natural (Named HTMLStyle "column header"))))
-> [(LastInGroup, [FmtVal])]
-> ([[FmtVal]],
    Maybe (Either Natural (Named HTMLStyle "column header")))
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
endOfGroup LastInGroup -> [LastInGroup] -> [LastInGroup]
forall a. a -> [a] -> [a]
: LastInGroup -> [LastInGroup]
forall e. e -> [e]
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 :: Natural
-> ([[FmtVal]], Maybe (Either a (Named HTMLStyle "column header")))
-> (LastInGroup, [FmtVal])
-> ([[FmtVal]], Maybe (Either a (Named HTMLStyle "column header")))
leftAdd Natural
nrows ([[FmtVal]]
acc,Maybe (Either a (Named HTMLStyle "column header"))
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 Span
h LastInGroup
g' LastInGroup
i Text
v) = Span -> LastInGroup -> LastInGroup -> Text -> FmtVal
Val Span
h (LastInGroup
g LastInGroup -> LastInGroup -> LastInGroup
|| LastInGroup
g') LastInGroup
i Text
v
                setValGrouping LastInGroup
g (Hdr Span
h LastInGroup
g' Named HTMLStyle "column header"
v) = Span -> LastInGroup -> Named HTMLStyle "column header" -> FmtVal
Hdr Span
h (LastInGroup
g LastInGroup -> LastInGroup -> LastInGroup
|| LastInGroup
g') Named HTMLStyle "column header"
v
            in ( [[FmtVal]] -> [FmtVal] -> [[FmtVal]]
forall a. [a] -> a -> [a]
snoc [[FmtVal]]
acc
                 (case Maybe (Either a (Named HTMLStyle "column header"))
mb'kv of
                     Maybe (Either a (Named HTMLStyle "column header"))
Nothing -> [FmtVal]
sr
                     Just (Right Named HTMLStyle "column header"
kv) ->
                       let w :: Natural
w = if RenderConfig -> LastInGroup
rowRepeat RenderConfig
cfg then Natural
1 else Natural
nrows
                       in Span -> LastInGroup -> Named HTMLStyle "column header" -> FmtVal
Hdr (Natural -> Span
Rows Natural
w) LastInGroup
endOfGroup Named HTMLStyle "column header"
kv FmtVal -> [FmtVal] -> [FmtVal]
forall a. a -> [a] -> [a]
: [FmtVal]
sr
                     Just (Left a
n) ->
                       let m :: Named HTMLStyle "column header"
m = String -> Named HTMLStyle "column header"
forall a. IsString a => String -> a
fromString (String -> Named HTMLStyle "column header")
-> String -> Named HTMLStyle "column header"
forall a b. (a -> b) -> a -> b
$ forall (saytag :: Symbol) a. Sayable saytag a => a -> String
sez @"html" (Saying "html" -> String) -> Saying "html" -> String
forall a b. (a -> b) -> a -> b
$ Text -> Text
t'Text
"{+" Text -> a -> Saying "html"
forall (saytag :: Symbol) m n.
(Sayable saytag m, Sayable saytag n) =>
m -> n -> Saying saytag
&+ a
n Saying "html" -> Char -> Saying "html"
forall (saytag :: Symbol) m n.
(Sayable saytag m, Sayable saytag n) =>
m -> n -> Saying saytag
&+ Char
'}'
                       in Span -> LastInGroup -> Named HTMLStyle "column header" -> FmtVal
Hdr (Natural -> Span
Cols Natural
nHdrs) LastInGroup
True Named HTMLStyle "column header"
m FmtVal -> [FmtVal] -> [FmtVal]
forall a. a -> [a] -> [a]
: [FmtVal]
sr
                 )
               , if RenderConfig -> LastInGroup
rowRepeat RenderConfig
cfg then Maybe (Either a (Named HTMLStyle "column header"))
mb'kv else Maybe (Either a (Named HTMLStyle "column header"))
forall a. Maybe a
Nothing)
      in [[[FmtVal]]] -> [[FmtVal]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[[FmtVal]]] -> [[FmtVal]]) -> [[[FmtVal]]] -> [[FmtVal]]
forall a b. (a -> b) -> a -> b
$ (TblHdr -> [[FmtVal]]) -> [TblHdr] -> [[[FmtVal]]]
forall a b. (a -> b) -> [a] -> [b]
each TblHdr -> [[FmtVal]]
genSubrows [TblHdr]
keyvals

    multivalRows :: TblHdrs -> KeySpec -> [Maybe FmtVal]
multivalRows [] KeySpec
_ = String -> [Maybe FmtVal]
forall a. HasCallStack => String -> a
error String
"HTML multivalRows cannot be called with no keys!"
    multivalRows ((Key
key, [TblHdr]
keyvals) : []) KeySpec
path =
      (\case
          V KeyVal
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 -> (Key, KeyVal) -> KeySpec
forall a. [a] -> a -> [a]
snoc KeySpec
path (Key
key,KeyVal
v)) KVITable v
t
          TblHdr
_ -> FmtVal -> Maybe FmtVal
forall a. a -> Maybe a
Just (FmtVal -> Maybe FmtVal) -> FmtVal -> Maybe FmtVal
forall a b. (a -> b) -> a -> b
$ Span -> LastInGroup -> LastInGroup -> Text -> FmtVal
Val Span
Singular LastInGroup
False LastInGroup
True Text
"... -->"
      ) (TblHdr -> Maybe FmtVal) -> [TblHdr] -> [Maybe FmtVal]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TblHdr]
keyvals
    multivalRows ((Key
key, [TblHdr]
keyvals) : TblHdrs
kseq) KeySpec
path =
      (TblHdr -> [Maybe FmtVal]) -> [TblHdr] -> [Maybe FmtVal]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\case
                   V KeyVal
v -> TblHdrs -> KeySpec -> [Maybe FmtVal]
multivalRows TblHdrs
kseq (KeySpec -> (Key, KeyVal) -> KeySpec
forall a. [a] -> a -> [a]
snoc KeySpec
path (Key
key,KeyVal
v))
                   TblHdr
_ -> [Maybe FmtVal]
forall a. Monoid a => a
mempty
                ) [TblHdr]
keyvals