{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

{- | Build HTML tables using @lucid@ and @colonnade@. It is
  recommended that users read the documentation for @colonnade@ first,
  since this library builds on the abstractions introduced there.
  Also, look at the docs for @blaze-colonnade@. These two
  libraries are similar, but blaze offers an HTML pretty printer
  which makes it possible to doctest examples. Since lucid
  does not offer such facilities, examples are omitted here.
-}
module Lucid.Colonnade
  ( -- * Apply
    encodeHtmlTable
  , encodeCellTable
  , encodeCellTableSized
  , encodeTable

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

    -- * Discussion
    -- $discussion
  ) where

#if MIN_VERSION_base(4,18,0)
#else
import Control.Applicative (liftA2)
#endif
import Colonnade (Colonnade)
import Control.Monad
import Data.Foldable
import Data.String (IsString (..))
import Data.Text (Text)
import Lucid hiding (for_)

import qualified Colonnade.Encode as E
import qualified Data.Text as T
import qualified Data.Text as Text
import qualified Data.Text.Lazy as LText
import qualified Data.Text.Lazy.Builder as TBuilder
import qualified Data.Vector as V

{- $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 d = Cell
  { cellAttribute :: ![Attribute]
  , cellHtml :: !(Html d)
  }

instance (d ~ ()) => IsString (Cell d) where
  fromString = stringCell

instance (Semigroup d) => Semigroup (Cell d) where
  Cell a1 c1 <> Cell a2 c2 = Cell (mappend a1 a2) (liftA2 (<>) c1 c2)

instance (Monoid d) => Monoid (Cell d) where
  mempty = Cell mempty (return mempty)
  mappend = (<>)

-- | Create a 'Cell' from a 'Widget'
htmlCell :: Html d -> Cell d
htmlCell = Cell mempty

-- | Create a 'Cell' from a 'String'
stringCell :: String -> Cell ()
stringCell = htmlCell . fromString

-- | Create a 'Cell' from a 'Char'
charCell :: Char -> Cell ()
charCell = stringCell . pure

-- | Create a 'Cell' from a 'Text'
textCell :: Text -> Cell ()
textCell = htmlCell . toHtml

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

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

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

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

encodeCellTableSized ::
  (E.Headedness h, Foldable f, Monoid d) =>
  -- | Attributes of @\<table\>@ element
  [Attribute] ->
  -- | How to encode data as columns
  Colonnade (E.Sized Int h) a (Cell d) ->
  -- | Collection of data
  f a ->
  Html ()
encodeCellTableSized =
  encodeTableSized
    (E.headednessPure ([], []))
    mempty
    (const mempty)
    htmlFromCell

{- | 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.
  The elements of type @d@ produced by generating html are
  strictly combined with their monoidal append function.
  However, this type is nearly always @()@.
-}
encodeTable ::
  forall f h a d c.
  (Foldable f, E.Headedness h, Monoid d) =>
  -- | Attributes of @\<thead\>@ and its @\<tr\>@
  h ([Attribute], [Attribute]) ->
  -- | Attributes of @\<tbody\>@ element
  [Attribute] ->
  -- | Attributes of each @\<tr\>@ element
  (a -> [Attribute]) ->
  -- | Wrap content and convert to 'Html'
  (([Attribute] -> Html d -> Html d) -> c -> Html d) ->
  -- | Attributes of @\<table\>@ element
  [Attribute] ->
  -- | How to encode data as a row
  Colonnade h a c ->
  -- | Collection of data
  f a ->
  Html d
encodeTable mtheadAttrs tbodyAttrs trAttrs wrapContent tableAttrs colonnade xs =
  table_ tableAttrs $ do
    d1 <- case E.headednessExtractForall of
      Nothing -> return mempty
      Just extractForall -> do
        let (theadAttrs, theadTrAttrs) = extract mtheadAttrs
        thead_ theadAttrs $ tr_ theadTrAttrs $ do
          foldlMapM' (wrapContent th_ . extract . E.oneColonnadeHead) (E.getColonnade colonnade)
       where
        extract :: forall y. h y -> y
        extract = E.runExtractForall extractForall
    d2 <- encodeBody trAttrs wrapContent tbodyAttrs colonnade xs
    return (mappend d1 d2)

encodeBody ::
  (Foldable f, Monoid d) =>
  -- | Attributes of each @\<tr\>@ element
  (a -> [Attribute]) ->
  -- | Wrap content and convert to 'Html'
  (([Attribute] -> Html d -> Html d) -> c -> Html d) ->
  -- | Attributes of @\<tbody\>@ element
  [Attribute] ->
  -- | How to encode data as a row
  Colonnade h a c ->
  -- | Collection of data
  f a ->
  Html d
encodeBody trAttrs wrapContent tbodyAttrs colonnade xs = do
  tbody_ tbodyAttrs $ do
    flip foldlMapM' xs $ \x -> do
      tr_ (trAttrs x) $ E.rowMonadic colonnade (wrapContent td_) x

encodeBodySized ::
  (Foldable f, Monoid d) =>
  (a -> [Attribute]) ->
  [Attribute] ->
  Colonnade (E.Sized Int h) a (Cell d) ->
  f a ->
  Html ()
encodeBodySized trAttrs tbodyAttrs colonnade collection = tbody_ tbodyAttrs $ do
  for_ collection $ \a -> tr_ (trAttrs a) $ do
    E.rowMonoidalHeader
      colonnade
      ( \(E.Sized sz _) (Cell cattr content) ->
          void $ td_ (setColspanOrHide sz cattr) content
      )
      a

encodeTableSized ::
  forall f h a d.
  (Foldable f, E.Headedness h, Monoid d) =>
  -- | Attributes of @\<thead\>@ and its @\<tr\>@
  h ([Attribute], [Attribute]) ->
  -- | Attributes of @\<tbody\>@ element
  [Attribute] ->
  -- | Attributes of each @\<tr\>@ element
  (a -> [Attribute]) ->
  -- | Wrap content and convert to 'Html'
  (([Attribute] -> Html d -> Html d) -> (Cell d) -> Html d) ->
  -- | Attributes of @\<table\>@ element
  [Attribute] ->
  -- | How to encode data as a row
  Colonnade (E.Sized Int h) a (Cell d) ->
  -- | Collection of data
  f a ->
  Html ()
encodeTableSized mtheadAttrs tbodyAttrs trAttrs wrapContent tableAttrs colonnade xs =
  table_ tableAttrs $ do
    _ <- case E.headednessExtractForall of
      Nothing -> pure mempty
      Just extractForall -> do
        let (theadAttrs, theadTrAttrs) = extract mtheadAttrs
        thead_ theadAttrs $ tr_ theadTrAttrs $ do
          traverse_
            ( wrapContent th_
                . extract
                . ( \(E.Sized i h) -> case E.headednessExtract of
                      Just f ->
                        let (Cell attrs content) = f h
                         in E.headednessPure $ Cell (setColspanOrHide i attrs) content
                      Nothing -> E.headednessPure mempty
                      -- (E.Headed (Cell attrs content)) -> E.Headed $ Cell (setColspanOrHide i attrs) content
                      -- E.Headless -> E.Headless
                  )
                . E.oneColonnadeHead
            )
            (E.getColonnade colonnade)
       where
        extract :: forall y. h y -> y
        extract = E.runExtractForall extractForall
    encodeBodySized trAttrs tbodyAttrs colonnade xs

setColspanOrHide :: Int -> [Attribute] -> [Attribute]
setColspanOrHide i attrs
  | i < 1 = style_ "display:none;" : attrs
  | otherwise = colspan_ (Text.pack (show i)) : attrs

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

{- | Convert a 'Cell' to 'Html' by wrapping the content with a tag
and applying the 'Cell' attributes to that tag.
-}
htmlFromCell :: ([Attribute] -> Html d -> Html d) -> Cell d -> Html d
htmlFromCell f (Cell attr content) = f attr content

{- $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 a (Cell d) -> f a -> Html d

The 'Colonnade' content type is 'Cell', but the content
type of the result is 'Html'. It may not be immidiately clear why
this is 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 a (Html d) -> f a -> Html d

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.
-}

sectioned ::
  (Foldable f, E.Headedness h, Foldable g, Monoid c) =>
  -- | @\<table\>@ tag attributes
  [Attribute] ->
  -- | Attributes of @\<thead\>@ and its @\<tr\>@, pass 'Nothing' to omit @\<thead\>@
  Maybe ([Attribute], [Attribute]) ->
  -- | @\<tbody\>@ tag attributes
  [Attribute] ->
  -- | @\<tr\>@ tag attributes for data rows
  (a -> [Attribute]) ->
  -- | Section divider encoding strategy
  (b -> Cell c) ->
  -- | Data encoding strategy
  Colonnade h a (Cell c) ->
  -- | Collection of data
  f (b, g a) ->
  Html ()
sectioned tableAttrs mheadAttrs bodyAttrs trAttrs dividerContent colonnade@(E.Colonnade v) collection = do
  let vlen = V.length v
  table_ tableAttrs $ do
    for_ mheadAttrs $ \(headAttrs, headTrAttrs) ->
      thead_ headAttrs . tr_ headTrAttrs $
        E.headerMonadicGeneral_ colonnade (htmlFromCell th_)
    tbody_ bodyAttrs $ for_ collection $ \(b, as) -> do
      let Cell attrs contents = dividerContent b
      _ <- tr_ [] $ do
        td_ ((colspan_ $ T.pack (show vlen)) : attrs) contents
      flip traverse_ as $ \a -> do
        tr_ (trAttrs a) $ E.rowMonadic colonnade (htmlFromCell td_) a