{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

{- | Build HTML tables using @blaze-html@ and @colonnade@. The bottom
  of this page has a tutorial that walks through a full example,
  illustrating how to meet typical needs with this library. It is
  recommended that users read the documentation for @colonnade@ first,
  since this library builds on the abstractions introduced there.
  A concise example of this library\'s use:

>>> :set -XOverloadedStrings
>>> :module + Colonnade Text.Blaze.Html Text.Blaze.Colonnade
>>> let col = headed "Grade" (toHtml . fst) <> headed "Letter" (toHtml . snd)
>>> let rows = [("90-100",'A'),("80-89",'B'),("70-79",'C')]
>>> printVeryCompactHtml (encodeHtmlTable mempty col rows)
<table>
    <thead>
        <tr><th>Grade</th><th>Letter</th></tr>
    </thead>
    <tbody>
        <tr><td>90-100</td><td>A</td></tr>
        <tr><td>80-89</td><td>B</td></tr>
        <tr><td>70-79</td><td>C</td></tr>
    </tbody>
</table>
-}
module Text.Blaze.Colonnade
  ( -- * Apply
    encodeCappedCellTable
  , encodeHtmlTable
  , encodeCellTable
  , encodeTable
  , encodeCappedTable

    -- * Cell
    -- $build
  , Cell (..)
  , charCell
  , htmlCell
  , stringCell
  , textCell
  , lazyTextCell
  , builderCell
  , htmlFromCell

    -- * Interactive
  , printCompactHtml
  , printVeryCompactHtml

    -- * Tutorial
    -- $setup

    -- * Discussion
    -- $discussion
  ) where

import Colonnade (Colonnade, Cornice, Fascia, Headed)
import qualified Colonnade.Encode as E
import Control.Monad
import Data.Char (isSpace)
import Data.Foldable
import qualified Data.List as List
import Data.Maybe (listToMaybe)
import Data.String (IsString (..))
import Data.Text (Text)
import qualified Data.Text.Lazy as LText
import qualified Data.Text.Lazy.Builder as TBuilder
import Text.Blaze (Attribute, (!))
import Text.Blaze.Html (Html, toHtml)
import qualified Text.Blaze.Html.Renderer.Pretty as Pretty
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as HA

{- $setup
We start with a few necessary imports and some example data
types:

>>> :set -XOverloadedStrings
>>> import Data.Monoid (mconcat,(<>))
>>> import Data.Char (toLower)
>>> import Data.Profunctor (Profunctor(lmap))
>>> import Colonnade (Colonnade,Headed,Headless,headed,cap,Fascia(..))
>>> import Text.Blaze.Html (Html, toHtml, toValue)
>>> import qualified Text.Blaze.Html5 as H
>>> data Department = Management | Sales | Engineering deriving (Show,Eq)
>>> data Employee = Employee { name :: String, department :: Department, age :: Int }

We define some employees that we will display in a table:

>>> :{
let employees =
      [ Employee "Thaddeus" Sales 34
      , Employee "Lucia" Engineering 33
      , Employee "Pranav" Management 57
      ]
:}

Let's build a table that displays the name and the age
of an employee. Additionally, we will emphasize the names of
engineers using a @\<strong\>@ tag.

>>> :{
let tableEmpA :: Colonnade Headed Employee Html
    tableEmpA = mconcat
      [ headed "Name" $ \emp -> case department emp of
          Engineering -> H.strong (toHtml (name emp))
          _ -> toHtml (name emp)
      , headed "Age" (toHtml . show . age)
      ]
:}

The type signature of @tableEmpA@ is inferrable but is written
out for clarity in this example. Additionally, note that the first
argument to 'headed' is of type 'Html', so @OverloadedStrings@ is
necessary for the above example to compile. To avoid using this extension,
it is possible to instead use 'toHtml' to convert a 'String' to 'Html'.
Let\'s continue:

>>> let customAttrs = HA.class_ "stylish-table" <> HA.id "main-table"
>>> printCompactHtml (encodeHtmlTable customAttrs tableEmpA employees)
<table class="stylish-table" id="main-table">
    <thead>
        <tr>
            <th>Name</th>
            <th>Age</th>
        </tr>
    </thead>
    <tbody>
        <tr>
            <td>Thaddeus</td>
            <td>34</td>
        </tr>
        <tr>
            <td><strong>Lucia</strong></td>
            <td>33</td>
        </tr>
        <tr>
            <td>Pranav</td>
            <td>57</td>
        </tr>
    </tbody>
</table>

Excellent. As expected, Lucia\'s name is wrapped in a @\<strong\>@ tag
since she is an engineer.

One limitation of using 'Html' as the content
type of a 'Colonnade' is that we are unable to add attributes to
the @\<td\>@ and @\<th\>@ elements. This library provides the 'Cell' type
to work around this problem. A 'Cell' is just 'Html' content and a set
of attributes to be applied to its parent @<th>@ or @<td>@. To illustrate
how its use, another employee table will be built. This table will
contain a single column indicating the department of each employ. Each
cell will be assigned a class name based on the department. To start off,
let\'s build a table that encodes departments:

>>> :{
let tableDept :: Colonnade Headed Department Cell
    tableDept = mconcat
      [ headed "Dept." $ \d -> Cell
          (HA.class_ (toValue (map toLower (show d))))
          (toHtml (show d))
      ]
:}

Again, @OverloadedStrings@ plays a role, this time allowing the
literal @"Dept."@ to be accepted as a value of type 'Cell'. To avoid
this extension, 'stringCell' could be used to upcast the 'String'.
To try out our 'Colonnade' on a list of departments, we need to use
'encodeCellTable' instead of 'encodeHtmlTable':

>>> let twoDepts = [Sales,Management]
>>> printVeryCompactHtml (encodeCellTable customAttrs tableDept twoDepts)
<table class="stylish-table" id="main-table">
    <thead>
        <tr><th>Dept.</th></tr>
    </thead>
    <tbody>
        <tr><td class="sales">Sales</td></tr>
        <tr><td class="management">Management</td></tr>
    </tbody>
</table>

The attributes on the @\<td\>@ elements show up as they are expected to.
Now, we take advantage of the @Profunctor@ instance of 'Colonnade' to allow
this to work on @Employee@\'s instead:

>>> :t lmap
lmap :: Profunctor p => (a -> b) -> p b c -> p a c
>>> let tableEmpB = lmap department tableDept
>>> :t tableEmpB
tableEmpB :: Colonnade Headed Employee Cell
>>> printVeryCompactHtml (encodeCellTable customAttrs tableEmpB employees)
<table class="stylish-table" id="main-table">
    <thead>
        <tr><th>Dept.</th></tr>
    </thead>
    <tbody>
        <tr><td class="sales">Sales</td></tr>
        <tr><td class="engineering">Engineering</td></tr>
        <tr><td class="management">Management</td></tr>
    </tbody>
</table>

This table shows the department of each of our three employees, additionally
making a lowercased version of the department into a class name for the @\<td\>@.
This table is nice for illustrative purposes, but it does not provide all the
information that we have about the employees. If we combine it with the
earlier table we wrote, we can present everything in the table. One small
roadblock is that the types of @tableEmpA@ and @tableEmpB@ do not match, which
prevents a straightforward monoidal append:

>>> :t tableEmpA
tableEmpA :: Colonnade Headed Employee Html
>>> :t tableEmpB
tableEmpB :: Colonnade Headed Employee Cell

We can upcast the content type with 'fmap'.
Monoidal append is then well-typed, and the resulting 'Colonnade'
can be applied to the employees:

>>> let tableEmpC = fmap htmlCell tableEmpA <> tableEmpB
>>> :t tableEmpC
tableEmpC :: Colonnade Headed Employee Cell
>>> printCompactHtml (encodeCellTable customAttrs tableEmpC employees)
<table class="stylish-table" id="main-table">
    <thead>
        <tr>
            <th>Name</th>
            <th>Age</th>
            <th>Dept.</th>
        </tr>
    </thead>
    <tbody>
        <tr>
            <td>Thaddeus</td>
            <td>34</td>
            <td class="sales">Sales</td>
        </tr>
        <tr>
            <td><strong>Lucia</strong></td>
            <td>33</td>
            <td class="engineering">Engineering</td>
        </tr>
        <tr>
            <td>Pranav</td>
            <td>57</td>
            <td class="management">Management</td>
        </tr>
    </tbody>
</table>
-}

{- $build

The 'Cell' type is used to build a 'Colonnade' that
has 'Html' content inside table cells and may optionally
have attributes added to the @\<td\>@ or @\<th\>@ elements
that wrap this HTML content.
-}

{- | The attributes that will be applied to a @\<td\>@ and
  the HTML content that will go inside it. When using
  this type, remember that 'Attribute', defined in @blaze-markup@,
  is actually a collection of attributes, not a single attribute.
-}
data Cell = Cell
  { Cell -> Attribute
cellAttribute :: !Attribute
  , Cell -> Html
cellHtml :: !Html
  }

instance IsString Cell where
  fromString :: String -> Cell
fromString = String -> Cell
stringCell

instance Semigroup Cell where
  (Cell Attribute
a1 Html
c1) <> :: Cell -> Cell -> Cell
<> (Cell Attribute
a2 Html
c2) = Attribute -> Html -> Cell
Cell (Attribute
a1 Attribute -> Attribute -> Attribute
forall a. Semigroup a => a -> a -> a
<> Attribute
a2) (Html
c1 Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> Html
c2)

instance Monoid Cell where
  mempty :: Cell
mempty = Attribute -> Html -> Cell
Cell Attribute
forall a. Monoid a => a
mempty Html
forall a. Monoid a => a
mempty
  mappend :: Cell -> Cell -> Cell
mappend = Cell -> Cell -> Cell
forall a. Semigroup a => a -> a -> a
(<>)

-- | Create a 'Cell' from a 'Widget'
htmlCell :: Html -> Cell
htmlCell :: Html -> Cell
htmlCell = Attribute -> Html -> Cell
Cell Attribute
forall a. Monoid a => a
mempty

-- | Create a 'Cell' from a 'String'
stringCell :: String -> Cell
stringCell :: String -> Cell
stringCell = Html -> Cell
htmlCell (Html -> Cell) -> (String -> Html) -> String -> Cell
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Html
forall a. IsString a => String -> a
fromString

-- | Create a 'Cell' from a 'Char'
charCell :: Char -> Cell
charCell :: Char -> Cell
charCell = String -> Cell
stringCell (String -> Cell) -> (Char -> String) -> Char -> Cell
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- | Create a 'Cell' from a 'Text'
textCell :: Text -> Cell
textCell :: Text -> Cell
textCell = Html -> Cell
htmlCell (Html -> Cell) -> (Text -> Html) -> Text -> Cell
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Html
forall a. ToMarkup a => a -> Html
toHtml

-- | Create a 'Cell' from a lazy text
lazyTextCell :: LText.Text -> Cell
lazyTextCell :: Text -> Cell
lazyTextCell = Text -> Cell
textCell (Text -> Cell) -> (Text -> Text) -> Text -> Cell
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
LText.toStrict

-- | Create a 'Cell' from a text builder
builderCell :: TBuilder.Builder -> Cell
builderCell :: Builder -> Cell
builderCell = Text -> Cell
lazyTextCell (Text -> Cell) -> (Builder -> Text) -> Builder -> Cell
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Text
TBuilder.toLazyText

{- | Encode a table. This handles a very general case and
  is seldom needed by users. One of the arguments provided is
  used to add attributes to the generated @\<tr\>@ elements.
-}
encodeTable ::
  forall h f a c.
  (Foldable f, E.Headedness h) =>
  -- | Attributes of @\<thead\>@ and its @\<tr\>@, pass 'Nothing' to omit @\<thead\>@
  h (Attribute, Attribute) ->
  -- | Attributes of @\<tbody\>@ element
  Attribute ->
  -- | Attributes of each @\<tr\>@ element
  (a -> Attribute) ->
  -- | Wrap content and convert to 'Html'
  ((Html -> Html) -> c -> Html) ->
  -- | Attributes of @\<table\>@ element
  Attribute ->
  -- | How to encode data as a row
  Colonnade h a c ->
  -- | Collection of data
  f a ->
  Html
encodeTable :: forall (h :: * -> *) (f :: * -> *) a c.
(Foldable f, Headedness h) =>
h (Attribute, Attribute)
-> Attribute
-> (a -> Attribute)
-> ((Html -> Html) -> c -> Html)
-> Attribute
-> Colonnade h a c
-> f a
-> Html
encodeTable h (Attribute, Attribute)
mtheadAttrs Attribute
tbodyAttrs a -> Attribute
trAttrs (Html -> Html) -> c -> Html
wrapContent Attribute
tableAttrs Colonnade h a c
colonnade f a
xs =
  Html -> Html
H.table (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! Attribute
tableAttrs (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
    case Maybe (ExtractForall h)
forall (h :: * -> *). Headedness h => Maybe (ExtractForall h)
E.headednessExtractForall of
      Maybe (ExtractForall h)
Nothing -> () -> Html
forall a. a -> MarkupM a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
forall a. Monoid a => a
mempty
      Just ExtractForall h
extractForall -> do
        let (Attribute
theadAttrs, Attribute
theadTrAttrs) = h (Attribute, Attribute) -> (Attribute, Attribute)
forall y. h y -> y
extract h (Attribute, Attribute)
mtheadAttrs
        Html -> Html
H.thead (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! Attribute
theadAttrs (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html -> Html
H.tr (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! Attribute
theadTrAttrs (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
          -- E.headerMonoidalGeneral colonnade (wrapContent H.th)
          (OneColonnade h a c -> Html) -> Vector (OneColonnade h a c) -> Html
forall (g :: * -> *) b a (m :: * -> *).
(Foldable g, Monoid b, Monad m) =>
(a -> m b) -> g a -> m b
foldlMapM' ((Html -> Html) -> c -> Html
wrapContent Html -> Html
H.th (c -> Html)
-> (OneColonnade h a c -> c) -> OneColonnade h a c -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. h c -> c
forall y. h y -> y
extract (h c -> c)
-> (OneColonnade h a c -> h c) -> OneColonnade h a c -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OneColonnade h a c -> h c
forall (h :: * -> *) a c. OneColonnade h a c -> h c
E.oneColonnadeHead) (Colonnade h a c -> Vector (OneColonnade h a c)
forall (h :: * -> *) a c.
Colonnade h a c -> Vector (OneColonnade h a c)
E.getColonnade Colonnade h a c
colonnade)
       where
        extract :: forall y. h y -> y
        extract :: forall y. h y -> y
extract = ExtractForall h -> forall y. h y -> y
forall (h :: * -> *). ExtractForall h -> forall a. h a -> a
E.runExtractForall ExtractForall h
extractForall
    (a -> Attribute)
-> ((Html -> Html) -> c -> Html)
-> Attribute
-> Colonnade h a c
-> f a
-> Html
forall (f :: * -> *) a c (h :: * -> *).
Foldable f =>
(a -> Attribute)
-> ((Html -> Html) -> c -> Html)
-> Attribute
-> Colonnade h a c
-> f a
-> Html
encodeBody a -> Attribute
trAttrs (Html -> Html) -> c -> Html
wrapContent Attribute
tbodyAttrs Colonnade h a c
colonnade f a
xs

foldlMapM' :: forall g b a m. (Foldable g, Monoid b, Monad m) => (a -> m b) -> g a -> m b
foldlMapM' :: forall (g :: * -> *) b a (m :: * -> *).
(Foldable g, Monoid b, Monad m) =>
(a -> m b) -> g a -> m b
foldlMapM' a -> m b
f g a
xs = (a -> (b -> m b) -> b -> m b) -> (b -> m b) -> g a -> b -> m b
forall a b. (a -> b -> b) -> b -> g a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr a -> (b -> m b) -> b -> m b
f' b -> m b
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure g a
xs b
forall a. Monoid a => a
mempty
 where
  f' :: a -> (b -> m b) -> b -> m b
  f' :: a -> (b -> m b) -> b -> m b
f' a
x b -> m b
k b
bl = do
    b
br <- a -> m b
f a
x
    let !b :: b
b = b -> b -> b
forall a. Monoid a => a -> a -> a
mappend b
bl b
br
    b -> m b
k b
b

{- | Encode a table with tiered header rows.
>>> let cor = mconcat [cap "Personal" (fmap htmlCell tableEmpA), cap "Work" tableEmpB]
>>> let fascia = FasciaCap (HA.class_ "category") (FasciaBase (HA.class_ "subcategory"))
>>> printCompactHtml (encodeCappedCellTable mempty fascia cor [head employees])
<table>
    <thead>
        <tr class="category">
            <th colspan="2">Personal</th>
            <th colspan="1">Work</th>
        </tr>
        <tr class="subcategory">
            <th colspan="1">Name</th>
            <th colspan="1">Age</th>
            <th colspan="1">Dept.</th>
        </tr>
    </thead>
    <tbody>
        <tr>
            <td>Thaddeus</td>
            <td>34</td>
            <td class="sales">Sales</td>
        </tr>
    </tbody>
</table>
-}
encodeCappedCellTable ::
  (Foldable f) =>
  -- | Attributes of @\<table\>@ element
  Attribute ->
  -- | Attributes for @\<tr\>@ elements in the @\<thead\>@
  Fascia p Attribute ->
  Cornice Headed p a Cell ->
  -- | Collection of data
  f a ->
  Html
encodeCappedCellTable :: forall (f :: * -> *) (p :: Pillar) a.
Foldable f =>
Attribute
-> Fascia p Attribute -> Cornice Headed p a Cell -> f a -> Html
encodeCappedCellTable = Attribute
-> Attribute
-> (a -> Attribute)
-> ((Html -> Html) -> Cell -> Html)
-> Attribute
-> Fascia p Attribute
-> Cornice Headed p a Cell
-> f a
-> Html
forall (f :: * -> *) a c (p :: Pillar).
Foldable f =>
Attribute
-> Attribute
-> (a -> Attribute)
-> ((Html -> Html) -> c -> Html)
-> Attribute
-> Fascia p Attribute
-> Cornice Headed p a c
-> f a
-> Html
encodeCappedTable Attribute
forall a. Monoid a => a
mempty Attribute
forall a. Monoid a => a
mempty (Attribute -> a -> Attribute
forall a b. a -> b -> a
const Attribute
forall a. Monoid a => a
mempty) (Html -> Html) -> Cell -> Html
htmlFromCell

{- | Encode a table with tiered header rows. This is the most general function
  in this library for encoding a 'Cornice'.
-}
encodeCappedTable ::
  (Foldable f) =>
  -- | Attributes of @\<thead\>@
  Attribute ->
  -- | Attributes of @\<tbody\>@ element
  Attribute ->
  -- | Attributes of each @\<tr\>@ element in the @\<tbody\>@
  (a -> Attribute) ->
  -- | Wrap content and convert to 'Html'
  ((Html -> Html) -> c -> Html) ->
  -- | Attributes of @\<table\>@ element
  Attribute ->
  -- | Attributes for @\<tr\>@ elements in the @\<thead\>@
  Fascia p Attribute ->
  Cornice Headed p a c ->
  -- | Collection of data
  f a ->
  Html
encodeCappedTable :: forall (f :: * -> *) a c (p :: Pillar).
Foldable f =>
Attribute
-> Attribute
-> (a -> Attribute)
-> ((Html -> Html) -> c -> Html)
-> Attribute
-> Fascia p Attribute
-> Cornice Headed p a c
-> f a
-> Html
encodeCappedTable Attribute
theadAttrs Attribute
tbodyAttrs a -> Attribute
trAttrs (Html -> Html) -> c -> Html
wrapContent Attribute
tableAttrs Fascia p Attribute
fascia Cornice Headed p a c
cornice f a
xs = do
  let colonnade :: Colonnade Headed a c
colonnade = Cornice Headed p a c -> Colonnade Headed a c
forall (h :: * -> *) (p :: Pillar) a c.
Cornice h p a c -> Colonnade h a c
E.discard Cornice Headed p a c
cornice
      annCornice :: AnnotatedCornice (Maybe Int) Headed p a c
annCornice = Cornice Headed p a c -> AnnotatedCornice (Maybe Int) Headed p a c
forall (p :: Pillar) a c.
Cornice Headed p a c -> AnnotatedCornice (Maybe Int) Headed p a c
E.annotate Cornice Headed p a c
cornice
  Html -> Html
H.table (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! Attribute
tableAttrs (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
    Html -> Html
H.thead (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! Attribute
theadAttrs (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
      Maybe (Fascia p Attribute, Attribute -> Html -> Html)
-> [(Maybe Int -> c -> Html, Html -> Html)]
-> AnnotatedCornice (Maybe Int) Headed p a c
-> Html
forall sz r m c (p :: Pillar) a (h :: * -> *).
(Monoid m, Headedness h) =>
Maybe (Fascia p r, r -> m -> m)
-> [(sz -> c -> m, m -> m)] -> AnnotatedCornice sz h p a c -> m
E.headersMonoidal
        ((Fascia p Attribute, Attribute -> Html -> Html)
-> Maybe (Fascia p Attribute, Attribute -> Html -> Html)
forall a. a -> Maybe a
Just (Fascia p Attribute
fascia, \Attribute
attrs Html
theHtml -> Html -> Html
H.tr (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! Attribute
attrs (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html
theHtml))
        [
          ( \Maybe Int
msz c
c -> case Maybe Int
msz of
              Just Int
sz -> (Html -> Html) -> c -> Html
wrapContent Html -> Html
H.th c
c Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
HA.colspan (String -> AttributeValue
forall a. ToValue a => a -> AttributeValue
H.toValue (Int -> String
forall a. Show a => a -> String
show Int
sz))
              Maybe Int
Nothing -> Html
forall a. Monoid a => a
mempty
          , Html -> Html
forall a. a -> a
id
          )
        ]
        AnnotatedCornice (Maybe Int) Headed p a c
annCornice
    -- H.tr ! trAttrs $ do
    -- E.headerMonoidalGeneral colonnade (wrapContent H.th)
    (a -> Attribute)
-> ((Html -> Html) -> c -> Html)
-> Attribute
-> Colonnade Headed a c
-> f a
-> Html
forall (f :: * -> *) a c (h :: * -> *).
Foldable f =>
(a -> Attribute)
-> ((Html -> Html) -> c -> Html)
-> Attribute
-> Colonnade h a c
-> f a
-> Html
encodeBody a -> Attribute
trAttrs (Html -> Html) -> c -> Html
wrapContent Attribute
tbodyAttrs Colonnade Headed a c
colonnade f a
xs

encodeBody ::
  (Foldable f) =>
  -- | Attributes of each @\<tr\>@ element
  (a -> Attribute) ->
  -- | Wrap content and convert to 'Html'
  ((Html -> Html) -> c -> Html) ->
  -- | Attributes of @\<tbody\>@ element
  Attribute ->
  -- | How to encode data as a row
  Colonnade h a c ->
  -- | Collection of data
  f a ->
  Html
encodeBody :: forall (f :: * -> *) a c (h :: * -> *).
Foldable f =>
(a -> Attribute)
-> ((Html -> Html) -> c -> Html)
-> Attribute
-> Colonnade h a c
-> f a
-> Html
encodeBody a -> Attribute
trAttrs (Html -> Html) -> c -> Html
wrapContent Attribute
tbodyAttrs Colonnade h a c
colonnade f a
xs = do
  Html -> Html
H.tbody (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! Attribute
tbodyAttrs (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
    f a -> (a -> Html) -> Html
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ f a
xs ((a -> Html) -> Html) -> (a -> Html) -> Html
forall a b. (a -> b) -> a -> b
$ \a
x -> do
      Html -> Html
H.tr (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! a -> Attribute
trAttrs a
x (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Colonnade h a c -> (c -> Html) -> a -> Html
forall m (h :: * -> *) a c.
Monoid m =>
Colonnade h a c -> (c -> m) -> a -> m
E.rowMonoidal Colonnade h a c
colonnade ((Html -> Html) -> c -> Html
wrapContent Html -> Html
H.td) a
x

{- | Encode a table. Table cells may have attributes
  applied to them.
-}
encodeCellTable ::
  (Foldable f) =>
  -- | Attributes of @\<table\>@ element
  Attribute ->
  -- | How to encode data as columns
  Colonnade Headed a Cell ->
  -- | Collection of data
  f a ->
  Html
encodeCellTable :: forall (f :: * -> *) a.
Foldable f =>
Attribute -> Colonnade Headed a Cell -> f a -> Html
encodeCellTable =
  Headed (Attribute, Attribute)
-> Attribute
-> (a -> Attribute)
-> ((Html -> Html) -> Cell -> Html)
-> Attribute
-> Colonnade Headed a Cell
-> f a
-> Html
forall (h :: * -> *) (f :: * -> *) a c.
(Foldable f, Headedness h) =>
h (Attribute, Attribute)
-> Attribute
-> (a -> Attribute)
-> ((Html -> Html) -> c -> Html)
-> Attribute
-> Colonnade h a c
-> f a
-> Html
encodeTable
    ((Attribute, Attribute) -> Headed (Attribute, Attribute)
forall a. a -> Headed a
forall (h :: * -> *) a. Headedness h => a -> h a
E.headednessPure (Attribute
forall a. Monoid a => a
mempty, Attribute
forall a. Monoid a => a
mempty))
    Attribute
forall a. Monoid a => a
mempty
    (Attribute -> a -> Attribute
forall a b. a -> b -> a
const Attribute
forall a. Monoid a => a
mempty)
    (Html -> Html) -> Cell -> Html
htmlFromCell

{- | Encode a table. Table cell element do not have
  any attributes applied to them.
-}
encodeHtmlTable ::
  (Foldable f, E.Headedness h) =>
  -- | Attributes of @\<table\>@ element
  Attribute ->
  -- | How to encode data as columns
  Colonnade h a Html ->
  -- | Collection of data
  f a ->
  Html
encodeHtmlTable :: forall (f :: * -> *) (h :: * -> *) a.
(Foldable f, Headedness h) =>
Attribute -> Colonnade h a Html -> f a -> Html
encodeHtmlTable =
  h (Attribute, Attribute)
-> Attribute
-> (a -> Attribute)
-> ((Html -> Html) -> Html -> Html)
-> Attribute
-> Colonnade h a Html
-> f a
-> Html
forall (h :: * -> *) (f :: * -> *) a c.
(Foldable f, Headedness h) =>
h (Attribute, Attribute)
-> Attribute
-> (a -> Attribute)
-> ((Html -> Html) -> c -> Html)
-> Attribute
-> Colonnade h a c
-> f a
-> Html
encodeTable
    ((Attribute, Attribute) -> h (Attribute, Attribute)
forall a. a -> h a
forall (h :: * -> *) a. Headedness h => a -> h a
E.headednessPure (Attribute
forall a. Monoid a => a
mempty, Attribute
forall a. Monoid a => a
mempty))
    Attribute
forall a. Monoid a => a
mempty
    (Attribute -> a -> Attribute
forall a b. a -> b -> a
const Attribute
forall a. Monoid a => a
mempty)
    (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
($)

{- | Convert a 'Cell' to 'Html' by wrapping the content with a tag
and applying the 'Cell' attributes to that tag.
-}
htmlFromCell :: (Html -> Html) -> Cell -> Html
htmlFromCell :: (Html -> Html) -> Cell -> Html
htmlFromCell Html -> Html
f (Cell Attribute
attr Html
content) = Html -> Html
f (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! Attribute
attr (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html
content

data St = St
  { St -> [String]
_stContext :: [String]
  , St -> TagStatus
_stTagStatus :: TagStatus
  , St -> String -> String
stResult :: String -> String
  -- ^ difference list
  }

data TagStatus
  = TagStatusSomeTag
  | TagStatusOpening (String -> String)
  | TagStatusOpeningAttrs
  | TagStatusNormal
  | TagStatusClosing (String -> String)
  | TagStatusAfterTag

removeWhitespaceAfterTag :: String -> String -> String
removeWhitespaceAfterTag :: String -> String -> String
removeWhitespaceAfterTag String
chosenTag =
  (String -> String) -> (St -> String) -> Either String St -> String
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> String
forall a. a -> a
id (\St
st -> St -> String -> String
stResult St
st String
"") (Either String St -> String)
-> (String -> Either String St) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (St -> Char -> Either String St)
-> St -> String -> Either String St
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM ((Char -> St -> Either String St) -> St -> Char -> Either String St
forall a b c. (a -> b -> c) -> b -> a -> c
flip Char -> St -> Either String St
f) ([String] -> TagStatus -> (String -> String) -> St
St [] TagStatus
TagStatusNormal String -> String
forall a. a -> a
id)
 where
  f :: Char -> St -> Either String St
  f :: Char -> St -> Either String St
f Char
c (St [String]
ctx TagStatus
status String -> String
res) = case TagStatus
status of
    TagStatus
TagStatusNormal
      | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'<' -> St -> Either String St
forall a b. b -> Either a b
Right ([String] -> TagStatus -> (String -> String) -> St
St [String]
ctx TagStatus
TagStatusSomeTag String -> String
likelyRes)
      | Char -> Bool
isSpace Char
c ->
          if String -> Maybe String
forall a. a -> Maybe a
Just String
chosenTag Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
== [String] -> Maybe String
forall a. [a] -> Maybe a
listToMaybe [String]
ctx
            then St -> Either String St
forall a b. b -> Either a b
Right ([String] -> TagStatus -> (String -> String) -> St
St [String]
ctx TagStatus
TagStatusNormal String -> String
res) -- drops the whitespace
            else St -> Either String St
forall a b. b -> Either a b
Right ([String] -> TagStatus -> (String -> String) -> St
St [String]
ctx TagStatus
TagStatusNormal String -> String
likelyRes)
      | Bool
otherwise -> St -> Either String St
forall a b. b -> Either a b
Right ([String] -> TagStatus -> (String -> String) -> St
St [String]
ctx TagStatus
TagStatusNormal String -> String
likelyRes)
    TagStatus
TagStatusSomeTag
      | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/' -> St -> Either String St
forall a b. b -> Either a b
Right ([String] -> TagStatus -> (String -> String) -> St
St [String]
ctx ((String -> String) -> TagStatus
TagStatusClosing String -> String
forall a. a -> a
id) String -> String
likelyRes)
      | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'>' -> String -> Either String St
forall a b. a -> Either a b
Left String
"unexpected >"
      | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'<' -> String -> Either String St
forall a b. a -> Either a b
Left String
"unexpected <"
      | Bool
otherwise -> St -> Either String St
forall a b. b -> Either a b
Right ([String] -> TagStatus -> (String -> String) -> St
St [String]
ctx ((String -> String) -> TagStatus
TagStatusOpening (Char
c Char -> String -> String
forall a. a -> [a] -> [a]
:)) String -> String
likelyRes)
    TagStatusOpening String -> String
tag
      | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'>' -> St -> Either String St
forall a b. b -> Either a b
Right ([String] -> TagStatus -> (String -> String) -> St
St (String -> String
tag String
"" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
ctx) TagStatus
TagStatusAfterTag String -> String
likelyRes)
      | Char -> Bool
isSpace Char
c -> St -> Either String St
forall a b. b -> Either a b
Right ([String] -> TagStatus -> (String -> String) -> St
St (String -> String
tag String
"" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
ctx) TagStatus
TagStatusOpeningAttrs String -> String
likelyRes)
      | Bool
otherwise -> St -> Either String St
forall a b. b -> Either a b
Right ([String] -> TagStatus -> (String -> String) -> St
St [String]
ctx ((String -> String) -> TagStatus
TagStatusOpening (String -> String
tag (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
c Char -> String -> String
forall a. a -> [a] -> [a]
:))) String -> String
likelyRes)
    TagStatus
TagStatusOpeningAttrs
      | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'>' -> St -> Either String St
forall a b. b -> Either a b
Right ([String] -> TagStatus -> (String -> String) -> St
St [String]
ctx TagStatus
TagStatusAfterTag String -> String
likelyRes)
      | Bool
otherwise -> St -> Either String St
forall a b. b -> Either a b
Right ([String] -> TagStatus -> (String -> String) -> St
St [String]
ctx TagStatus
TagStatusOpeningAttrs String -> String
likelyRes)
    TagStatusClosing String -> String
tag
      | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'>' -> do
          [String]
otherTags <- case [String]
ctx of
            [] -> String -> Either String [String]
forall a b. a -> Either a b
Left String
"closing tag without any opening tag"
            String
closestTag : [String]
otherTags ->
              if String
closestTag String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String -> String
tag String
""
                then [String] -> Either String [String]
forall a b. b -> Either a b
Right [String]
otherTags
                else String -> Either String [String]
forall a b. a -> Either a b
Left (String -> Either String [String])
-> String -> Either String [String]
forall a b. (a -> b) -> a -> b
$ String
"closing tag <" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
tag String
"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"> did not match opening tag <" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
closestTag String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
">"
          St -> Either String St
forall a b. b -> Either a b
Right ([String] -> TagStatus -> (String -> String) -> St
St [String]
otherTags TagStatus
TagStatusAfterTag String -> String
likelyRes)
      | Bool
otherwise -> St -> Either String St
forall a b. b -> Either a b
Right ([String] -> TagStatus -> (String -> String) -> St
St [String]
ctx ((String -> String) -> TagStatus
TagStatusClosing (String -> String
tag (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
c Char -> String -> String
forall a. a -> [a] -> [a]
:))) String -> String
likelyRes)
    TagStatus
TagStatusAfterTag
      | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'<' -> St -> Either String St
forall a b. b -> Either a b
Right ([String] -> TagStatus -> (String -> String) -> St
St [String]
ctx TagStatus
TagStatusSomeTag String -> String
likelyRes)
      | Char -> Bool
isSpace Char
c ->
          if String -> Maybe String
forall a. a -> Maybe a
Just String
chosenTag Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
== [String] -> Maybe String
forall a. [a] -> Maybe a
listToMaybe [String]
ctx
            then St -> Either String St
forall a b. b -> Either a b
Right ([String] -> TagStatus -> (String -> String) -> St
St [String]
ctx TagStatus
TagStatusAfterTag String -> String
res) -- drops the whitespace
            else St -> Either String St
forall a b. b -> Either a b
Right ([String] -> TagStatus -> (String -> String) -> St
St [String]
ctx TagStatus
TagStatusNormal String -> String
likelyRes)
      | Bool
otherwise -> St -> Either String St
forall a b. b -> Either a b
Right ([String] -> TagStatus -> (String -> String) -> St
St [String]
ctx TagStatus
TagStatusNormal String -> String
likelyRes)
   where
    likelyRes :: String -> String
    likelyRes :: String -> String
likelyRes = String -> String
res (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
c Char -> String -> String
forall a. a -> [a] -> [a]
:)

{- | Pretty print an HTML table, stripping whitespace from inside @\<td\>@,
  @\<th\>@, and common inline tags. The implementation is inefficient and is
  incorrect in many corner cases. It is only provided to reduce the line
  count of the HTML printed by GHCi examples in this module\'s documentation.
  Use of this function is discouraged.
-}
printCompactHtml :: Html -> IO ()
printCompactHtml :: Html -> IO ()
printCompactHtml =
  String -> IO ()
putStrLn
    (String -> IO ()) -> (Html -> String) -> Html -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
List.dropWhileEnd (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n')
    (String -> String) -> (Html -> String) -> Html -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
removeWhitespaceAfterTag String
"td"
    (String -> String) -> (Html -> String) -> Html -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
removeWhitespaceAfterTag String
"th"
    (String -> String) -> (Html -> String) -> Html -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
removeWhitespaceAfterTag String
"strong"
    (String -> String) -> (Html -> String) -> Html -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
removeWhitespaceAfterTag String
"span"
    (String -> String) -> (Html -> String) -> Html -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
removeWhitespaceAfterTag String
"em"
    (String -> String) -> (Html -> String) -> Html -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html -> String
Pretty.renderHtml

{- | Similar to 'printCompactHtml'. Additionally strips all whitespace inside
  @\<tr\>@ elements and @\<thead\>@ elements.
-}
printVeryCompactHtml :: Html -> IO ()
printVeryCompactHtml :: Html -> IO ()
printVeryCompactHtml =
  String -> IO ()
putStrLn
    (String -> IO ()) -> (Html -> String) -> Html -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
List.dropWhileEnd (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n')
    (String -> String) -> (Html -> String) -> Html -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
removeWhitespaceAfterTag String
"td"
    (String -> String) -> (Html -> String) -> Html -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
removeWhitespaceAfterTag String
"th"
    (String -> String) -> (Html -> String) -> Html -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
removeWhitespaceAfterTag String
"strong"
    (String -> String) -> (Html -> String) -> Html -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
removeWhitespaceAfterTag String
"span"
    (String -> String) -> (Html -> String) -> Html -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
removeWhitespaceAfterTag String
"em"
    (String -> String) -> (Html -> String) -> Html -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
removeWhitespaceAfterTag String
"tr"
    (String -> String) -> (Html -> String) -> Html -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html -> String
Pretty.renderHtml

{- $discussion

In this module, some of the functions for applying a 'Colonnade' to
some values to build a table have roughly this type signature:

> Foldable a => Colonnade Headedness Cell a -> f a -> Html

The 'Colonnade' content type is 'Cell', but the content
type of the result is 'Html'. It may not be immidiately clear why
this is useful done. Another strategy, which this library also
uses, is to write
these functions to take a 'Colonnade' whose content is 'Html':

> Foldable a => Colonnade Headedness Html a -> f a -> Html

When the 'Colonnade' content type is 'Html', then the header
content is rendered as the child of a @\<th\>@ and the row
content the child of a @\<td\>@. However, it is not possible
to add attributes to these parent elements. To accomodate this
situation, it is necessary to introduce 'Cell', which includes
the possibility of attributes on the parent node.
-}