Merge branch 'master' of github.com:andrewthad/colonnade

colonnade/colonnade.cabal

@@ -10,6 +10,8 @@ description:
   that provides (1) a content type and (2) functions for feeding
   data into a columnar encoding:
   .
+  * <https://hackage.haskell.org/package/lucid-colonnade lucid-colonnade> for `lucid` html tables
+  .
   * <https://hackage.haskell.org/package/blaze-colonnade blaze-colonnade> for `blaze` html tables
   .
   * <https://hackage.haskell.org/package/reflex-dom-colonnade reflex-dom-colonnade> for reactive `reflex-dom` tables

lucid-colonnade/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.

lucid-colonnade/Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

lucid-colonnade/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 && < 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

lucid-colonnade/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.
+
+

siphon/src/Siphon.hs

@@ -8,20 +8,8 @@
 -- | Build CSVs using the abstractions provided in the @colonnade@ library, and 
 --   parse CSVs using 'Siphon', which is the dual of 'Colonnade'.
 --   Read the documentation for @colonnade@ before reading the documentation
---   for @siphon@. All of the examples on this page assume the following
---   setup:
---
---   >>> :set -XOverloadedStrings
---   >>> import Siphon (Siphon)
---   >>> import Colonnade (Colonnade,Headed)
---   >>> import qualified Siphon as S
---   >>> import qualified Colonnade as C
---   >>> import qualified Data.Text as T
---   >>> import qualified Data.Text.Lazy.IO as LTIO
---   >>> import qualified Data.Text.Lazy.Builder as LB
---   >>> import Data.Text (Text)
---   >>> import Data.Maybe (fromMaybe)
---   >>> data Person = Person { name :: Text, age :: Int, company :: Maybe Text}
+--   for @siphon@. All of the examples on this page assume a common set of
+--   imports that are provided at the bottom of this page.
 module Siphon
   ( -- * Encode CSV
     encodeCsv
@@ -29,7 +17,7 @@ module Siphon
   , encodeCsvUtf8
   , encodeCsvStreamUtf8
     -- * Decode CSV
-  , decodeHeadedUtf8Csv
+  , decodeCsvUtf8
     -- * Build Siphon
   , headed
   , headless
@@ -40,6 +28,8 @@ module Siphon
   , Indexed(..)
     -- * Utility
   , humanizeSiphonError
+    -- * Imports
+    -- $setup
   ) where
 
 import Siphon.Types
@@ -89,11 +79,11 @@ data Ended = EndedYes | EndedNo
 data CellResult c = CellResultData !c | CellResultNewline !c !Ended
   deriving (Show)
 
-decodeHeadedUtf8Csv :: Monad m 
+decodeCsvUtf8 :: Monad m 
   => Siphon CE.Headed ByteString a
   -> Stream (Of ByteString) m () -- ^ encoded csv
   -> Stream (Of a) m (Maybe SiphonError)
-decodeHeadedUtf8Csv headedSiphon s1 = do
+decodeCsvUtf8 headedSiphon s1 = do
   e <- lift (consumeHeaderRowUtf8 s1)
   case e of
     Left err -> return (Just err)
@@ -353,7 +343,7 @@ field !delim = do
   case mb of
     Just b
       | b == doubleQuote -> do
-          (bs,tc) <- escapedField delim
+          (bs,tc) <- escapedField
           case tc of
             TrailCharComma -> return (CellResultData bs)
             TrailCharNewline -> return (CellResultNewline bs EndedNo)
@@ -376,8 +366,8 @@ field !delim = do
 eatNewlines :: AL.Parser S.ByteString
 eatNewlines = A.takeWhile (\x -> x == 10 || x == 13)
 
-escapedField :: Word8 -> AL.Parser (S.ByteString,TrailChar)
-escapedField !delim = do
+escapedField :: AL.Parser (S.ByteString,TrailChar)
+escapedField = do
   _ <- dquote
   -- The scan state is 'True' if the previous character was a double
   -- quote.  We need to drop a trailing double quote left by scan.
