summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorandrewthad <>2018-01-13 00:53:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2018-01-13 00:53:00 (GMT)
commit9374d4e5d2cc4485c48b63ee6c6ad05b6d029273 (patch)
tree07fa61b8c2bacf43a0735839cf6e34b33f52594a
version 1.01.0
-rw-r--r--LICENSE30
-rw-r--r--Setup.hs2
-rw-r--r--lucid-colonnade.cabal28
-rw-r--r--src/Lucid/Colonnade.hs193
4 files changed, 253 insertions, 0 deletions
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..9beb3f9
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,30 @@
+Copyright Andrew Martin (c) 2016
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Andrew Martin nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. \ No newline at end of file
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
index 0000000..9a994af
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/lucid-colonnade.cabal b/lucid-colonnade.cabal
new file mode 100644
index 0000000..39bb4e4
--- /dev/null
+++ b/lucid-colonnade.cabal
@@ -0,0 +1,28 @@
+name: lucid-colonnade
+version: 1.0
+synopsis: Helper functions for using lucid with colonnade
+description: Lucid and colonnade
+homepage: https://github.com/andrewthad/colonnade#readme
+license: BSD3
+license-file: LICENSE
+author: Andrew Martin
+maintainer: andrew.thaddeus@gmail.com
+copyright: 2017 Andrew Martin
+category: web
+build-type: Simple
+cabal-version: >=1.10
+
+library
+ hs-source-dirs: src
+ exposed-modules:
+ Lucid.Colonnade
+ build-depends:
+ base >= 4.7 && < 5
+ , colonnade >= 1.1 && < 1.3
+ , lucid >= 2.9 && < 3.0
+ , text >= 1.0 && < 1.3
+ default-language: Haskell2010
+
+source-repository head
+ type: git
+ location: https://github.com/andrewthad/colonnade
diff --git a/src/Lucid/Colonnade.hs b/src/Lucid/Colonnade.hs
new file mode 100644
index 0000000..600b99e
--- /dev/null
+++ b/src/Lucid/Colonnade.hs
@@ -0,0 +1,193 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+
+-- | 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
+ , encodeTable
+ -- * Cell
+ -- $build
+ , Cell(..)
+ , htmlCell
+ , stringCell
+ , textCell
+ , lazyTextCell
+ , builderCell
+ , htmlFromCell
+ -- * Discussion
+ -- $discussion
+ ) where
+
+import Colonnade (Colonnade,Headed,Headless,Fascia,Cornice)
+import Data.Text (Text)
+import Control.Monad
+import Data.Monoid
+import Data.Foldable
+import Data.String (IsString(..))
+import Data.Maybe (listToMaybe)
+import Data.Char (isSpace)
+import Control.Applicative (liftA2)
+import Lucid
+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
+
+-- $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 Monoid d => Monoid (Cell d) where
+ mempty = Cell mempty (return mempty)
+ mappend (Cell a1 c1) (Cell a2 c2) = Cell (mappend a1 a2) (liftA2 mappend c1 c2)
+
+-- | 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)
+ => [Attribute] -- ^ Attributes of @\<table\>@ element
+ -> Colonnade h a (Html d) -- ^ How to encode data as columns
+ -> f a -- ^ Collection of data
+ -> 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)
+ => [Attribute] -- ^ Attributes of @\<table\>@ element
+ -> Colonnade h a (Cell d) -- ^ How to encode data as columns
+ -> f a -- ^ Collection of data
+ -> Html d
+encodeCellTable = encodeTable
+ (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)
+ => 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) -> c -> Html d) -- ^ Wrap content and convert to 'Html'
+ -> [Attribute] -- ^ Attributes of @\<table\>@ element
+ -> Colonnade h a c -- ^ How to encode data as a row
+ -> f a -- ^ Collection of data
+ -> 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)
+ => (a -> [Attribute]) -- ^ Attributes of each @\<tr\>@ element
+ -> (([Attribute] -> Html d -> Html d) -> c -> Html d) -- ^ Wrap content and convert to 'Html'
+ -> [Attribute] -- ^ Attributes of @\<tbody\>@ element
+ -> Colonnade h a c -- ^ How to encode data as a row
+ -> f a -- ^ Collection of data
+ -> 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
+
+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.
+
+