yesod-colonnade base upper bound bump

add sized table to lucid-colonnade

.gitignore

@@ -28,3 +28,12 @@ colonnade/ex1.hs
 colonnade/result
 
 reflex-dom-colonnade/result
+siphon-0.8.0-docs.tar.gz
+siphon-0.8.0-docs/
+.ghc.environment.*
+example
+example.hs
+example1
+example1.hs
+client_session_key.aes
+cabal.project.local

blaze-colonnade/blaze-colonnade.cabal

@@ -1,27 +1,36 @@
-name:                blaze-colonnade
+name: blaze-colonnade
-version:             1.1.0
+version: 1.2.2.1
-synopsis:            Helper functions for using blaze-html with colonnade
+synopsis: blaze-html backend for colonnade
-description:         Blaze HTML and colonnade
+description:
-homepage:            https://github.com/andrewthad/colonnade#readme
+  This library provides a backend for using blaze-html with colonnade.
-license:             BSD3
+  It generates standard HTML tables with `<table>`, `<tbody>`, `<thead>`,
-license-file:        LICENSE
+  `<tr>`, `<th>`, and `<td>`.
-author:              Andrew Martin
+homepage: https://github.com/andrewthad/colonnade#readme
-maintainer:          andrew.thaddeus@gmail.com
+license: BSD3
-copyright:           2017 Andrew Martin
+license-file: LICENSE
-category:            web
+author: Andrew Martin
-build-type:          Simple
+maintainer: andrew.thaddeus@gmail.com
-cabal-version:       >=1.10
+copyright: 2017 Andrew Martin
+category: web
+build-type: Simple
+cabal-version: >=1.10
+
+-- Note: There is a dependency on profunctors whose only
+-- purpose is to make doctest work correctly. Since this
+-- library transitively depends on profunctors anyway,
+-- this is not a big deal.
 
 library
   hs-source-dirs:      src
   exposed-modules:
     Text.Blaze.Colonnade
   build-depends:
-      base >= 4.7 && < 5
+      base >= 4.8 && < 5
-    , colonnade >= 1.1 && < 1.2
+    , colonnade >= 1.1 && < 1.3
     , blaze-markup >= 0.7 && < 0.9
     , blaze-html >= 0.8 && < 0.10
-    , text >= 1.0 && < 1.3
+    , profunctors >= 5.0 && < 5.5
+    , text >= 1.2 && < 1.3
   default-language:    Haskell2010
 
 test-suite test
@@ -32,6 +41,7 @@ test-suite test
       base >= 4.7 && <= 5
     , colonnade
     , doctest
+    , profunctors
   default-language: Haskell2010
 
 source-repository head

blaze-colonnade/src/Text/Blaze/Colonnade.hs

@@ -1,3 +1,7 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
 -- | Build HTML tables using @blaze-html@ and @colonnade@. The bottom
 --   of this page has a tutorial that walks through a full example,
 --   illustrating how to meet typical needs with this library. It is
@@ -9,7 +13,7 @@
 -- >>> :module + Colonnade Text.Blaze.Html Text.Blaze.Colonnade
 -- >>> let col = headed "Grade" (toHtml . fst) <> headed "Letter" (toHtml . snd)
 -- >>> let rows = [("90-100",'A'),("80-89",'B'),("70-79",'C')]
--- >>> printVeryCompactHtml (encodeHeadedHtmlTable mempty col rows)
+-- >>> printVeryCompactHtml (encodeHtmlTable mempty col rows)
 -- <table>
 --     <thead>
 --         <tr><th>Grade</th><th>Letter</th></tr>
