From e956f2640378b9db35b7f1865f56885c616df111 Mon Sep 17 00:00:00 2001 From: Zachary Churchill Date: Mon, 3 Jun 2019 11:41:24 -0400 Subject: [PATCH] add sized tables to lucid-colonnade (#20) add sized table to lucid-colonnade --- lucid-colonnade/lucid-colonnade.cabal | 1 + lucid-colonnade/src/Lucid/Colonnade.hs | 97 +++++++++++++++++++++++++- 2 files changed, 97 insertions(+), 1 deletion(-) 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