diff --git a/lucid-colonnade/lucid-colonnade.cabal b/lucid-colonnade/lucid-colonnade.cabal
index 41df29f..ed708ff 100644
--- a/lucid-colonnade/lucid-colonnade.cabal
+++ b/lucid-colonnade/lucid-colonnade.cabal
@@ -21,6 +21,7 @@ library
, colonnade >= 1.1.1 && < 1.3
, lucid >= 2.9 && < 3.0
, text >= 1.2 && < 1.3
+ , vector >= 0.10 && < 0.13
default-language: Haskell2010
source-repository head
diff --git a/lucid-colonnade/src/Lucid/Colonnade.hs b/lucid-colonnade/src/Lucid/Colonnade.hs
index e993040..7dfe6ab 100644
--- a/lucid-colonnade/src/Lucid/Colonnade.hs
+++ b/lucid-colonnade/src/Lucid/Colonnade.hs
@@ -1,6 +1,7 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE OverloadedStrings #-}
-- | Build HTML tables using @lucid@ and @colonnade@. It is
-- recommended that users read the documentation for @colonnade@ first,
@@ -13,6 +14,7 @@ module Lucid.Colonnade
( -- * Apply
encodeHtmlTable
, encodeCellTable
+ , encodeCellTableSized
, encodeTable
-- * Cell
-- $build
@@ -23,6 +25,8 @@ module Lucid.Colonnade
, lazyTextCell
, builderCell
, htmlFromCell
+ , encodeBodySized
+ , sectioned
-- * Discussion
-- $discussion
) where
@@ -37,12 +41,15 @@ import Data.String (IsString(..))
import Data.Maybe (listToMaybe)
import Data.Char (isSpace)
import Control.Applicative (liftA2)
-import Lucid
+import Lucid hiding (for_)
+import qualified Colonnade as Col
import qualified Data.List as List
import qualified Colonnade.Encode as E
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
+import qualified Data.Text as T
-- $build
--
@@ -116,6 +123,15 @@ encodeCellTable ::
encodeCellTable = encodeTable
(E.headednessPure ([],[])) mempty (const mempty) htmlFromCell
+encodeCellTableSized ::
+ (E.Headedness h, Foldable f, Monoid d)
+ => [Attribute] -- ^ Attributes of @\
@ element
+ -> Colonnade (E.Sized Int h) a (Cell d) -- ^ How to encode data as columns
+ -> f a -- ^ Collection of data
+ -> 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 @\@ elements.
@@ -158,6 +174,62 @@ encodeBody trAttrs wrapContent tbodyAttrs colonnade xs = 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 c.
+ (Foldable f, E.Headedness h, Monoid d)
+ => h ([Attribute],[Attribute]) -- ^ Attributes of @\@ and its @\@
+ -> [Attribute] -- ^ Attributes of @\
@ element
+ -> (a -> [Attribute]) -- ^ Attributes of each @\@ element
+ -> (([Attribute] -> Html d -> Html d) -> (Cell d) -> Html d) -- ^ Wrap content and convert to 'Html'
+ -> [Attribute] -- ^ Attributes of @\@ element
+ -> Colonnade (E.Sized Int h) a (Cell d) -- ^ How to encode data as a row
+ -> f a -- ^ Collection of data
+ -> Html ()
+encodeTableSized mtheadAttrs tbodyAttrs trAttrs wrapContent tableAttrs colonnade xs =
+ table_ tableAttrs $ do
+ d1 <- 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
@@ -194,4 +266,27 @@ htmlFromCell f (Cell attr content) = f attr content
-- 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)
+ => [Attribute] -- ^ @\@ tag attributes
+ -> Maybe ([Attribute], [Attribute])
+ -- ^ Attributes of @\@ and its @\@, pass 'Nothing' to omit @\@
+ -> [Attribute] -- ^ @\
@ tag attributes
+ -> (a -> [Attribute]) -- ^ @\@ tag attributes for data rows
+ -> (b -> Cell c) -- ^ Section divider encoding strategy
+ -> Colonnade h a (Cell c) -- ^ Data encoding strategy
+ -> f (b, g a) -- ^ Collection of data
+ -> 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