@@ -22,10 +26,8 @@
 -- </table>
 module Text.Blaze.Colonnade
   ( -- * Apply
-    encodeHeadedHtmlTable
+    encodeHtmlTable
-  , encodeHeadlessHtmlTable
+  , encodeCellTable
-  , encodeHeadedCellTable
-  , encodeHeadlessCellTable
   , encodeTable
   , encodeCappedTable
     -- * Cell
@@ -52,7 +54,8 @@ import Text.Blaze.Html (Html, toHtml)
 import Colonnade (Colonnade,Headed,Headless,Fascia,Cornice)
 import Data.Text (Text)
 import Control.Monad
-import Data.Monoid
+import Data.Semigroup
+import Data.Monoid hiding ((<>))
 import Data.Foldable
 import Data.String (IsString(..))
 import Data.Maybe (listToMaybe)
@@ -62,7 +65,7 @@ import qualified Text.Blaze.Html.Renderer.Pretty as Pretty
 import qualified Text.Blaze as Blaze
 import qualified Text.Blaze.Html5 as H
 import qualified Text.Blaze.Html5.Attributes as HA
-import qualified Colonnade.Encode as Encode
+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
@@ -113,7 +116,7 @@ import qualified Data.Text.Lazy.Builder as TBuilder
 -- Let\'s continue:
 --
 -- >>> let customAttrs = HA.class_ "stylish-table" <> HA.id "main-table"
--- >>> printCompactHtml (encodeHeadedHtmlTable customAttrs tableEmpA employees)
+-- >>> printCompactHtml (encodeHtmlTable customAttrs tableEmpA employees)
 -- <table class="stylish-table" id="main-table">
 --     <thead>
 --         <tr>
@@ -163,10 +166,10 @@ import qualified Data.Text.Lazy.Builder as TBuilder
 -- literal @"Dept."@ to be accepted as a value of type 'Cell'. To avoid
 -- this extension, 'stringCell' could be used to upcast the 'String'.
 -- To try out our 'Colonnade' on a list of departments, we need to use
--- 'encodeHeadedCellTable' instead of 'encodeHeadedHtmlTable':
+-- 'encodeCellTable' instead of 'encodeHtmlTable':
 --
 -- >>> let twoDepts = [Sales,Management]
--- >>> printVeryCompactHtml (encodeHeadedCellTable customAttrs tableDept twoDepts)
+-- >>> printVeryCompactHtml (encodeCellTable customAttrs tableDept twoDepts)
 -- <table class="stylish-table" id="main-table">
 --     <thead>
 --         <tr><th>Dept.</th></tr>
@@ -186,7 +189,7 @@ import qualified Data.Text.Lazy.Builder as TBuilder
 -- >>> let tableEmpB = lmap department tableDept
 -- >>> :t tableEmpB
 -- tableEmpB :: Colonnade Headed Employee Cell
--- >>> printVeryCompactHtml (encodeHeadedCellTable customAttrs tableEmpB employees)
+-- >>> printVeryCompactHtml (encodeCellTable customAttrs tableEmpB employees)
 -- <table class="stylish-table" id="main-table">
 --     <thead>
 --         <tr><th>Dept.</th></tr>
@@ -218,7 +221,7 @@ import qualified Data.Text.Lazy.Builder as TBuilder
 -- >>> let tableEmpC = fmap htmlCell tableEmpA <> tableEmpB
 -- >>> :t tableEmpC
 -- tableEmpC :: Colonnade Headed Employee Cell
--- >>> printCompactHtml (encodeHeadedCellTable customAttrs tableEmpC employees)
+-- >>> printCompactHtml (encodeCellTable customAttrs tableEmpC employees)
 -- <table class="stylish-table" id="main-table">
 --     <thead>
 --         <tr>
@@ -265,9 +268,12 @@ data Cell = Cell
 instance IsString Cell where
   fromString = stringCell
 
+instance Semigroup Cell where
+  (Cell a1 c1) <> (Cell a2 c2) = Cell (a1 <> a2) (c1 <> c2)
+
 instance Monoid Cell where
   mempty = Cell mempty mempty
-  mappend (Cell a1 c1) (Cell a2 c2) = Cell (mappend a1 a2) (mappend c1 c2)
+  mappend = (<>)
 
 -- | Create a 'Cell' from a 'Widget'
 htmlCell :: Html -> Cell
@@ -296,9 +302,8 @@ builderCell = lazyTextCell . TBuilder.toLazyText
 -- | 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.
-encodeTable ::
+encodeTable :: forall h f a c. (Foldable f, E.Headedness h)
-     (Foldable f, Foldable h)
+  => h (Attribute,Attribute) -- ^ Attributes of @\<thead\>@ and its @\<tr\>@, pass 'Nothing' to omit @\<thead\>@
-  => Maybe (Attribute,Attribute) -- ^ Attributes of @\<thead\>@ and its @\<tr\>@, pass 'Nothing' to omit @\<thead\>@
   -> Attribute -- ^ Attributes of @\<tbody\>@ element
   -> (a -> Attribute) -- ^ Attributes of each @\<tr\>@ element
   -> ((Html -> Html) -> c -> Html) -- ^ Wrap content and convert to 'Html'
@@ -308,11 +313,27 @@ encodeTable ::
   -> Html
 encodeTable mtheadAttrs tbodyAttrs trAttrs wrapContent tableAttrs colonnade xs =
   H.table ! tableAttrs $ do
-    for_ mtheadAttrs $ \(theadAttrs,theadTrAttrs) -> do
+    case E.headednessExtractForall of
-      H.thead ! theadAttrs $ H.tr ! theadTrAttrs $ do
+      Nothing -> return mempty
-        Encode.headerMonoidalGeneral colonnade (wrapContent H.th)
+      Just extractForall -> do
+        let (theadAttrs,theadTrAttrs) = extract mtheadAttrs
+        H.thead ! theadAttrs $ H.tr ! theadTrAttrs $ do
+          -- E.headerMonoidalGeneral colonnade (wrapContent H.th)
+          foldlMapM' (wrapContent H.th . extract . E.oneColonnadeHead) (E.getColonnade colonnade)
+        where
+        extract :: forall y. h y -> y
+        extract = E.runExtractForall extractForall
     encodeBody trAttrs wrapContent tbodyAttrs colonnade xs
 
+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
+
 -- | Encode a table with tiered header rows.
 -- >>> let cor = mconcat [cap "Personal" (fmap htmlCell tableEmpA), cap "Work" tableEmpB]
 -- >>> let fascia = FasciaCap (HA.class_ "category") (FasciaBase (HA.class_ "subcategory"))
@@ -341,7 +362,7 @@ encodeTable mtheadAttrs tbodyAttrs trAttrs wrapContent tableAttrs colonnade xs =
 encodeCappedCellTable :: Foldable f
   => Attribute -- ^ Attributes of @\<table\>@ element
   -> Fascia p Attribute -- ^ Attributes for @\<tr\>@ elements in the @\<thead\>@
-  -> Cornice p a Cell 
+  -> Cornice Headed p a Cell 
   -> f a -- ^ Collection of data
   -> Html
 encodeCappedCellTable = encodeCappedTable mempty mempty (const mempty) htmlFromCell
@@ -356,23 +377,28 @@ encodeCappedTable :: Foldable f
   -> ((Html -> Html) -> c -> Html) -- ^ Wrap content and convert to 'Html'
   -> Attribute -- ^ Attributes of @\<table\>@ element
   -> Fascia p Attribute -- ^ Attributes for @\<tr\>@ elements in the @\<thead\>@
-  -> Cornice p a c 
+  -> Cornice Headed p a c 
   -> f a -- ^ Collection of data
   -> Html
 encodeCappedTable theadAttrs tbodyAttrs trAttrs wrapContent tableAttrs fascia cornice xs = do
-  let colonnade = Encode.discard cornice
+  let colonnade = E.discard cornice
-      annCornice = Encode.annotate cornice
+      annCornice = E.annotate cornice
   H.table ! tableAttrs $ do
     H.thead ! theadAttrs $ do
-      Encode.headersMonoidal 
+      E.headersMonoidal 
         (Just (fascia, \attrs theHtml -> H.tr ! attrs $ theHtml))
-        [(\sz c -> wrapContent H.th c ! HA.colspan (H.toValue (show sz)),id)]
+        [ ( \msz c -> case msz of
+              Just sz -> wrapContent H.th c ! HA.colspan (H.toValue (show sz))
+              Nothing -> mempty
+          , id
+          )
+        ]
         annCornice
       -- H.tr ! trAttrs $ do
-      -- Encode.headerMonoidalGeneral colonnade (wrapContent H.th)
+      -- E.headerMonoidalGeneral colonnade (wrapContent H.th)
     encodeBody trAttrs wrapContent tbodyAttrs colonnade xs
 
-encodeBody :: (Foldable h, Foldable f)
+encodeBody :: Foldable f
   => (a -> Attribute) -- ^ Attributes of each @\<tr\>@ element
   -> ((Html -> Html) -> c -> Html) -- ^ Wrap content and convert to 'Html'
   -> Attribute -- ^ Attributes of @\<tbody\>@ element
@@ -382,52 +408,30 @@ encodeBody :: (Foldable h, Foldable f)
 encodeBody trAttrs wrapContent tbodyAttrs colonnade xs = do
   H.tbody ! tbodyAttrs $ do
     forM_ xs $ \x -> do
-      H.tr ! trAttrs x $ Encode.rowMonoidal colonnade (wrapContent H.td) x
+      H.tr ! trAttrs x $ E.rowMonoidal colonnade (wrapContent H.td) x
   
 
--- | Encode a table with a header. Table cells may have attributes
+-- | Encode a table. Table cells may have attributes
 --   applied to them.
-encodeHeadedCellTable :: 
+encodeCellTable :: 
      Foldable f
   => Attribute -- ^ Attributes of @\<table\>@ element
   -> Colonnade Headed a Cell -- ^ How to encode data as columns
   -> f a -- ^ Collection of data
   -> Html
-encodeHeadedCellTable = encodeTable
+encodeCellTable = encodeTable
-  (Just (mempty,mempty)) mempty (const mempty) htmlFromCell 
+  (E.headednessPure (mempty,mempty)) mempty (const mempty) htmlFromCell 
 
--- | Encode a table without a header. Table cells may have attributes
+-- | Encode a table. Table cell element do not have 
---   applied to them.
-encodeHeadlessCellTable :: 
-     Foldable f
-  => Attribute -- ^ Attributes of @\<table\>@ element
-  -> Colonnade Headless a Cell -- ^ How to encode data as columns
-  -> f a -- ^ Collection of data
-  -> Html
-encodeHeadlessCellTable = encodeTable
-  Nothing mempty (const mempty) htmlFromCell 
-
--- | Encode a table with a header. Table cell element do not have 
 --   any attributes applied to them.
-encodeHeadedHtmlTable :: 
+encodeHtmlTable :: 
-     Foldable f
+     (Foldable f, E.Headedness h)
   => Attribute -- ^ Attributes of @\<table\>@ element
-  -> Colonnade Headed a Html -- ^ How to encode data as columns
+  -> Colonnade h a Html -- ^ How to encode data as columns
   -> f a -- ^ Collection of data
   -> Html
-encodeHeadedHtmlTable = encodeTable
+encodeHtmlTable = encodeTable
-  (Just (mempty,mempty)) mempty (const mempty) ($) 
+  (E.headednessPure (mempty,mempty)) mempty (const mempty) ($) 
-
--- | Encode a table without a header. Table cells do not have
---   any attributes applied to them.
-encodeHeadlessHtmlTable :: 
-     Foldable f
-  => Attribute -- ^ Attributes of @\<table\>@ element
-  -> Colonnade Headless a Html -- ^ How to encode data as columns
-  -> f a -- ^ Collection of data
-  -> Html
-encodeHeadlessHtmlTable = encodeTable
-  Nothing mempty (const mempty) ($) 
 
 -- | Convert a 'Cell' to 'Html' by wrapping the content with a tag
 -- and applying the 'Cell' attributes to that tag.

build

@@ -0,0 +1,16 @@
+#!/bin/bash
+set -e
+
+# To use this script on Ubuntu, you will need to first run the following:
+# 
+# sudo apt install ghc-7.4.2 ghc-7.6.3 ghc-7.8.4 ghc-7.10.3 ghc-8.0.2 ghc-8.2.2 ghc-8.4.3 ghc-8.6.1
+
+declare -a ghcs=("7.10.3" "8.0.2" "8.2.2" "8.4.4" "8.6.5")
+
+## now loop through the above array
+for g in "${ghcs[@]}"
+do
+   cabal new-build --builddir "dist-$g" -w "/opt/ghc/bin/ghc-$g" colonnade
+   cabal new-build --builddir "dist-$g" -w "/opt/ghc/bin/ghc-$g" siphon
+done
+

cabal.project

@@ -0,0 +1,4 @@
+packages: ./colonnade
+          ./blaze-colonnade
+          ./lucid-colonnade
+          ./siphon

colonnade/colonnade.cabal

@@ -1,8 +1,8 @@
-name:                colonnade
+name: colonnade
-version:             1.1.0
+version: 1.2.0.2
-synopsis:            Generic types and functions for columnar encoding and decoding
+synopsis: Generic types and functions for columnar encoding and decoding
 description:
-  The `colonnade` package provides a way to to talk about
+  The `colonnade` package provides a way to talk about
   columnar encodings and decodings of data. This package provides
   very general types and does not provide a way for the end-user
   to actually apply the columnar encodings they build to data.
@@ -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
@@ -17,15 +19,15 @@ description:
   * <https://hackage.haskell.org/package/yesod-colonnade yesod-colonnade> for `yesod` widgets
   .
   * <http://hackage.haskell.org/package/siphon siphon> for encoding and decoding CSVs
-homepage:            https://github.com/andrewthad/colonnade#readme
+homepage: https://github.com/andrewthad/colonnade#readme
-license:             BSD3
+license: BSD3
-license-file:        LICENSE
+license-file: LICENSE
-author:              Andrew Martin
+author: Andrew Martin
-maintainer:          andrew.thaddeus@gmail.com
+maintainer: andrew.thaddeus@gmail.com
-copyright:           2016 Andrew Martin
+copyright: 2016 Andrew Martin
-category:            web
+category: web
-build-type:          Simple
+build-type: Simple
-cabal-version:       >=1.10
+cabal-version: >=1.10
 
 library
   hs-source-dirs:      src
@@ -33,23 +35,28 @@ library
     Colonnade
     Colonnade.Encode
   build-depends:
-      base >= 4.7 && < 5
+      base >= 4.8 && < 5
-    , contravariant >= 1.2 && < 1.5
+    , contravariant >= 1.2 && < 1.6
     , vector >= 0.10 && < 0.13
     , text >= 1.0 && < 1.3
     , bytestring >= 0.10 && < 0.11
-    , profunctors >= 4.0 && < 5.3
+    , profunctors >= 5.0 && < 5.5
+    , semigroups >= 0.18.2 && < 0.20
   default-language:    Haskell2010
   ghc-options: -Wall
 
 test-suite test
-  type:             exitcode-stdio-1.0
+  type: exitcode-stdio-1.0
-  hs-source-dirs:   test
+  hs-source-dirs: test
-  main-is:          Main.hs
+  main-is: Main.hs
   build-depends:
       base >= 4.7 && <= 5
     , colonnade
     , doctest
+    , semigroupoids
+    , ansi-wl-pprint
+    , QuickCheck
+    , fast-logger
   default-language: Haskell2010
 
 source-repository head

colonnade/default.nix

@@ -0,0 +1,8 @@
+{ frontend ? false }:
+let
+  pname = "colonnade"; 
+  main = (import ../nix/default.nix {
+    inherit frontend;
+  });
+in
+  main.${pname}

colonnade/shell.nix

@@ -0,0 +1 @@
+(import ./. {}).env

colonnade/src/Colonnade.hs

@@ -1,7 +1,7 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE RankNTypes #-}
 
-{-# OPTIONS_GHC -Wall -fno-warn-unused-imports -fno-warn-unticked-promoted-constructors -Werror #-}
+{-# OPTIONS_GHC -Wall -fno-warn-unused-imports -fno-warn-unticked-promoted-constructors #-}
 
 -- | Build backend-agnostic columnar encodings that can be 
 --   used to visualize tabular data.
@@ -12,6 +12,8 @@ module Colonnade
     Colonnade
   , Headed(..)
   , Headless(..)
+    -- * Typeclasses
+  , E.Headedness(..)
     -- * Create
   , headed
   , headless
@@ -272,7 +274,7 @@ replaceWhen = modifyWhen . const
 --   
 --   >>> let cor = mconcat [cap "Person" colPersonFst, cap "House" colHouseSnd]
 --   >>> :t cor
---   cor :: Cornice ('Cap 'Base) (Person, House) [Char]
+--   cor :: Cornice Headed ('Cap 'Base) (Person, House) [Char]
 --   >>> putStr (asciiCapped cor personHomePairs)
 --   +-------------+-----------------+
 --   | Person      | House           |
@@ -284,7 +286,7 @@ replaceWhen = modifyWhen . const
 --   | Sonia | 12  | Green | $150000 |
 --   +-------+-----+-------+---------+
 --   
-cap :: c -> Colonnade Headed a c -> Cornice (Cap Base) a c
+cap :: c -> Colonnade h a c -> Cornice h (Cap Base) a c
 cap h = E.CorniceCap . Vector.singleton . E.OneCornice h . E.CorniceBase
 
 -- | Add another cap to a cornice. There is no limit to how many times
@@ -319,11 +321,11 @@ cap h = E.CorniceCap . Vector.singleton . E.OneCornice h . E.CorniceBase
 --   | Weekday | $8 | $8 | $8 | $6   | $7    | $8 | $8 | $8 | $6   | $7    |
 --   | Weekend | $9 | $9 | $9 | $7   | $8    | $9 | $9 | $9 | $7   | $8    |
 --   +---------+----+----+----+------+-------+----+----+----+------+-------+
-recap :: c -> Cornice p a c -> Cornice (Cap p) a c
+recap :: c -> Cornice h p a c -> Cornice h (Cap p) a c
 recap h cor = E.CorniceCap (Vector.singleton (E.OneCornice h cor))
 
 asciiCapped :: Foldable f
-  => Cornice p a String -- ^ columnar encoding
+  => Cornice Headed p a String -- ^ columnar encoding
   -> f a -- ^ rows
   -> String
 asciiCapped cor xs =
@@ -332,8 +334,16 @@ asciiCapped cor xs =
       sizedCol = E.uncapAnnotated annCor
    in E.headersMonoidal
         Nothing 
-        [ (\sz _ -> hyphens (sz + 2) ++ "+", \s -> "+" ++ s ++ "\n")
+        [ ( \msz _ -> case msz of
-        , (\sz c -> " " ++ rightPad sz ' ' c ++ " |", \s -> "|" ++ s ++ "\n")
+              Just sz -> "+" ++ hyphens (sz + 2)
+              Nothing -> ""
+          , \s -> s ++ "+\n"
+          )
+        , ( \msz c -> case msz of
+              Just sz -> "| " ++ rightPad sz ' ' c ++ " "
+              Nothing -> ""
+          , \s -> s ++ "|\n"
+          )
         ] annCor ++ asciiBody sizedCol xs
       
 
@@ -349,41 +359,49 @@ ascii :: Foldable f
 ascii col xs = 
   let sizedCol = E.sizeColumns List.length xs col
       divider = concat
-        [ "+" 
+        [ E.headerMonoidalFull sizedCol 
-        , E.headerMonoidalFull sizedCol 
+             (\(E.Sized msz _) -> case msz of
-             (\(E.Sized sz _) -> hyphens (sz + 2) ++ "+")
+               Just sz -> "+" ++ hyphens (sz + 2)
-        , "\n"
+               Nothing -> ""
+             )
+        , "+\n"
         ]
    in List.concat
       [ divider
       , concat
-         [ "|"
+         [ E.headerMonoidalFull sizedCol
-         , E.headerMonoidalFull sizedCol
+             (\(E.Sized msz (Headed h)) -> case msz of
-             (\(E.Sized s (Headed h)) -> " " ++ rightPad s ' ' h ++ " |")
+               Just sz -> "| " ++ rightPad sz ' ' h ++ " "
-         , "\n"
+               Nothing -> ""
+             )
+         , "|\n"
          ]
       , asciiBody sizedCol xs
       ]
 
 asciiBody :: Foldable f
-  => Colonnade (E.Sized Headed) a String
+  => Colonnade (E.Sized (Maybe Int) Headed) a String
   -> f a
   -> String
 asciiBody sizedCol xs =
   let divider = concat
-        [ "+" 
+        [ E.headerMonoidalFull sizedCol 
-        , E.headerMonoidalFull sizedCol 
+             (\(E.Sized msz _) -> case msz of
-             (\(E.Sized sz _) -> hyphens (sz + 2) ++ "+")
+               Just sz -> "+" ++ hyphens (sz + 2)
-        , "\n"
+               Nothing -> ""
+             )
+        , "+\n"
         ]
       rowContents = foldMap
         (\x -> concat
-           [ "|"
+           [ E.rowMonoidalHeader 
-           , E.rowMonoidalHeader 
                sizedCol
-               (\(E.Sized sz _) c -> " " ++ rightPad sz ' ' c ++ " |")
+               (\(E.Sized msz _) c -> case msz of
+                 Nothing -> ""
+                 Just sz -> "| " ++ rightPad sz ' ' c ++ " "
+               )
                x
-           , "\n"
+           , "|\n"
            ]
         ) xs
    in List.concat

colonnade/src/Colonnade/Encode.hs

@@ -8,7 +8,7 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 
 {-# OPTIONS_HADDOCK not-home #-}
-{-# OPTIONS_GHC -Wall -fno-warn-unused-imports -fno-warn-unticked-promoted-constructors -Werror #-}
+{-# OPTIONS_GHC -Wall -fno-warn-unused-imports -fno-warn-unticked-promoted-constructors #-}
 
 -- | Most users of this library do not need this module. The functions
 --   here are used to build functions that apply a 'Colonnade'
@@ -44,6 +44,9 @@ module Colonnade.Encode
   , Headed(..)
   , Headless(..)
   , Sized(..)
+  , ExtractForall(..)
+    -- ** Typeclasses
+  , Headedness(..)
     -- ** Row
   , row
   , rowMonadic
@@ -175,7 +178,7 @@ sizeColumns :: (Foldable f, Foldable h)
   => (c -> Int) -- ^ Get size from content
   -> f a
   -> Colonnade h a c
-  -> Colonnade (Sized h) a c
+  -> Colonnade (Sized (Maybe Int) h) a c
 sizeColumns toSize rows colonnade = runST $ do
   mcol <- newMutableSizedColonnade colonnade
   headerUpdateSize toSize mcol 
@@ -187,14 +190,14 @@ newMutableSizedColonnade (Colonnade v) = do
   mv <- MVU.replicate (V.length v) 0
   return (MutableSizedColonnade v mv)
 
-freezeMutableSizedColonnade :: MutableSizedColonnade s h a c -> ST s (Colonnade (Sized h) a c)
+freezeMutableSizedColonnade :: MutableSizedColonnade s h a c -> ST s (Colonnade (Sized (Maybe Int) h) a c)
 freezeMutableSizedColonnade (MutableSizedColonnade v mv) =
   if MVU.length mv /= V.length v
     then error "rowMonoidalSize: vector sizes mismatched"
     else do
       sizeVec <- VU.freeze mv
       return $ Colonnade
-        $ V.map (\(OneColonnade h enc,sz) -> OneColonnade (Sized sz h) enc)
+        $ V.map (\(OneColonnade h enc,sz) -> OneColonnade (Sized (Just sz) h) enc)
         $ V.zip v (GV.convert sizeVec)
 
 rowMonadicWith :: 
@@ -234,12 +237,13 @@ headerMonadic (Colonnade v) g =
   fmap (mconcat . Vector.toList) $ Vector.mapM (g . getHeaded . oneColonnadeHead) v
 
 headerMonadicGeneral_ :: 
-     (Monad m, Foldable h)
+     (Monad m, Headedness h)
   => Colonnade h a c
   -> (c -> m b)
   -> m ()
-headerMonadicGeneral_ (Colonnade v) g =
+headerMonadicGeneral_ (Colonnade v) g = case headednessExtract of
-  Vector.mapM_ (mapM_ g . oneColonnadeHead) v
+  Nothing -> return ()
+  Just f -> Vector.mapM_ (g . f . oneColonnadeHead) v
 
 headerMonoidalGeneral ::
      (Monoid m, Foldable h)
@@ -266,37 +270,41 @@ headerMonadic_ (Colonnade v) g = Vector.mapM_ (g . getHeaded . oneColonnadeHead)
 foldlMapM :: (Foldable t, Monoid b, Monad m) => (a -> m b) -> t a -> m b
 foldlMapM f = foldlM (\b a -> fmap (mappend b) (f a)) mempty
 
-discard :: Cornice p a c -> Colonnade Headed a c
+discard :: Cornice h p a c -> Colonnade h a c
 discard = go where
-  go :: forall p a c. Cornice p a c -> Colonnade Headed a c
+  go :: forall h p a c. Cornice h p a c -> Colonnade h a c
   go (CorniceBase c) = c
   go (CorniceCap children) = Colonnade (getColonnade . go . oneCorniceBody =<< children)
 
-endow :: forall p a c. (c -> c -> c) -> Cornice p a c -> Colonnade Headed a c
+endow :: forall p a c. (c -> c -> c) -> Cornice Headed p a c -> Colonnade Headed a c
 endow f x = case x of
   CorniceBase colonnade -> colonnade
   CorniceCap v -> Colonnade (V.concatMap (\(OneCornice h b) -> go h b) v)
   where
-  go :: forall p'. c -> Cornice p' a c -> Vector (OneColonnade Headed a c)
+  go :: forall p'. c -> Cornice Headed p' a c -> Vector (OneColonnade Headed a c)
   go c (CorniceBase (Colonnade v)) = V.map (mapOneColonnadeHeader (f c)) v
   go c (CorniceCap v) = V.concatMap (\(OneCornice h b) -> go (f c h) b) v
 
-uncapAnnotated :: forall p a c. AnnotatedCornice p a c -> Colonnade (Sized Headed) a c
+uncapAnnotated :: forall sz p a c h.
+     AnnotatedCornice sz h p a c
+  -> Colonnade (Sized sz h) a c
 uncapAnnotated x = case x of
   AnnotatedCorniceBase _ colonnade -> colonnade
   AnnotatedCorniceCap _ v -> Colonnade (V.concatMap (\(OneCornice _ b) -> go b) v)
   where
-  go :: forall p'. AnnotatedCornice p' a c -> Vector (OneColonnade (Sized Headed) a c)
+  go :: forall p'. 
+       AnnotatedCornice sz h p' a c
+    -> Vector (OneColonnade (Sized sz h) a c)
   go (AnnotatedCorniceBase _ (Colonnade v)) = v
   go (AnnotatedCorniceCap _ v) = V.concatMap (\(OneCornice _ b) -> go b) v
 
-annotate :: Cornice p a c -> AnnotatedCornice p a c
+annotate :: Cornice Headed p a c -> AnnotatedCornice (Maybe Int) Headed p a c
 annotate = go where
-  go :: forall p a c. Cornice p a c -> AnnotatedCornice p a c
+  go :: forall p a c. Cornice Headed p a c -> AnnotatedCornice (Maybe Int) Headed p a c
   go (CorniceBase c) = let len = V.length (getColonnade c) in
     AnnotatedCorniceBase
       (if len > 0 then (Just len) else Nothing)
-      (mapHeadedness (Sized 1) c)
+      (mapHeadedness (Sized (Just 1)) c)
   go (CorniceCap children) =
     let annChildren = fmap (mapOneCorniceBody go) children
      in AnnotatedCorniceCap 
@@ -324,8 +332,8 @@ annotateFinely :: Foldable f
   -> (Int -> Int) -- ^ finalize
   -> (c -> Int) -- ^ Get size from content
   -> f a
-  -> Cornice p a c 
+  -> Cornice Headed p a c 
-  -> AnnotatedCornice p a c
+  -> AnnotatedCornice (Maybe Int) Headed p a c
 annotateFinely g finish toSize xs cornice = runST $ do
   m <- newMutableSizedCornice cornice
   sizeColonnades toSize xs m
@@ -352,16 +360,18 @@ freezeMutableSizedCornice :: forall s p a c.
      (Int -> Int -> Int) -- ^ fold function
   -> (Int -> Int) -- ^ finalize
   -> MutableSizedCornice s p a c 
-  -> ST s (AnnotatedCornice p a c)
+  -> ST s (AnnotatedCornice (Maybe Int) Headed p a c)
 freezeMutableSizedCornice step finish = go
   where
-  go :: forall p' a' c'. MutableSizedCornice s p' a' c' -> ST s (AnnotatedCornice p' a' c')
+  go :: forall p' a' c'.
+       MutableSizedCornice s p' a' c' 
+    -> ST s (AnnotatedCornice (Maybe Int) Headed p' a' c')
   go (MutableSizedCorniceBase msc) = do
     szCol <- freezeMutableSizedColonnade msc
     let sz = 
           ( mapJustInt finish 
           . V.foldl' (combineJustInt step) Nothing 
-          . V.map (Just . sizedSize . oneColonnadeHead)
+          . V.map (sizedSize . oneColonnadeHead)
           ) (getColonnade szCol)
     return (AnnotatedCorniceBase sz szCol)
   go (MutableSizedCorniceCap v1) = do
@@ -374,10 +384,10 @@ freezeMutableSizedCornice step finish = go
     return $ AnnotatedCorniceCap sz v2
 
 newMutableSizedCornice :: forall s p a c.
-     Cornice p a c 
+     Cornice Headed p a c 
   -> ST s (MutableSizedCornice s p a c)
 newMutableSizedCornice = go where
-  go :: forall p'. Cornice p' a c -> ST s (MutableSizedCornice s p' a c)
+  go :: forall p'. Cornice Headed p' a c -> ST s (MutableSizedCornice s p' a c)
   go (CorniceBase c) = fmap MutableSizedCorniceBase (newMutableSizedColonnade c)
   go (CorniceCap v) = fmap MutableSizedCorniceCap (V.mapM (traverseOneCorniceBody go) v)
     
@@ -390,7 +400,7 @@ mapHeadedness f (Colonnade v) =
 
 
 -- | This is an O(1) operation, sort of
-size :: AnnotatedCornice p a c -> Maybe Int
+size :: AnnotatedCornice sz h p a c -> sz
 size x = case x of
   AnnotatedCorniceBase m _ -> m
   AnnotatedCorniceCap sz _ -> sz
@@ -401,33 +411,32 @@ mapOneCorniceBody f (OneCornice h b) = OneCornice h (f b)
 mapOneColonnadeHeader :: Functor h => (c -> c) -> OneColonnade h a c -> OneColonnade h a c
 mapOneColonnadeHeader f (OneColonnade h b) = OneColonnade (fmap f h) b
 
-headersMonoidal :: forall r m c p a.
+headersMonoidal :: forall sz r m c p a h.
-     Monoid m
+     (Monoid m, Headedness h)
   => Maybe (Fascia p r, r -> m -> m) -- ^ Apply the Fascia header row content
-  -> [(Int -> c -> m, m -> m)] -- ^ Build content from cell content and size
+  -> [(sz -> c -> m, m -> m)] -- ^ Build content from cell content and size
-  -> AnnotatedCornice p a c
+  -> AnnotatedCornice sz h p a c
   -> m
 headersMonoidal wrapRow fromContentList = go wrapRow
   where
-  go :: forall p'. Maybe (Fascia p' r, r -> m -> m) -> AnnotatedCornice p' a c -> m
+  go :: forall p'. Maybe (Fascia p' r, r -> m -> m) -> AnnotatedCornice sz h p' a c -> m
   go ef (AnnotatedCorniceBase _ (Colonnade v)) = 
     let g :: m -> m
         g m = case ef of
           Nothing -> m
           Just (FasciaBase r, f) -> f r m
-     in g $ foldMap (\(fromContent,wrap) -> wrap 
+     in case headednessExtract of
-          (foldMap (\(OneColonnade (Sized sz (Headed h)) _) -> 
+          Just unhead -> g $ foldMap (\(fromContent,wrap) -> wrap 
-            (fromContent sz h)) v)) fromContentList
+            (foldMap (\(OneColonnade (Sized sz h) _) -> 
+              (fromContent sz (unhead h))) v)) fromContentList
+          Nothing -> mempty
   go ef (AnnotatedCorniceCap _ v) = 
     let g :: m -> m
         g m = case ef of
           Nothing -> m
           Just (FasciaCap r _, f) -> f r m
      in g (foldMap (\(fromContent,wrap) -> wrap (foldMap (\(OneCornice h b) -> 
-          (case size b of
+          (fromContent (size b) h)) v)) fromContentList)
-            Nothing -> mempty
-            Just sz -> fromContent sz h)
-          ) v)) fromContentList)
           <> case ef of
                Nothing -> case flattenAnnotated v of
                  Nothing -> mempty
@@ -436,23 +445,33 @@ headersMonoidal wrapRow fromContentList = go wrapRow
                  Nothing -> mempty
                  Just annCoreNext -> go (Just (fn,f)) annCoreNext
 
-flattenAnnotated :: Vector (OneCornice AnnotatedCornice p a c) -> Maybe (AnnotatedCornice p a c)
+flattenAnnotated ::
+     Vector (OneCornice (AnnotatedCornice sz h) p a c)
+  -> Maybe (AnnotatedCornice sz h p a c)
 flattenAnnotated v = case v V.!? 0 of 
   Nothing -> Nothing
   Just (OneCornice _ x) -> Just $ case x of
     AnnotatedCorniceBase m _ -> flattenAnnotatedBase m v
     AnnotatedCorniceCap m _ -> flattenAnnotatedCap m v
 
-flattenAnnotatedBase :: Maybe Int -> Vector (OneCornice AnnotatedCornice Base a c) -> AnnotatedCornice Base a c
+flattenAnnotatedBase ::
+     sz
+  -> Vector (OneCornice (AnnotatedCornice sz h) Base a c)
+  -> AnnotatedCornice sz h Base a c
 flattenAnnotatedBase msz = AnnotatedCorniceBase msz
   . Colonnade 
   . V.concatMap 
     (\(OneCornice _ (AnnotatedCorniceBase _ (Colonnade v))) -> v)
 
-flattenAnnotatedCap :: Maybe Int -> Vector (OneCornice AnnotatedCornice (Cap p) a c) -> AnnotatedCornice (Cap p) a c
+flattenAnnotatedCap ::
+     sz
+  -> Vector (OneCornice (AnnotatedCornice sz h) (Cap p) a c)
+  -> AnnotatedCornice sz h (Cap p) a c
 flattenAnnotatedCap m = AnnotatedCorniceCap m . V.concatMap getTheVector
 
-getTheVector :: OneCornice AnnotatedCornice (Cap p) a c -> Vector (OneCornice AnnotatedCornice p a c)
+getTheVector :: 
+     OneCornice (AnnotatedCornice sz h) (Cap p) a c 
+  -> Vector (OneCornice (AnnotatedCornice sz h) p a c)
 getTheVector (OneCornice _ (AnnotatedCorniceCap _ v)) = v
 
 data MutableSizedCornice s (p :: Pillar) a c where
@@ -480,6 +499,10 @@ data MutableSizedColonnade s h a c = MutableSizedColonnade
 newtype Headed a = Headed { getHeaded :: a }
   deriving (Eq,Ord,Functor,Show,Read,Foldable)
 
+instance Applicative Headed where
+  pure = Headed
+  Headed f <*> Headed a = Headed (f a)
+
 -- | As the first argument to the 'Colonnade' type 
 --   constructor, this indictates that the columnar encoding does not have 
 --   a header. This type is isomorphic to 'Proxy' but is 
@@ -492,8 +515,12 @@ newtype Headed a = Headed { getHeaded :: a }
 data Headless a = Headless
   deriving (Eq,Ord,Functor,Show,Read,Foldable)
 
-data Sized f a = Sized
+instance Applicative Headless where
-  { sizedSize :: {-# UNPACK #-} !Int
+  pure _ = Headless
+  Headless <*> Headless = Headless
+
+data Sized sz f a = Sized
+  { sizedSize :: !sz
   , sizedContent :: !(f a)
   } deriving (Functor, Foldable)
 
@@ -554,7 +581,7 @@ instance Semigroup (Colonnade h a c) where
 data Pillar = Cap !Pillar | Base
 
 class ToEmptyCornice (p :: Pillar) where
-  toEmptyCornice :: Cornice p a c
+  toEmptyCornice :: Cornice h p a c
 
 instance ToEmptyCornice Base where
   toEmptyCornice = CorniceBase mempty
@@ -569,43 +596,96 @@ data Fascia (p :: Pillar) r where
 data OneCornice k (p :: Pillar) a c = OneCornice
   { oneCorniceHead :: !c
   , oneCorniceBody :: !(k p a c)
-  }
+  } deriving (Functor)
 
-data Cornice (p :: Pillar) a c where
+data Cornice h (p :: Pillar) a c where
-  CorniceBase :: !(Colonnade Headed a c) -> Cornice Base a c
+  CorniceBase :: !(Colonnade h a c) -> Cornice h Base a c
-  CorniceCap :: {-# UNPACK #-} !(Vector (OneCornice Cornice p a c)) -> Cornice (Cap p) a c
+  CorniceCap :: {-# UNPACK #-} !(Vector (OneCornice (Cornice h) p a c)) -> Cornice h (Cap p) a c
 
-instance Semigroup (Cornice p a c) where
+instance Functor h => Functor (Cornice h p a) where
+  fmap f x = case x of
+    CorniceBase c -> CorniceBase (fmap f c)
+    CorniceCap c -> CorniceCap (mapVectorCornice f c)
+
+instance Functor h => Profunctor (Cornice h p) where
+  rmap = fmap
+  lmap f x = case x of
+    CorniceBase c -> CorniceBase (lmap f c)
+    CorniceCap c -> CorniceCap (contramapVectorCornice f c)
+
+instance Semigroup (Cornice h p a c) where
   CorniceBase a <> CorniceBase b = CorniceBase (mappend a b)
   CorniceCap a <> CorniceCap b = CorniceCap (a Vector.++ b)
   sconcat xs@(x :| _) = case x of
     CorniceBase _ -> CorniceBase (Colonnade (vectorConcatNE (fmap (getColonnade . getCorniceBase) xs)))
     CorniceCap _ -> CorniceCap (vectorConcatNE (fmap getCorniceCap xs))
 
-instance ToEmptyCornice p => Monoid (Cornice p a c) where
+instance ToEmptyCornice p => Monoid (Cornice h p a c) where
   mempty = toEmptyCornice
   mappend = (Semigroup.<>)
   mconcat xs1 = case xs1 of
     [] -> toEmptyCornice
     x : xs2 -> Semigroup.sconcat (x :| xs2)
 
-getCorniceBase :: Cornice Base a c -> Colonnade Headed a c
+mapVectorCornice :: Functor h => (c -> d) -> Vector (OneCornice (Cornice h) p a c) -> Vector (OneCornice (Cornice h) p a d)
+mapVectorCornice f = V.map (fmap f)
+
+contramapVectorCornice :: Functor h => (b -> a) -> Vector (OneCornice (Cornice h) p a c) -> Vector (OneCornice (Cornice h) p b c)
+contramapVectorCornice f = V.map (lmapOneCornice f)
+
+lmapOneCornice :: Functor h => (b -> a) -> OneCornice (Cornice h) p a c -> OneCornice (Cornice h) p b c
+lmapOneCornice f (OneCornice theHead theBody) = OneCornice theHead (lmap f theBody) 
+
+getCorniceBase :: Cornice h Base a c -> Colonnade h a c
 getCorniceBase (CorniceBase c) = c
 
-getCorniceCap :: Cornice (Cap p) a c -> Vector (OneCornice Cornice p a c)
+getCorniceCap :: Cornice h (Cap p) a c -> Vector (OneCornice (Cornice h) p a c)
 getCorniceCap (CorniceCap c) = c
 
-data AnnotatedCornice (p :: Pillar) a c where
+data AnnotatedCornice sz h (p :: Pillar) a c where
-  AnnotatedCorniceBase :: !(Maybe Int) -> !(Colonnade (Sized Headed) a c) -> AnnotatedCornice Base a c
+  AnnotatedCorniceBase ::
+       !sz
+    -> !(Colonnade (Sized sz h) a c)
+    -> AnnotatedCornice sz h Base a c
   AnnotatedCorniceCap :: 
-       !(Maybe Int)
+       !sz
-    -> {-# UNPACK #-} !(Vector (OneCornice AnnotatedCornice p a c))
+    -> {-# UNPACK #-} !(Vector (OneCornice (AnnotatedCornice sz h) p a c))
-    -> AnnotatedCornice (Cap p) a c
+    -> AnnotatedCornice sz h (Cap p) a c
 
 -- data MaybeInt = JustInt {-# UNPACK #-} !Int | NothingInt
 
--- | This is provided with vector-0.12, but we include a copy here 
+-- | This is provided with @vector-0.12@, but we include a copy here 
 --   for compatibility.
 vectorConcatNE :: NonEmpty (Vector a) -> Vector a
 vectorConcatNE = Vector.concat . toList
 
+-- | This class communicates that a container holds either zero
+--   elements or one element. Furthermore, all inhabitants of
+--   the type must hold the same number of elements. Both
+--   'Headed' and 'Headless' have instances. The following
+--   law accompanies any instances:
+--
+--   > maybe x (\f -> f (headednessPure x)) headednessContents == x
+--   > todo: come up with another law that relates to Traversable
+--
+--   Consequently, there is no instance for 'Maybe', which cannot
+--   satisfy the laws since it has inhabitants which hold different
+--   numbers of elements. 'Nothing' holds 0 elements and 'Just' holds
+--   1 element.
+class Headedness h where
+  headednessPure :: a -> h a
+  headednessExtract :: Maybe (h a -> a)
+  headednessExtractForall :: Maybe (ExtractForall h)
+
+instance Headedness Headed where
+  headednessPure = Headed
+  headednessExtract = Just getHeaded 
+  headednessExtractForall = Just (ExtractForall getHeaded)
+
+instance Headedness Headless where
+  headednessPure _ = Headless
+  headednessExtract = Nothing
+  headednessExtractForall = Nothing
+
+newtype ExtractForall h = ExtractForall { runExtractForall :: forall a. h a -> a }
+

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,29 @@
+name: lucid-colonnade
+version: 1.0.1
+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.8 && < 5
+    , 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
+  type:     git
+  location: https://github.com/andrewthad/colonnade

lucid-colonnade/src/Lucid/Colonnade.hs

@@ -0,0 +1,292 @@
+{-# 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,
+--   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
+  , encodeCellTableSized
+  , encodeTable
+    -- * Cell
+    -- $build
+  , Cell(..)
+  , htmlCell
+  , stringCell
+  , textCell
+  , lazyTextCell
+  , builderCell
+  , htmlFromCell
+  , encodeBodySized
+  , sectioned
+    -- * Discussion
+    -- $discussion
+  ) where
+
+import Colonnade (Colonnade,Headed,Headless,Fascia,Cornice)
+import Data.Text (Text)
+import Control.Monad
+import Data.Semigroup
+import Data.Monoid hiding ((<>))
+import Data.Foldable
+import Data.String (IsString(..))
+import Data.Maybe (listToMaybe)
+import Data.Char (isSpace)
+import Control.Applicative (liftA2)
+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
+--
+-- 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 Semigroup d => Semigroup (Cell d) where
+  Cell a1 c1 <> Cell a2 c2 = Cell (mappend a1 a2) (liftA2 (<>) c1 c2)
+
+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
+
+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.
+--   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
+
+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
+  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.
+
+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
+

nix/default.nix

@@ -1,47 +1,73 @@
-{ package, test ? true, frontend ? false }:
+{ frontend ? false }:
-let bootstrap = import <nixpkgs> {};
+
+let _nixpkgs = import <nixpkgs> {};
+    nixpkgs = _nixpkgs.fetchFromGitHub {
+      owner = "NixOS";
+      repo = "nixpkgs";
+      rev = "5c4a404b0d0e5125070dde5c1787210149157e83";
+      sha256 = "0a478l0dxzy5hglavkilxjkh45zfg31q50hgkv1npninc4lpv5f7";
+    };
+    pkgs = import nixpkgs { config = {}; overlays = []; };
+
     fetch-github-json = owner: repo: path:
       let commit = builtins.fromJSON (builtins.readFile path);
-      in bootstrap.fetchFromGitHub {
+      in pkgs.fetchFromGitHub {
-            inherit owner repo;
+        name = "${repo}-${commit.rev}";
-            inherit (commit) rev sha256;
+        inherit owner repo;
+        inherit (commit) rev sha256;
       };
-    reflex-platform = import (fetch-github-json "reflex-frp" "reflex-platform" ./reflex-platform.json) {};
+      
-    compiler = if frontend then "ghcjs" else "ghc";
+    reflex-platform = import (fetch-github-json "layer-3-communications" "reflex-platform" ./reflex-platform.json) {};
-    overrides = (builtins.getAttr compiler reflex-platform).override {
+    jsaddle-src = fetch-github-json "ghcjs" "jsaddle" ./jsaddle.json;
+    compiler = "ghc8_2_1";
+
+    filterPredicate = p: type:
+      let path = baseNameOf p; in !(
+           (type == "directory" && pkgs.lib.hasPrefix "dist" path)
+        || (type == "symlink"   && pkgs.lib.hasPrefix "result" path)
+        || pkgs.lib.hasPrefix ".ghc" path
+        || pkgs.lib.hasPrefix ".git" path
+        || pkgs.lib.hasSuffix "~" path
+        || pkgs.lib.hasSuffix ".o" path
+        || pkgs.lib.hasSuffix ".so" path
+        || pkgs.lib.hasSuffix ".nix" path);
+
+    overrides = reflex-platform.${compiler}.override {
       overrides = self: super:
         with reflex-platform;
-        let options = pkg: lib.overrideCabal pkg (drv: { doCheck = test; });
+        with reflex-platform.lib;
-            filterPredicate = p: type:
+        with reflex-platform.nixpkgs.haskell.lib;
-              let path = baseNameOf p; in
+        with reflex-platform.nixpkgs.haskellPackages; 
-              !builtins.any (x: x)
+        let
-              [(type == "directory" && path == "dist")
+          cp              = file: (self.callPackage (./deps + "/${file}.nix") {});
-               (type == "symlink"   && path == "result")
+          build-from-json = name: str: self.callCabal2nix name str {};
-               (type == "directory" && path == ".git")];
+          build           = name: path: self.callCabal2nix name (builtins.filterSource filterPredicate path) {};
-        in {
+        in
-          mkDerivation = args: super.mkDerivation (args //
+        {
-            (if nixpkgs.stdenv.isDarwin && !frontend then {
+          gtk2hs-buildtools = self.callPackage ./gtk2hs-buildtools.nix {};
-              postCompileBuildDriver = ''
+          colonnade = build "colonnade" ../colonnade;
-                echo "Patching dynamic library dependencies"
+          siphon    = build "siphon" ../siphon;
-                # 1. Link all dylibs from 'dynamic-library-dirs's in package confs to $out/lib/links
+          reflex-dom-colonnade = build "reflex-dom-colonnade" ../reflex-dom-colonnade;
-                mkdir -p $out/lib/links
+          lucid-colonnade = build "lucid-colonnade" ../lucid-colonnade;
-                for d in $(grep dynamic-library-dirs $packageConfDir/*|awk '{print $2}'); do
+          blaze-colonnade = build "blaze-colonnade" ../blaze-colonnade;
-                  ln -s $d/*.dylib $out/lib/links
+          yesod-colonnade = build "yesod-colonnade" ../yesod-colonnade;
-                done
+        } //
+        {
+          jsaddle              = doJailbreak (build-from-json "jsaddle"            "${jsaddle-src}/jsaddle");
+          jsaddle-webkitgtk    = doJailbreak (build-from-json "jsaddle-webkitgtk"  "${jsaddle-src}/jsaddle-webkitgtk");
+          jsaddle-webkit2gtk   = doJailbreak (build-from-json "jsaddle-webkit2gtk" "${jsaddle-src}/jsaddle-webkit2gtk");
+          jsaddle-wkwebview    = doJailbreak (build-from-json "jsaddle-wkwebview"  "${jsaddle-src}/jsaddle-wkwebview");
+          jsaddle-clib         = doJailbreak (build-from-json "jsaddle-clib"       "${jsaddle-src}/jsaddle-clib");
+          jsaddle-warp         = dontCheck (doJailbreak (build-from-json "jsaddle-warp"       "${jsaddle-src}/jsaddle-warp"));
+        };
 
-                # 2. Patch 'dynamic-library-dirs' in package confs to point to the symlink dir
-                for f in $packageConfDir/*.conf; do
-                  sed -i "s,dynamic-library-dirs: .*,dynamic-library-dirs: $out/lib/links," $f
-                done
-
-                # 3. Recache package database
-                ghc-pkg --package-db="$packageConfDir" recache
-              '';
-            } else {}));
-        } // import ./overrides.nix { inherit options filterPredicate lib cabal2nixResult self super; };
     };
-    drv = builtins.getAttr package overrides;
+in rec {
-in if reflex-platform.nixpkgs.lib.inNixShell then
+  inherit reflex-platform fetch-github-json overrides nixpkgs pkgs;
-  reflex-platform.workOn overrides drv
+  colonnade = overrides.colonnade;
-else
+  siphon    = overrides.siphon;
-  drv
+  reflex-dom-colonnade = overrides.reflex-dom-colonnade;
+  lucid-colonnade = overrides.lucid-colonnade;
+  blaze-colonnade = overrides.blaze-colonnade;
+  yesod-colonnade = overrides.yesod-colonnade;
+}

nix/gtk2hs-buildtools.nix

@@ -0,0 +1,20 @@
+{ mkDerivation, alex, array, base, Cabal, containers, directory
+, filepath, happy, hashtables, pretty, process, random, stdenv
+}:
+mkDerivation {
+  pname = "gtk2hs-buildtools";
+  version = "0.13.4.0";
+  sha256 = "0f3e6ba90839efd43efe8cecbddb6478a55e2ce7788c57a0add4df477dede679";
+  isLibrary = true;
+  isExecutable = true;
+  enableSeparateDataOutput = true;
+  libraryHaskellDepends = [
+    array base Cabal containers directory filepath hashtables pretty
+    process random
+  ];
+  libraryToolDepends = [ alex happy ];
+  executableHaskellDepends = [ base ];
+  homepage = "http://projects.haskell.org/gtk2hs/";
+  description = "Tools to build the Gtk2Hs suite of User Interface libraries";
+  license = stdenv.lib.licenses.gpl2;
+}

nix/jsaddle.json

@@ -0,0 +1,6 @@
+{
+  "owner": "ghcjs",
+  "repo": "jsaddle",
+  "rev": "b423436565fce7f69a65d843c71fc52dc455bf54",
+  "sha256": "09plndkh5wnbqi34x3jpaz0kjdjgyf074faf5xk97rsm81vhz8kk"
+}

nix/reflex-platform.json

@@ -1,7 +1,7 @@
 {
   "url": "https://github.com/reflex-frp/reflex-platform",
-  "rev": "a16213b82f05808ad96b81939850a32ecedd18eb",
+  "rev": "0446e9df3adfc7271015c278a2ec5b7e7a6a46f3",
   "date": "2017-05-05T11:40:26-04:00",
-  "sha256": "0dfm8pcpk2zpkfrc9gxh79pkk4ac8ljfm5nqv0sksd64qlhhpj4f",
+  "sha256": "0v0d53xqrmh0i01iiq1flq66gw3cb6g9894j94cflsavmhih8y1d",
   "fetchSubmodules": true
 }

projects/cabal-8.0.2.project

@@ -0,0 +1,4 @@
+packages: ./colonnade
+          ./blaze-colonnade
+          ./lucid-colonnade
+          ./yesod-colonnade

projects/cabal-8.2.2.project

@@ -0,0 +1,4 @@
+packages: ./colonnade
+          ./blaze-colonnade
+          ./lucid-colonnade
+          ./yesod-colonnade

projects/cabal-8.4.3.project

@@ -0,0 +1,3 @@
+packages: ./colonnade
+          ./blaze-colonnade
+          ./lucid-colonnade

reflex-dom-colonnade/default.nix

@@ -1,5 +1,8 @@
-{ test ? "true" }:
+{ frontend ? false }:
-let parseBool = str: with builtins;
+let
-  let json = fromJSON str; in if isBool json then json else throw "nix parseBool: ${str} is not a bool.";
+  pname = "reflex-dom-colonnade"; 
+  main = (import ../nix/default.nix {
+    inherit frontend;
+  });
 in
-import ../nix/default.nix { package = "reflex-dom-colonnade"; frontend = false; test = parseBool test; }
+  main.${pname}

reflex-dom-colonnade/reflex-dom-colonnade.cabal

@@ -1,30 +1,32 @@
-name:                reflex-dom-colonnade
+name: reflex-dom-colonnade
-version:             0.5.0
+version: 0.6.0
-synopsis:            Use colonnade with reflex-dom
+synopsis: Use colonnade with reflex-dom
-description:         Please see README.md
+description: Please see README.md
-homepage:            https://github.com/andrewthad/colonnade#readme
+homepage: https://github.com/andrewthad/colonnade#readme
-license:             BSD3
+license: BSD3
-license-file:        LICENSE
+license-file: LICENSE
-author:              Andrew Martin
+author: Andrew Martin
-maintainer:          andrew.thaddeus@gmail.com
+maintainer: andrew.thaddeus@gmail.com
-copyright:           2016 Andrew Martin
+copyright: 2016 Andrew Martin
-category:            web
+category: web
-build-type:          Simple
+build-type: Simple
-cabal-version:       >=1.10
+cabal-version: >=1.10
 
 library
   hs-source-dirs:      src
   exposed-modules:
     Reflex.Dom.Colonnade
   build-depends:
-      base >= 4.7 && < 5.0
+      base >= 4.9 && < 5.0
-    , colonnade >= 1.1 && < 1.2
+    , colonnade >= 1.2 && < 1.3
     , contravariant >= 1.2 && < 1.5
-    , vector >= 0.10 && < 0.12
+    , vector >= 0.10 && < 0.13
     , text >= 1.0 && < 1.3
     , reflex == 0.5.*
     , reflex-dom == 0.4.*
     , containers >= 0.5 && < 0.6
+    , profunctors >= 5.2 && < 5.3
+    , transformers >= 0.5 && < 0.6
   default-language: Haskell2010
 
 source-repository head

reflex-dom-colonnade/shell.nix

@@ -0,0 +1 @@
+(import ./. {}).env

siphon/siphon.cabal

@@ -1,5 +1,5 @@
 name: siphon
-version: 0.7
+version: 0.8.1.1
 synopsis: Encode and decode CSV files
 description: Please see README.md
 homepage: https://github.com/andrewthad/colonnade#readme
@@ -13,22 +13,33 @@ build-type: Simple
 cabal-version: >=1.10
 
 library
-  hs-source-dirs:      src
+  hs-source-dirs: src
   exposed-modules:
     Siphon
     Siphon.Types
   build-depends:
-      base >= 4.9 && < 5
+      base >= 4.8 && < 5
-    , colonnade >= 1.1 && < 1.2
+    , colonnade >= 1.2 && < 1.3
-    , text
+    , text >= 1.0 && < 1.3
     , bytestring
     , vector
-    , streaming
+    , streaming >= 0.1.4 && < 0.3
     , attoparsec
-    , transformers
+    , transformers >= 0.4.2 && < 0.6
-  default-language:    Haskell2010
+    , semigroups >= 0.18.2 && < 0.20
+  default-language: Haskell2010
 
-test-suite siphon-test
+test-suite doctest
+  type: exitcode-stdio-1.0
+  hs-source-dirs: test
+  main-is: Doctest.hs
+  build-depends:
+      base
+    , siphon
+    , doctest >= 0.10
+  default-language: Haskell2010
+
+test-suite test
   type: exitcode-stdio-1.0
   hs-source-dirs: test
   main-is: Test.hs

siphon/src/Siphon.hs

@@ -3,18 +3,33 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE RankNTypes #-}
 
--- {-# OPTIONS_GHC -Wall -Werr -fno-warn-unused-imports #-}
+{-# OPTIONS_GHC -Wall -fno-warn-unused-imports #-}
 
+-- | 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 a common set of
+--   imports that are provided at the bottom of this page.
 module Siphon
-  ( Siphon
+  ( -- * Encode CSV
-  , SiphonError
+    encodeCsv
-  , Indexed(..)
+  , encodeCsvStream
-  , decodeHeadedUtf8Csv
+  , encodeCsvUtf8
-  , encodeHeadedUtf8Csv
+  , encodeCsvStreamUtf8
-  , humanizeSiphonError
+    -- * Decode CSV
+  , decodeCsvUtf8
+    -- * Build Siphon
   , headed
   , headless
   , indexed
+    -- * Types
+  , Siphon
+  , SiphonError(..)
+  , Indexed(..)
+    -- * Utility
+  , humanizeSiphonError
+    -- * Imports
+    -- $setup
   ) where
 
 import Siphon.Types
@@ -32,6 +47,8 @@ import qualified Data.Vector as V
 import qualified Data.ByteString as B
 import qualified Data.ByteString.Lazy as LByteString
 import qualified Data.ByteString.Builder as Builder
+import qualified Data.Text.Lazy as LT
+import qualified Data.Text.Lazy.Builder as TB
 import qualified Data.Text as T
 import qualified Data.List as L
 import qualified Streaming as SM
@@ -39,9 +56,11 @@ import qualified Streaming.Prelude as SMP
 import qualified Data.Attoparsec.Types as ATYP
 import qualified Colonnade.Encode as CE
 import qualified Data.Vector.Mutable as MV
-
+import qualified Data.ByteString.Builder as BB
+import qualified Data.Semigroup as SG
 
 import Control.Monad.Trans.Class
+import Data.Functor.Identity (Identity(..))
 import Data.ByteString.Builder (toLazyByteString,byteString)
 import Data.Attoparsec.ByteString.Char8 (char, endOfInput, string)
 import Data.Word (Word8)
@@ -53,18 +72,20 @@ import Data.Text.Encoding (decodeUtf8')
 import Streaming (Stream,Of(..))
 import Data.Vector.Mutable (MVector)
 import Control.Monad.ST
+import Data.Text (Text)
+import Data.Semigroup (Semigroup)
 
 newtype Escaped c = Escaped { getEscaped :: c }
 data Ended = EndedYes | EndedNo
   deriving (Show)
-data CellResult c = CellResultData !c | CellResultNewline !Ended
+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)
@@ -74,40 +95,107 @@ decodeHeadedUtf8Csv headedSiphon s1 = do
         let requiredLength = V.length v
         consumeBodyUtf8 1 requiredLength ixedSiphon s2
 
-encodeHeadedUtf8Csv :: Monad m 
+encodeCsvStreamUtf8 :: (Monad m, CE.Headedness h)
-  => CE.Colonnade CE.Headed a ByteString
+  => CE.Colonnade h a ByteString
   -> Stream (Of a) m r
   -> Stream (Of ByteString) m r
-encodeHeadedUtf8Csv =
+encodeCsvStreamUtf8 =
-  encodeHeadedCsv escapeChar8 (B.singleton comma) (B.singleton newline)
+  encodeCsvInternal escapeChar8 (B.singleton comma) (B.singleton newline)
 
-encodeHeadedCsv :: Monad m
+-- | Streaming variant of 'encodeCsv'. This is particularly useful
+--   when you need to produce millions of rows without having them
+--   all loaded into memory at the same time.
+encodeCsvStream :: (Monad m, CE.Headedness h)
+  => CE.Colonnade h a Text
+  -> Stream (Of a) m r
+  -> Stream (Of Text) m r
+encodeCsvStream =
+  encodeCsvInternal textEscapeChar8 (T.singleton ',') (T.singleton '\n')
+
+-- | Encode a collection to a CSV as a text 'TB.Builder'. For example,
+--   we can take the following columnar encoding of a person:
+--
+-- >>> :{
+-- let colPerson :: Colonnade Headed Person Text
+--     colPerson = mconcat
+--       [ C.headed "Name" name
+--       , C.headed "Age" (T.pack . show . age)
+--       , C.headed "Company" (fromMaybe "N/A" . company)
+--       ]
+-- :}
+--
+-- And we have the following people whom we wish to encode
+-- in this way:
+--
+-- >>> :{
+-- let people :: [Person]
+--     people =
+--       [ Person "Chao" 26 (Just "Tectonic, Inc.")
+--       , Person "Elsie" 41 (Just "Globex Corporation")
+--       , Person "Arabella" 19 Nothing
+--       ]
+-- :}
+--
+-- We pair the encoding with the rows to get a CSV:
+--
+-- >>> LTIO.putStr (TB.toLazyText (encodeCsv colPerson people))
+-- Name,Age,Company
+-- Chao,26,"Tectonic, Inc."
+-- Elsie,41,Globex Corporation
+-- Arabella,19,N/A
+encodeCsv :: (Foldable f, CE.Headedness h)
+  => CE.Colonnade h a Text -- ^ Tablular encoding
+  -> f a -- ^ Value of each row
+  -> TB.Builder
+encodeCsv enc = 
+  textStreamToBuilder . encodeCsvStream enc . SMP.each
+
+-- | Encode a collection to a CSV as a bytestring 'BB.Builder'.
+encodeCsvUtf8 :: (Foldable f, CE.Headedness h)
+  => CE.Colonnade h a ByteString -- ^ Tablular encoding
+  -> f a -- ^ Value of each row
+  -> BB.Builder
+encodeCsvUtf8 enc =
+  streamToBuilder . encodeCsvStreamUtf8 enc . SMP.each
+
+streamToBuilder :: Stream (Of ByteString) Identity () -> BB.Builder
+streamToBuilder s = SM.destroy s
+  (\(bs :> bb) -> BB.byteString bs <> bb) runIdentity (\() -> mempty)
+
+textStreamToBuilder :: Stream (Of Text) Identity () -> TB.Builder
+textStreamToBuilder s = SM.destroy s
+  (\(bs :> bb) -> TB.fromText bs <> bb) runIdentity (\() -> mempty)
+
+encodeCsvInternal :: (Monad m, CE.Headedness h)
   => (c -> Escaped c)
   -> c -- ^ separator
   -> c -- ^ newline
-  -> CE.Colonnade CE.Headed a c
+  -> CE.Colonnade h a c
   -> Stream (Of a) m r
   -> Stream (Of c) m r
-encodeHeadedCsv escapeFunc separatorStr newlineStr colonnade s = do
+encodeCsvInternal escapeFunc separatorStr newlineStr colonnade s = do
-  encodeHeader escapeFunc separatorStr newlineStr colonnade
+  case CE.headednessExtract of
+    Just toContent -> encodeHeader toContent escapeFunc separatorStr newlineStr colonnade
+    Nothing -> return ()
   encodeRows escapeFunc separatorStr newlineStr colonnade s
 
 encodeHeader :: Monad m
-  => (c -> Escaped c)
+  => (h c -> c)
+  -> (c -> Escaped c)
   -> c -- ^ separator
   -> c -- ^ newline
-  -> CE.Colonnade CE.Headed a c
+  -> CE.Colonnade h a c
   -> Stream (Of c) m ()
-encodeHeader escapeFunc separatorStr newlineStr colonnade = do
+encodeHeader toContent escapeFunc separatorStr newlineStr colonnade = do
   let (vs,ws) = V.splitAt 1 (CE.getColonnade colonnade)
   -- we only need to do this split because the first cell
   -- gets treated differently than the others. It does not
   -- get a separator added before it.
-  V.forM_ vs $ \(CE.OneColonnade (CE.Headed h) _) -> do
+  V.forM_ vs $ \(CE.OneColonnade h _) -> do
-    SMP.yield (getEscaped (escapeFunc h))
+    SMP.yield (getEscaped (escapeFunc (toContent h)))
-  V.forM_ ws $ \(CE.OneColonnade (CE.Headed h) _) -> do
+  V.forM_ ws $ \(CE.OneColonnade h _) -> do
     SMP.yield separatorStr
-    SMP.yield (getEscaped (escapeFunc h))
+    SMP.yield (getEscaped (escapeFunc (toContent h)))
   SMP.yield newlineStr
 
 mapStreamM :: Monad m
@@ -172,10 +260,13 @@ headedToIndexed toStr v =
 
 data HeaderErrors = HeaderErrors !(Vector (Vector CellError)) !(Vector T.Text) !(Vector Int)
 
+instance Semigroup HeaderErrors where
+  HeaderErrors a1 b1 c1 <> HeaderErrors a2 b2 c2 = HeaderErrors
+    (mappend a1 a2) (mappend b1 b2) (mappend c1 c2)
+
 instance Monoid HeaderErrors where
   mempty = HeaderErrors mempty mempty mempty
-  mappend (HeaderErrors a1 b1 c1) (HeaderErrors a2 b2 c2) = HeaderErrors
+  mappend = (SG.<>)
-    (mappend a1 a2) (mappend b1 b2) (mappend c1 c2)
 
 -- byteStringChar8 :: Siphon ByteString
 -- byteStringChar8 = Siphon
@@ -189,7 +280,12 @@ escapeChar8 t = case B.find (\c -> c == newline || c == cr || c == comma || c ==
   Nothing -> Escaped t
   Just _  -> escapeAlways t
 
--- | This implementation is definitely suboptimal.
+textEscapeChar8 :: Text -> Escaped Text
+textEscapeChar8 t = case T.find (\c -> c == '\n' || c == '\r' || c == ',' || c == '"') t of
+  Nothing -> Escaped t
+  Just _  -> textEscapeAlways t
+
+-- This implementation is definitely suboptimal.
 -- A better option (which would waste a little space
 -- but would be much faster) would be to build the
 -- new bytestring by writing to a buffer directly.
@@ -205,25 +301,25 @@ escapeAlways t = Escaped $ LByteString.toStrict $ Builder.toLazyByteString $
       t
   <> Builder.word8 doubleQuote
 
--- | Specialized version of 'sepBy1'' which is faster due to not
+-- Suboptimal for similar reason as escapeAlways.
--- accepting an arbitrary separator.
+textEscapeAlways :: Text -> Escaped Text
-sepByDelim1' :: AL.Parser a
+textEscapeAlways t = Escaped $ LT.toStrict $ TB.toLazyText $
-             -> Word8  -- ^ Field delimiter
+     TB.singleton '"'
-             -> AL.Parser [a]
+  <> T.foldl
-sepByDelim1' p !delim = liftM2' (:) p loop
+      (\ acc b -> acc <> if b == '"'
-  where
+          then TB.fromString "\"\""
-    loop = do
+          else TB.singleton b
-        mb <- A.peekWord8
+      )
-        case mb of
+      mempty
-            Just b | b == delim -> liftM2' (:) (A.anyWord8 *> p) loop
+      t
-            _                   -> pure []
+  <> TB.singleton '"'
-{-# INLINE sepByDelim1' #-}
 
--- | Parse a record, not including the terminating line separator. The
+-- Parse a record, not including the terminating line separator. The
 -- terminating line separate is not included as the last record in a
 -- CSV file is allowed to not have a terminating line separator. You
 -- most likely want to use the 'endOfLine' parser in combination with
 -- this parser.
+--
 -- row :: Word8  -- ^ Field delimiter
 --     -> AL.Parser (Vector ByteString)
 -- row !delim = rowNoNewline delim <* endOfLine
@@ -237,6 +333,7 @@ sepByDelim1' p !delim = liftM2' (:) p loop
 -- removeBlankLines :: [Vector ByteString] -> [Vector ByteString]
 -- removeBlankLines = filter (not . blankLine)
 
+
 -- | Parse a field. The field may be in either the escaped or
 --   non-escaped format. The return value is unescaped. This
 --   parser will consume the comma that comes after a field
@@ -251,49 +348,73 @@ field !delim = do
   case mb of
     Just b
       | b == doubleQuote -> do
-          bs <- escapedField delim
+          (bs,tc) <- escapedField
-          return (CellResultData bs)
+          case tc of
+            TrailCharComma -> return (CellResultData bs)
+            TrailCharNewline -> return (CellResultNewline bs EndedNo)
+            TrailCharEnd -> return (CellResultNewline bs EndedYes)
       | b == 10 || b == 13 -> do
           _ <- eatNewlines
           isEnd <- A.atEnd
           if isEnd
-            then return (CellResultNewline EndedYes)
+            then return (CellResultNewline B.empty EndedYes)
-            else return (CellResultNewline EndedNo)
+            else return (CellResultNewline B.empty EndedNo)
       | otherwise -> do
-          bs <- unescapedField delim
+          (bs,tc) <- unescapedField delim
-          return (CellResultData bs)
+          case tc of
-    Nothing -> return (CellResultNewline EndedYes)
+            TrailCharComma -> return (CellResultData bs)
+            TrailCharNewline -> return (CellResultNewline bs EndedNo)
+            TrailCharEnd -> return (CellResultNewline bs EndedYes)
+    Nothing -> return (CellResultNewline B.empty EndedYes)
 {-# INLINE field #-}
 
 eatNewlines :: AL.Parser S.ByteString
 eatNewlines = A.takeWhile (\x -> x == 10 || x == 13)
 
-escapedField :: Word8 -> AL.Parser S.ByteString
+escapedField :: AL.Parser (S.ByteString,TrailChar)
-escapedField !delim = do
+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.
-  s <- S.init <$> (A.scan False $ \s c -> if c == doubleQuote
+  s <- S.init <$>
-                                          then Just (not s)
+    ( A.scan False $ \s c ->
-                                          else if s then Nothing
+      if c == doubleQuote
-                                               else Just False)
+        then Just (not s)
-  A.option () (A.skip (== delim))
+        else if s
+          then Nothing
+          else Just False
+    )
+  mb <- A.peekWord8
+  trailChar <- case mb of
+    Just b
+      | b == comma -> A.anyWord8 >> return TrailCharComma
+      | b == newline || b == cr -> A.anyWord8 >> return TrailCharNewline
+      | otherwise -> fail "encountered double quote after escaped field"
+    Nothing -> return TrailCharEnd
   if doubleQuote `S.elem` s
-      then case Z.parse unescape s of
+    then case Z.parse unescape s of
-          Right r  -> return r
+      Right r  -> return (r,trailChar)
-          Left err -> fail err
+      Left err -> fail err
-      else return s
+    else return (s,trailChar)
+
+data TrailChar = TrailCharNewline | TrailCharComma | TrailCharEnd
 
 -- | Consume an unescaped field. If it ends with a newline,
 --   leave that in tact. If it ends with a comma, consume the comma.
-unescapedField :: Word8 -> AL.Parser S.ByteString
+unescapedField :: Word8 -> AL.Parser (S.ByteString,TrailChar)
-unescapedField !delim = 
+unescapedField !delim = do
-  ( A.takeWhile $ \c -> 
+  bs <- A.takeWhile $ \c -> 
     c /= doubleQuote &&
     c /= newline &&
     c /= delim &&
     c /= cr
-  ) <* A.option () (A.skip (== delim))
+  mb <- A.peekWord8
+  case mb of
+    Just b
+      | b == comma -> A.anyWord8 >> return (bs,TrailCharComma)
+      | b == newline || b == cr -> A.anyWord8 >> return (bs,TrailCharNewline)
+      | otherwise -> fail "encountered double quote in unescaped field"
+    Nothing -> return (bs,TrailCharEnd)
 
 dquote :: AL.Parser Char
 dquote = char '"'
@@ -319,23 +440,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' #-}
-
-
--- | Match either a single newline character @\'\\n\'@, or a carriage
--- return followed by a newline character @\"\\r\\n\"@, or a single
--- carriage return @\'\\r\'@.
-endOfLine :: A.Parser ()
-endOfLine = (A.word8 newline *> return ()) <|> (string (BC8.pack "\r\n") *> return ()) <|> (A.word8 cr *> return ())
-{-# INLINE endOfLine #-}
-
 doubleQuote, newline, cr, comma :: Word8
 doubleQuote = 34
 newline = 10
@@ -434,7 +538,7 @@ mapLeft f (Left a) = Left (f a)
 consumeHeaderRowUtf8 :: Monad m
   => Stream (Of ByteString) m ()
   -> m (Either SiphonError (Of (Vector ByteString) (Stream (Of ByteString) m ())))
-consumeHeaderRowUtf8 = consumeHeaderRow utf8ToStr (A.parse (field comma)) B.null B.empty (\() -> True)
+consumeHeaderRowUtf8 = consumeHeaderRow (A.parse (field comma)) B.null B.empty (\() -> True)
 
 consumeBodyUtf8 :: forall m a. Monad m
   => Int -- ^ index of first row, usually zero or one
@@ -449,14 +553,13 @@ utf8ToStr :: ByteString -> T.Text
 utf8ToStr = either (\_ -> T.empty) id . decodeUtf8'
 
 consumeHeaderRow :: forall m r c. Monad m
-  => (c -> T.Text)
+  => (c -> ATYP.IResult c (CellResult c))
-  -> (c -> ATYP.IResult c (CellResult c))
   -> (c -> Bool) -- ^ true if null string
   -> c
   -> (r -> Bool) -- ^ true if termination is acceptable
   -> Stream (Of c) m r
   -> m (Either SiphonError (Of (Vector c) (Stream (Of c) m r)))
-consumeHeaderRow toStr parseCell isNull emptyStr isGood s0 = go 0 StrictListNil s0
+consumeHeaderRow parseCell isNull emptyStr isGood s0 = go 0 StrictListNil s0
   where
   go :: Int
      -> StrictList c
@@ -477,8 +580,8 @@ consumeHeaderRow toStr parseCell isNull emptyStr isGood s0 = go 0 StrictListNil
     ATYP.Fail _ _ _ -> return $ Left $ SiphonError 0 RowErrorParse
     ATYP.Done !c1 !res -> case res of
       -- it might be wrong to ignore whether or not the stream has ended
-      CellResultNewline _ -> do
+      CellResultNewline cd _ -> do
-        let v = reverseVectorStrictList cellsLen cells
+        let v = reverseVectorStrictList (cellsLen + 1) (StrictListCons cd cells)
         return (Right (v :> (SMP.yield c1 >> s1)))
       CellResultData !cd -> if isNull c1
         then go (cellsLen + 1) (StrictListCons cd cells) s1
@@ -518,8 +621,8 @@ consumeBody toStr parseCell isNull emptyStr isGood row0 reqLen siphon s0 =
   handleResult !row !cellsLen !cells !result s1 = case result of
     ATYP.Fail _ _ _ -> return $ Just $ SiphonError row RowErrorParse
     ATYP.Done !c1 !res -> case res of
-      CellResultNewline !ended -> do
+      CellResultNewline !cd !ended -> do
-        case decodeRow row (reverseVectorStrictList cellsLen cells) of
+        case decodeRow row (reverseVectorStrictList (cellsLen + 1) (StrictListCons cd cells)) of
           Left err -> return (Just err)
           Right a -> do
             SMP.yield a
@@ -633,12 +736,34 @@ maxIndex = go 0 where
   go !ix1 (SiphonAp (IndexedHeader ix2 _) _ apNext) =
     go (max ix1 ix2) apNext
 
+-- | Uses the argument to parse a CSV column.
 headless :: (c -> Maybe a) -> Siphon CE.Headless c a
 headless f = SiphonAp CE.Headless f (SiphonPure id)
 
+-- | Uses the second argument to parse a CSV column whose 
+--   header content matches the first column exactly.
 headed :: c -> (c -> Maybe a) -> Siphon CE.Headed c a
 headed h f = SiphonAp (CE.Headed h) f (SiphonPure id)
 
+-- | Uses the second argument to parse a CSV column that
+--   is positioned at the index given by the first argument.
 indexed :: Int -> (c -> Maybe a) -> Siphon Indexed c a
 indexed ix f = SiphonAp (Indexed ix) f (SiphonPure id)
 
+-- $setup
+--
+-- This code is copied from the head section. It has to be
+-- run before every set of tests.
+--
+-- >>> :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 Data.Text (Text)
+-- >>> import qualified Data.Text.Lazy.IO as LTIO
+-- >>> import qualified Data.Text.Lazy.Builder as LB
+-- >>> import Data.Maybe (fromMaybe)
+-- >>> data Person = Person { name :: Text, age :: Int, company :: Maybe Text}
+

siphon/test/Doctest.hs

@@ -0,0 +1,8 @@
+import Test.DocTest
+
+main :: IO ()
+main = doctest
+  [ "-isrc"
+  , "src/Siphon.hs"
+  ]
+

siphon/test/Test.hs

@@ -23,12 +23,15 @@ import Data.Profunctor (lmap)
 import Streaming (Stream,Of(..))
 import Control.Exception
 import Debug.Trace
-import qualified Data.Text                  as Text
+import Data.Word (Word8)
-import qualified Data.ByteString.Builder    as Builder
+import Data.Char (ord)
-import qualified Data.ByteString.Lazy       as LByteString
+import qualified Data.Text as Text
-import qualified Data.ByteString            as ByteString
+import qualified Data.ByteString.Builder as Builder
-import qualified Data.ByteString.Char8      as BC8
+import qualified Data.ByteString.Lazy as LByteString
-import qualified Colonnade                  as Colonnade
+import qualified Data.ByteString as ByteString
+import qualified Data.ByteString.Char8 as BC8
+import qualified Data.ByteString as B
+import qualified Colonnade as Colonnade
 import qualified Siphon as S
 import qualified Streaming.Prelude as SMP
 import qualified Data.Text.Lazy as LText
@@ -42,8 +45,8 @@ tests :: [Test]
 tests =
   [ testGroup "ByteString encode/decode"
     [ testCase "Headed Encoding (int,char,bool)"
-        $ runTestScenario [(4,'c',False)]
+        $ runTestScenario [(4,intToWord8 (ord 'c'),False)]
-            S.encodeHeadedUtf8Csv
+            S.encodeCsvStreamUtf8
             encodingB
             $ ByteString.concat
               [ "number,letter,boolean\n"
@@ -51,7 +54,7 @@ tests =
               ]
     , testCase "Headed Encoding (int,char,bool) monoidal building"
         $ runTestScenario [(4,'c',False)]
-            S.encodeHeadedUtf8Csv
+            S.encodeCsvStreamUtf8
             encodingC
             $ ByteString.concat
               [ "boolean,letter\n"
@@ -59,7 +62,7 @@ tests =
               ]
     , testCase "Headed Encoding (escaped characters)"
         $ runTestScenario ["bob","there,be,commas","the \" quote"]
-            S.encodeHeadedUtf8Csv
+            S.encodeCsvStreamUtf8
             encodingF
             $ ByteString.concat
               [ "name\n"
@@ -69,16 +72,35 @@ 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"
                 ]
               )
-            ) @?= ([(244,'z',True)] :> Nothing)
+            ) @?= ([(244,intToWord8 (ord 'z'),True)] :> Nothing)
-    , testCase "Headed Decoding (escaped characters)"
+    , testCase "Headed Decoding (geolite)"
         $ ( runIdentity . SMP.toList )
-            ( S.decodeHeadedUtf8Csv decodingF
+            ( S.decodeCsvUtf8 decodingGeolite
+              ( SMP.yield $ BC8.pack $ concat
+                [ "network,autonomous_system_number,autonomous_system_organization\n"
+                , "1,z,y\n"
+                ]
+              )
+            ) @?= ([(1,intToWord8 (ord 'z'),intToWord8 (ord 'y'))] :> Nothing)
+    , testCase "Headed Decoding (escaped characters, one big chunk)"
+        $ ( runIdentity . SMP.toList )
+            ( S.decodeCsvUtf8 decodingF
+              ( SMP.yield $ BC8.pack $ concat
+                [ "name\n"
+                , "drew\n"
+                , "\"martin, drew\"\n"
+                ]
+              )
+            ) @?= (["drew","martin, drew"] :> Nothing)
+    , testCase "Headed Decoding (escaped characters, character per chunk)"
+        $ ( runIdentity . SMP.toList )
+            ( S.decodeCsvUtf8 decodingF
               ( mapM_ (SMP.yield . BC8.singleton) $ concat
                 [ "name\n"
                 , "drew\n"
@@ -88,11 +110,14 @@ tests =
             ) @?= (["drew","martin, drew"] :> Nothing)
     , testProperty "Headed Isomorphism (int,char,bool)"
         $ propIsoStream BC8.unpack
-          (S.decodeHeadedUtf8Csv decodingB)
+          (S.decodeCsvUtf8 decodingB)
-          (S.encodeHeadedUtf8Csv encodingB)
+          (S.encodeCsvStreamUtf8 encodingB)
     ]
   ]
 
+intToWord8 :: Int -> Word8
+intToWord8 = fromIntegral
+
 data Foo = FooA | FooB | FooC
   deriving (Generic,Eq,Ord,Show,Read,Bounded,Enum)
 
@@ -124,15 +149,21 @@ decodingA = (,,)
   <*> S.headless dbChar
   <*> S.headless dbBool
 
-decodingB :: Siphon Headed ByteString (Int,Char,Bool)
+decodingB :: Siphon Headed ByteString (Int,Word8,Bool)
 decodingB = (,,)
   <$> S.headed "number" dbInt
-  <*> S.headed "letter" dbChar
+  <*> S.headed "letter" dbWord8
   <*> S.headed "boolean" dbBool
 
 decodingF :: Siphon Headed ByteString ByteString
 decodingF = S.headed "name" Just
 
+decodingGeolite :: Siphon Headed ByteString (Int,Word8,Word8)
+decodingGeolite = (,,)
+  <$> S.headed "network" dbInt
+  <*> S.headed "autonomous_system_number" dbWord8
+  <*> S.headed "autonomous_system_organization" dbWord8
+
 
 encodingA :: Colonnade Headless (Int,Char,Bool) ByteString
 encodingA = mconcat
@@ -164,10 +195,10 @@ decodingY = (,,)
 encodingF :: Colonnade Headed ByteString ByteString
 encodingF = headed "name" id
 
-encodingB :: Colonnade Headed (Int,Char,Bool) ByteString
+encodingB :: Colonnade Headed (Int,Word8,Bool) ByteString
 encodingB = mconcat
   [ lmap fst3 (headed "number" ebInt)
-  , lmap snd3 (headed "letter" ebChar)
+  , lmap snd3 (headed "letter" ebWord8)
   , lmap thd3 (headed "boolean" ebBool)
   ]
 
@@ -253,6 +284,11 @@ dbChar b = case BC8.length b of
   1 -> Just (BC8.head b)
   _ -> Nothing
 
+dbWord8 :: ByteString -> Maybe Word8
+dbWord8 b = case B.length b of
+  1 -> Just (B.head b)
+  _ -> Nothing
+
 dbInt :: ByteString -> Maybe Int
 dbInt b = do
   (a,bsRem) <- BC8.readInt b
@@ -269,6 +305,9 @@ dbBool b
 ebChar :: Char -> ByteString
 ebChar = BC8.singleton
 
+ebWord8 :: Word8 -> ByteString
+ebWord8 = B.singleton
+
 ebInt :: Int -> ByteString
 ebInt = LByteString.toStrict
     . Builder.toLazyByteString 

stack-haddock-upload

@@ -0,0 +1,26 @@
+#!/bin/bash
+
+# Author: Dimitri Sabadie <dimitri.sabadie@gmail.com>
+# 2015
+
+dist=`stack path --dist-dir --stack-yaml ./stack.yaml 2> /dev/null`
+
+echo -e "\033[1;36mGenerating documentation...\033[0m"
+stack haddock 2> /dev/null
+
+if [ "$?" -eq "0" ]; then
+  docdir=$dist/doc/html
+  cd $docdir
+  doc=$1-$2-docs
+  echo -e "Compressing documentation from \033[1;34m$docdir\033[0m for \033[1;35m$1\033[0m-\033[1;33m$2\033[1;30m"
+  cp -r $1 $doc
+  tar -c -v -z --format=ustar -f $doc.tar.gz $doc
+  echo -e "\033[1;32mUploading to Hackage...\033[0m"
+  read -p "Hackage username: " username
+  read -p "Hackage password: " -s password
+  echo ""
+  curl -X PUT -H 'Content-Type: application/x-tar' -H 'Content-Encoding: gzip' --data-binary "@$doc.tar.gz" "https://$username:$password@hackage.haskell.org/package/$1-$2/docs"
+  exit $?
+else
+  echo -e "\033[1;31mNot in a stack-powered project\033[0m"
+fi

stack.yaml

@@ -1,50 +1,14 @@
-# This file was automatically generated by 'stack init'
+resolver: nightly-2018-06-11
-#
-# 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'
+- 'yesod-colonnade'
-# Dependency packages to be pulled from upstream that are not in the resolver
+# - 'geolite-csv'
-# (e.g., acme-missiles-0.3)
+
 extra-deps:
-- 'ip-0.9'
+- 'yesod-elements-1.1'
 
 # Override default flag values for local packages and extra-deps
 flags: {}

yesod-colonnade/src/Yesod/Colonnade.hs

@@ -15,23 +15,25 @@ module Yesod.Colonnade
   , anchorCell
   , anchorWidget
     -- * Apply
-  , encodeHeadedWidgetTable
+  , encodeWidgetTable
-  , encodeHeadlessWidgetTable
+  , encodeCellTable
-  , encodeHeadedCellTable
-  , encodeHeadlessCellTable
   , encodeDefinitionTable
   , encodeListItems
   ) where
 
 import Yesod.Core
-import Yesod.Core.Types (Body(..),GWData(..),WidgetT(..))
+import Yesod.Core.Types (Body(..),GWData(..),WidgetFor(..),wdRef)
 import Colonnade (Colonnade,Headed,Headless)
 import Data.Text (Text)
 import Control.Monad
+import Data.IORef (modifyIORef')
 import Data.Monoid
 import Data.String (IsString(..))
 import Text.Blaze (Attribute,toValue)
 import Data.Foldable
+import Yesod.Elements (table_,thead_,tbody_,tr_,td_,th_,ul_,li_,a_)
+import Data.Semigroup (Semigroup)
+import qualified Data.Semigroup as SG
 import qualified Text.Blaze.Html5.Attributes as HA
 import qualified Text.Blaze.Html5 as H
 import qualified Colonnade.Encode as E
@@ -42,19 +44,21 @@ import qualified Data.Text.Lazy.Builder as TBuilder
 -- | The attributes that will be applied to a @<td>@ and
 --   the HTML content that will go inside it.
 data Cell site = Cell
-  { cellAttrs :: !Attribute
+  { cellAttrs :: [Attribute]
-  , cellContents :: !(WidgetT site IO ())
+  , cellContents :: !(WidgetFor site ())
   }
 
 instance IsString (Cell site) where
   fromString = stringCell
 
+instance Semigroup (Cell site) where
+  Cell a1 c1 <> Cell a2 c2 = Cell (mappend a1 a2) (mappend c1 c2)
 instance Monoid (Cell site) where
   mempty = Cell mempty mempty
-  mappend (Cell a1 c1) (Cell a2 c2) = Cell (mappend a1 a2) (mappend c1 c2)
+  mappend = (SG.<>)
 
 -- | Create a 'Cell' from a 'Widget'
-cell :: WidgetT site IO () -> Cell site
+cell :: WidgetFor site () -> Cell site
 cell = Cell mempty
 
 -- | Create a 'Cell' from a 'String'
@@ -73,7 +77,7 @@ builderCell = cell . toWidget . toHtml . LText.toStrict . TBuilder.toLazyText
 --   it in an @\<a\>@.
 anchorCell :: 
      (a -> Route site) -- ^ Route that will go in @href@ attribute
-  -> (a -> WidgetT site IO ()) -- ^ Content wrapped by @<a>@ tag
+  -> (a -> WidgetFor site ()) -- ^ Content wrapped by @<a>@ tag
   -> a -- ^ Value
   -> Cell site
 anchorCell getRoute getContent = cell . anchorWidget getRoute getContent
@@ -82,26 +86,26 @@ anchorCell getRoute getContent = cell . anchorWidget getRoute getContent
 --   it in an @\<a\>@.
 anchorWidget :: 
      (a -> Route site) -- ^ Route that will go in @href@ attribute
-  -> (a -> WidgetT site IO ()) -- ^ Content wrapped by @<a>@ tag
+  -> (a -> WidgetFor site ()) -- ^ Content wrapped by @<a>@ tag
   -> a -- ^ Value
-  -> WidgetT site IO ()
+  -> WidgetFor site ()
 anchorWidget getRoute getContent a = do
   urlRender <- getUrlRender
-  a_ (HA.href (toValue (urlRender (getRoute a)))) (getContent a)
+  a_ [HA.href (toValue (urlRender (getRoute a)))] (getContent a)
 
 -- | This determines the attributes that are added
 --   to the individual @li@s by concatenating the header\'s
 --   attributes with the data\'s attributes. 
 encodeListItems :: 
-     (WidgetT site IO () -> WidgetT site IO ())
+     (WidgetFor site () -> WidgetFor site ())
      -- ^ Wrapper for items, often @ul@
-  -> (WidgetT site IO () -> WidgetT site IO () -> WidgetT site IO ())
+  -> (WidgetFor site () -> WidgetFor site () -> WidgetFor site ())
      -- ^ Combines header with data
   -> Colonnade Headed a (Cell site)
      -- ^ How to encode data as a row
   -> a
      -- ^ The value to display
-  -> WidgetT site IO ()
+  -> WidgetFor site ()
 encodeListItems ulWrap combine enc =
   ulWrap . E.bothMonadic_ enc
     (\(Cell ha hc) (Cell ba bc) ->
@@ -112,106 +116,68 @@ encodeListItems ulWrap combine enc =
 --   first column and the data displayed in the second column. Note
 --   that the generated HTML table does not have a @thead@.
 encodeDefinitionTable ::
-     Attribute
+     [Attribute]
      -- ^ Attributes of @table@ element.
   -> Colonnade Headed a (Cell site)
      -- ^ How to encode data as a row
   -> a
      -- ^ The value to display
-  -> WidgetT site IO ()
+  -> WidgetFor site ()
-encodeDefinitionTable attrs enc a = table_ attrs $ tbody_ mempty $ 
+encodeDefinitionTable attrs enc a = table_ attrs $ tbody_ [] $ 
   E.bothMonadic_ enc
-    (\theKey theValue -> tr_ mempty $ do
+    (\theKey theValue -> tr_ [] $ do
       widgetFromCell td_ theKey
       widgetFromCell td_ theValue
     ) a
 
--- | If you are using the bootstrap css framework, then you may want
+-- | Encode an html table with attributes on the table cells.
+--   If you are using the bootstrap css framework, then you may want
 --   to call this with the first argument as:
 --
---   > encodeHeadedCellTable (HA.class_ "table table-striped") ...
+--   > encodeCellTable (HA.class_ "table table-striped") ...
-encodeHeadedCellTable :: Foldable f
+encodeCellTable :: (Foldable f, E.Headedness h)
-  => Attribute -- ^ Attributes of @table@ element
+  => [Attribute] -- ^ Attributes of @table@ element
-  -> Colonnade Headed a (Cell site) -- ^ How to encode data as a row
+  -> Colonnade h a (Cell site) -- ^ How to encode data as a row
   -> f a -- ^ Rows of data
-  -> WidgetT site IO ()
+  -> WidgetFor site ()
-encodeHeadedCellTable = encodeTable
+encodeCellTable = encodeTable
-  (Just mempty) mempty (const mempty) widgetFromCell 
+  (E.headednessPure mempty) mempty (const mempty) widgetFromCell 
 
-encodeHeadlessCellTable :: Foldable f
+-- | Encode an html table.
-  => Attribute -- ^ Attributes of @table@ element
+encodeWidgetTable :: (Foldable f, E.Headedness h)
-  -> Colonnade Headless a (Cell site) -- ^ How to encode data as columns
+  => [Attribute] -- ^ Attributes of @\<table\>@ element
+  -> Colonnade h a (WidgetFor site ()) -- ^ How to encode data as columns
   -> f a -- ^ Rows of data
-  -> WidgetT site IO ()
+  -> WidgetFor site ()
-encodeHeadlessCellTable = encodeTable
+encodeWidgetTable = encodeTable
-  Nothing mempty (const mempty) widgetFromCell 
+  (E.headednessPure mempty) mempty (const mempty) ($ mempty) 
-
-encodeHeadedWidgetTable :: Foldable f
-  => Attribute -- ^ Attributes of @table@ element
-  -> Colonnade Headed a (WidgetT site IO ()) -- ^ How to encode data as columns
-  -> f a -- ^ Rows of data
-  -> WidgetT site IO ()
-encodeHeadedWidgetTable = encodeTable
-  (Just mempty) mempty (const mempty) ($ mempty)
-
-encodeHeadlessWidgetTable :: Foldable f
-  => Attribute -- ^ Attributes of @\<table\>@ element
-  -> Colonnade Headless a (WidgetT site IO ()) -- ^ How to encode data as columns
-  -> f a -- ^ Rows of data
-  -> WidgetT site IO ()
-encodeHeadlessWidgetTable = encodeTable
-  Nothing mempty (const mempty) ($ mempty) 
 
 -- | 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.
 encodeTable ::
-     (Foldable f, Foldable h)
+     (Foldable f, E.Headedness h)
-  => Maybe Attribute -- ^ Attributes of @\<thead\>@, pass 'Nothing' to omit @\<thead\>@
+  => h [Attribute] -- ^ Attributes of @\<thead\>@
-  -> Attribute -- ^ Attributes of @\<tbody\>@ element
+  -> [Attribute] -- ^ Attributes of @\<tbody\>@ element
-  -> (a -> Attribute) -- ^ Attributes of each @\<tr\>@ element
+  -> (a -> [Attribute]) -- ^ Attributes of each @\<tr\>@ element
-  -> ((Attribute -> WidgetT site IO () -> WidgetT site IO ()) -> c -> WidgetT site IO ()) -- ^ Wrap content and convert to 'Html'
+  -> (([Attribute] -> WidgetFor site () -> WidgetFor site ()) -> c -> WidgetFor site ()) -- ^ Wrap content and convert to 'Html'
-  -> Attribute -- ^ Attributes of @\<table\>@ element
+  -> [Attribute] -- ^ Attributes of @\<table\>@ element
   -> Colonnade h a c -- ^ How to encode data as a row
   -> f a -- ^ Collection of data
-  -> WidgetT site IO ()
+  -> WidgetFor site ()
-encodeTable mtheadAttrs tbodyAttrs trAttrs wrapContent tableAttrs colonnade xs =
+encodeTable theadAttrs tbodyAttrs trAttrs wrapContent tableAttrs colonnade xs =
   table_ tableAttrs $ do
-    for_ mtheadAttrs $ \theadAttrs -> do
+    for_ E.headednessExtract $ \unhead ->
-      thead_ theadAttrs $ do
+      thead_ (unhead theadAttrs) $ do
         E.headerMonadicGeneral_ colonnade (wrapContent th_)
     tbody_ tbodyAttrs $ do
       forM_ xs $ \x -> do
         tr_ (trAttrs x) (E.rowMonadic_ colonnade (wrapContent td_) x)
 
 widgetFromCell ::
-  (Attribute -> WidgetT site IO () -> WidgetT site IO ())
+     ([Attribute] -> WidgetFor site () -> WidgetFor site ())
   -> Cell site
-  -> WidgetT site IO ()
+  -> WidgetFor site ()
 widgetFromCell f (Cell attrs contents) =
   f attrs contents
 
-tr_,tbody_,thead_,table_,td_,th_,ul_,li_,a_ ::
-  Attribute -> WidgetT site IO () -> WidgetT site IO ()
-
-table_ = liftParent H.table
-thead_ = liftParent H.thead
-tbody_ = liftParent H.tbody
-tr_ = liftParent H.tr
-td_ = liftParent H.td
-th_ = liftParent H.th
-ul_ = liftParent H.ul
-li_ = liftParent H.li
-a_ = liftParent H.a
-
-liftParent :: (Html -> Html) -> Attribute -> WidgetT site IO a -> WidgetT site IO a
-liftParent el attrs (WidgetT f) = WidgetT $ \hdata -> do
-  (a,gwd) <- f hdata
-  let Body bodyFunc = gwdBody gwd
-      newBodyFunc render =
-        el H.! attrs $ (bodyFunc render)
-  return (a,gwd { gwdBody = Body newBodyFunc })
-
-
-
-

yesod-colonnade/yesod-colonnade.cabal

@@ -1,30 +1,33 @@
-name:                yesod-colonnade
+cabal-version: 2.0
-version:             1.1.0
+name: yesod-colonnade
-synopsis:            Helper functions for using yesod with colonnade
+version: 1.3.0.2
-description:         Yesod and colonnade
+synopsis: Helper functions for using yesod with colonnade
-homepage:            https://github.com/andrewthad/colonnade#readme
+description: Yesod and colonnade
-license:             BSD3
+homepage: https://github.com/andrewthad/colonnade#readme
-license-file:        LICENSE
+license: BSD3
-author:              Andrew Martin
+license-file: LICENSE
-maintainer:          andrew.thaddeus@gmail.com
+author: Andrew Martin
-copyright:           2016 Andrew Martin
+maintainer: andrew.thaddeus@gmail.com
-category:            web
+copyright: 2018 Andrew Martin
-build-type:          Simple
+category: web
-cabal-version:       >=1.10
+build-type: Simple
 
 library
   hs-source-dirs: src
   exposed-modules:
     Yesod.Colonnade
   build-depends:
-      base >= 4.7 && < 5
+      base >= 4.9.1 && < 4.14
-    , colonnade >= 1.1 && < 1.2
+    , colonnade >= 1.2 && < 1.3
-    , yesod-core >= 1.4 && < 1.5
+    , yesod-core >= 1.6 && < 1.7
+    , conduit >= 1.3 && < 1.4
+    , conduit-extra >= 1.3 && < 1.4
     , text >= 1.0 && < 1.3
     , blaze-markup >= 0.7 && < 0.9
     , blaze-html >= 0.8 && < 0.10
+    , yesod-elements >= 1.1 && < 1.2
   default-language: Haskell2010
 
 source-repository head
-  type:     git
+  type: git
   location: https://github.com/andrewthad/colonnade