add sized tables to lucid-colonnade (#20)

add sized table to lucid-colonnade

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

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 @\<table\>@ 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 @\<tr\>@ 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 @\<thead\>@ and its @\<tr\>@
+  -> [Attribute] -- ^ Attributes of @\<tbody\>@ element
+  -> (a -> [Attribute]) -- ^ Attributes of each @\<tr\>@ element
+  -> (([Attribute] -> Html d -> Html d) -> (Cell d) -> Html d) -- ^ Wrap content and convert to 'Html'
+  -> [Attribute] -- ^ Attributes of @\<table\>@ 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] -- ^ @\<table\>@ tag attributes
+  -> Maybe ([Attribute], [Attribute])
+  -- ^ Attributes of @\<thead\>@ and its @\<tr\>@, pass 'Nothing' to omit @\<thead\>@
+  -> [Attribute] -- ^ @\<tbody\>@ tag attributes
+  -> (a -> [Attribute]) -- ^ @\<tr\>@ 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