@@ -445,16 +435,6 @@ unescape = (LByteString.toStrict . toLazyByteString) <$!> go mempty where
 blankLine :: V.Vector B.ByteString -> Bool
 blankLine v = V.length v == 1 && (B.null (V.head v))
 
--- | A version of 'liftM2' that is strict in the result of its first
--- action.
-liftM2' :: (Monad m) => (a -> b -> c) -> m a -> m b -> m c
-liftM2' f a b = do
-    !x <- a
-    y <- b
-    return (f x y)
-{-# INLINE liftM2' #-}
-
-
 doubleQuote, newline, cr, comma :: Word8
 doubleQuote = 34
 newline = 10

siphon/test/Test.hs

@@ -69,7 +69,7 @@ tests =
               ]
     , testCase "Headed Decoding (int,char,bool)"
         $ ( runIdentity . SMP.toList )
-            ( S.decodeHeadedUtf8Csv decodingB
+            ( S.decodeCsvUtf8 decodingB
               ( mapM_ (SMP.yield . BC8.singleton) $ concat
                 [ "number,letter,boolean\n"
                 , "244,z,true\n"
@@ -78,7 +78,7 @@ tests =
             ) @?= ([(244,'z',True)] :> Nothing)
     , testCase "Headed Decoding (escaped characters, one big chunk)"
         $ ( runIdentity . SMP.toList )
-            ( S.decodeHeadedUtf8Csv decodingF
+            ( S.decodeCsvUtf8 decodingF
               ( SMP.yield $ BC8.pack $ concat
                 [ "name\n"
                 , "drew\n"
@@ -88,7 +88,7 @@ tests =
             ) @?= (["drew","martin, drew"] :> Nothing)
     , testCase "Headed Decoding (escaped characters, character per chunk)"
         $ ( runIdentity . SMP.toList )
-            ( S.decodeHeadedUtf8Csv decodingF
+            ( S.decodeCsvUtf8 decodingF
               ( mapM_ (SMP.yield . BC8.singleton) $ concat
                 [ "name\n"
                 , "drew\n"
@@ -98,7 +98,7 @@ tests =
             ) @?= (["drew","martin, drew"] :> Nothing)
     , testProperty "Headed Isomorphism (int,char,bool)"
         $ propIsoStream BC8.unpack
-          (S.decodeHeadedUtf8Csv decodingB)
+          (S.decodeCsvUtf8 decodingB)
           (S.encodeCsvStreamUtf8 encodingB)
     ]
   ]

stack.yaml

@@ -1,44 +1,9 @@
-# This file was automatically generated by 'stack init'
-#
-# Some commonly used options have been documented as comments in this file.
-# For advanced use and comprehensive documentation of the format, please see:
-# http://docs.haskellstack.org/en/stable/yaml_configuration/
-
-# Resolver to choose a 'specific' stackage snapshot or a compiler version.
-# A snapshot resolver dictates the compiler version and the set of packages
-# to be used for project dependencies. For example:
-#
-# resolver: lts-3.5
-# resolver: nightly-2015-09-21
-# resolver: ghc-7.10.2
-# resolver: ghcjs-0.1.0_ghc-7.10.2
-# resolver:
-#  name: custom-snapshot
-#  location: "./custom-snapshot.yaml"
 resolver: lts-8.0
-
-# User packages to be built.
-# Various formats can be used as shown in the example below.
-#
-# packages:
-# - some-directory
-# - https://example.com/foo/bar/baz-0.0.2.tar.gz
-# - location:
-#    git: https://github.com/commercialhaskell/stack.git
-#    commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
-# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a
-#   extra-dep: true
-#  subdirs:
-#  - auto-update
-#  - wai
-#
-# A package marked 'extra-dep: true' will only be built if demanded by a
-# non-dependency (i.e. a user package), and its test suites and benchmarks
-# will not be run. This is useful for tweaking upstream packages.
 packages:
 - 'colonnade'
 - 'yesod-colonnade'
 - 'blaze-colonnade'
+- 'lucid-colonnade'
 - 'siphon'
 # - 'geolite-csv'
 # Dependency packages to be pulled from upstream that are not in the resolver