yesod-colonnade base upper bound bump

add sized table to lucid-colonnade

.gitignore

@@ -5,8 +5,6 @@ cabal.config
 cabal.sandbox.config
 *.chi
 *.chs.h
-config/client_session_key.aes
-playground/
 dist*
 .DS_Store
 *.dyn_hi
@@ -19,22 +17,23 @@ dist*
 *.o
 *.prof
 *.sqlite3
-untracked/
-uploads/
-static/combined/
-static/tmp/
 *.swp
 .virtualenv
 .stack-work/
-yesod-devel/
 tmp/
-config/client_session_key.aes
-playground/auth.txt
 **/*.dump-hi
 tags
 TAGS
+colonnade/ex1.hs
+colonnade/result
 
-docs/db/unthreat
-
-geolite-csv/data/large
-geolite-lmdb/data/large
+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/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.

blaze-colonnade/Setup.hs

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

blaze-colonnade/blaze-colonnade.cabal

@@ -0,0 +1,49 @@
+name: blaze-colonnade
+version: 1.2.2.1
+synopsis: blaze-html backend for colonnade
+description:
+  This library provides a backend for using blaze-html with colonnade.
+  It generates standard HTML tables with `<table>`, `<tbody>`, `<thead>`,
+  `<tr>`, `<th>`, and `<td>`.
+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
+
+-- 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.8 && < 5
+    , colonnade >= 1.1 && < 1.3
+    , blaze-markup >= 0.7 && < 0.9
+    , blaze-html >= 0.8 && < 0.10
+    , profunctors >= 5.0 && < 5.5
+    , text >= 1.2 && < 1.3
+  default-language:    Haskell2010
+
+test-suite test
+  type:             exitcode-stdio-1.0
+  hs-source-dirs:   test
+  main-is:          Main.hs
+  build-depends:
+      base >= 4.7 && <= 5
+    , colonnade
+    , doctest
+    , profunctors
+  default-language: Haskell2010
+
+source-repository head
+  type:     git
+  location: https://github.com/andrewthad/colonnade

blaze-colonnade/hackage-docs.sh

@@ -0,0 +1,48 @@
+#!/bin/bash
+set -e
+
+if [ "$#" -ne 1 ]; then
+  echo "Usage: scripts/hackage-docs.sh HACKAGE_USER"
+  exit 1
+fi
+
+user=$1
+
+cabal_file=$(find . -maxdepth 1 -name "*.cabal" -print -quit)
+if [ ! -f "$cabal_file" ]; then
+  echo "Run this script in the top-level package directory"
+  exit 1
+fi
+
+pkg=$(awk -F ":[[:space:]]*" 'tolower($1)=="name"    { print $2 }' < "$cabal_file")
+ver=$(awk -F ":[[:space:]]*" 'tolower($1)=="version" { print $2 }' < "$cabal_file")
+
+if [ -z "$pkg" ]; then
+  echo "Unable to determine package name"
+  exit 1
+fi
+
+if [ -z "$ver" ]; then
+  echo "Unable to determine package version"
+  exit 1
+fi
+
+echo "Detected package: $pkg-$ver"
+
+dir=$(mktemp -d build-docs.XXXXXX)
+trap 'rm -r "$dir"' EXIT
+
+# cabal haddock --hoogle --hyperlink-source --html-location='/package/$pkg-$version/docs' --contents-location='/package/$pkg-$version'
+stack haddock
+
+cp -R .stack-work/dist/x86_64-linux/Cabal-1.22.5.0/doc/html/$pkg/ $dir/$pkg-$ver-docs
+# /home/andrew/.stack/snapshots/x86_64-linux/lts-5.17/7.10.3/doc/index.html
+
+tar cvz -C $dir --format=ustar -f $dir/$pkg-$ver-docs.tar.gz $pkg-$ver-docs
+
+curl -X PUT \
+     -H 'Content-Type: application/x-tar' \
+     -H 'Content-Encoding: gzip' \
+     -u "$user" \
+     --data-binary "@$dir/$pkg-$ver-docs.tar.gz" \
+     "https://hackage.haskell.org/package/$pkg-$ver/docs"

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

@@ -0,0 +1,549 @@
+{-# 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
+--   recommended that users read the documentation for @colonnade@ first,
+--   since this library builds on the abstractions introduced there.
+--   A concise example of this library\'s use:
+--
+-- >>> :set -XOverloadedStrings
+-- >>> :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 (encodeHtmlTable mempty col rows)
+-- <table>
+--     <thead>
+--         <tr><th>Grade</th><th>Letter</th></tr>
+--     </thead>
+--     <tbody>
+--         <tr><td>90-100</td><td>A</td></tr>
+--         <tr><td>80-89</td><td>B</td></tr>
+--         <tr><td>70-79</td><td>C</td></tr>
+--     </tbody>
+-- </table>
+module Text.Blaze.Colonnade
+  ( -- * Apply
+    encodeHtmlTable
+  , encodeCellTable
+  , encodeTable
+  , encodeCappedTable
+    -- * Cell
+    -- $build
+  , Cell(..)
+  , htmlCell
+  , stringCell
+  , textCell
+  , lazyTextCell
+  , builderCell
+  , htmlFromCell
+    -- * Interactive
+  , printCompactHtml
+  , printVeryCompactHtml
+    -- * Tutorial
+    -- $setup
+
+    -- * Discussion
+    -- $discussion
+  ) where
+
+import Text.Blaze (Attribute,(!))
+import Text.Blaze.Html (Html, toHtml)
+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 qualified Data.List as List
+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 E
+import qualified Data.Text as Text
+import qualified Data.Text.Lazy as LText
+import qualified Data.Text.Lazy.Builder as TBuilder
+
+-- $setup
+-- We start with a few necessary imports and some example data
+-- types:
+-- 
+-- >>> :set -XOverloadedStrings
+-- >>> import Data.Monoid (mconcat,(<>))
+-- >>> import Data.Char (toLower)
+-- >>> import Data.Profunctor (Profunctor(lmap))
+-- >>> import Colonnade (Colonnade,Headed,Headless,headed,cap,Fascia(..))
+-- >>> import Text.Blaze.Html (Html, toHtml, toValue)
+-- >>> import qualified Text.Blaze.Html5 as H
+-- >>> data Department = Management | Sales | Engineering deriving (Show,Eq)
+-- >>> data Employee = Employee { name :: String, department :: Department, age :: Int }
+-- 
+-- We define some employees that we will display in a table:
+--
+-- >>> :{
+-- let employees = 
+--       [ Employee "Thaddeus" Sales 34
+--       , Employee "Lucia" Engineering 33
+--       , Employee "Pranav" Management 57
+--       ]
+-- :}
+-- 
+-- Let's build a table that displays the name and the age
+-- of an employee. Additionally, we will emphasize the names of
+-- engineers using a @\<strong\>@ tag.
+--
+-- >>> :{
+-- let tableEmpA :: Colonnade Headed Employee Html
+--     tableEmpA = mconcat
+--       [ headed "Name" $ \emp -> case department emp of
+--           Engineering -> H.strong (toHtml (name emp))
+--           _ -> toHtml (name emp)
+--       , headed "Age" (toHtml . show . age)
+--       ]
+-- :}
+--
+-- The type signature of @tableEmpA@ is inferrable but is written
+-- out for clarity in this example. Additionally, note that the first
+-- argument to 'headed' is of type 'Html', so @OverloadedStrings@ is
+-- necessary for the above example to compile. To avoid using this extension,
+-- it is possible to instead use 'toHtml' to convert a 'String' to 'Html'.
+-- Let\'s continue:
+--
+-- >>> let customAttrs = HA.class_ "stylish-table" <> HA.id "main-table"
+-- >>> printCompactHtml (encodeHtmlTable customAttrs tableEmpA employees)
+-- <table class="stylish-table" id="main-table">
+--     <thead>
+--         <tr>
+--             <th>Name</th>
+--             <th>Age</th>
+--         </tr>
+--     </thead>
+--     <tbody>
+--         <tr>
+--             <td>Thaddeus</td>
+--             <td>34</td>
+--         </tr>
+--         <tr>
+--             <td><strong>Lucia</strong></td>
+--             <td>33</td>
+--         </tr>
+--         <tr>
+--             <td>Pranav</td>
+--             <td>57</td>
+--         </tr>
+--     </tbody>
+-- </table>
+-- 
+-- Excellent. As expected, Lucia\'s name is wrapped in a @\<strong\>@ tag 
+-- since she is an engineer.
+--
+-- One limitation of using 'Html' as the content
+-- type of a 'Colonnade' is that we are unable to add attributes to
+-- the @\<td\>@ and @\<th\>@ elements. This library provides the 'Cell' type
+-- to work around this problem. A 'Cell' is just 'Html' content and a set
+-- of attributes to be applied to its parent @<th>@ or @<td>@. To illustrate
+-- how its use, another employee table will be built. This table will
+-- contain a single column indicating the department of each employ. Each
+-- cell will be assigned a class name based on the department. To start off,
+-- let\'s build a table that encodes departments:
+--
+-- >>> :{
+-- let tableDept :: Colonnade Headed Department Cell
+--     tableDept = mconcat
+--       [ headed "Dept." $ \d -> Cell
+--           (HA.class_ (toValue (map toLower (show d))))
+--           (toHtml (show d))
+--       ]
+-- :}
+--
+-- Again, @OverloadedStrings@ plays a role, this time allowing the
+-- 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
+-- 'encodeCellTable' instead of 'encodeHtmlTable':
+--
+-- >>> let twoDepts = [Sales,Management]
+-- >>> printVeryCompactHtml (encodeCellTable customAttrs tableDept twoDepts)
+-- <table class="stylish-table" id="main-table">
+--     <thead>
+--         <tr><th>Dept.</th></tr>
+--     </thead>
+--     <tbody>
+--         <tr><td class="sales">Sales</td></tr>
+--         <tr><td class="management">Management</td></tr>
+--     </tbody>
+-- </table>
+-- 
+-- The attributes on the @\<td\>@ elements show up as they are expected to.
+-- Now, we take advantage of the @Profunctor@ instance of 'Colonnade' to allow
+-- this to work on @Employee@\'s instead:
+--
+-- >>> :t lmap
+-- lmap :: Profunctor p => (a -> b) -> p b c -> p a c
+-- >>> let tableEmpB = lmap department tableDept
+-- >>> :t tableEmpB
+-- tableEmpB :: Colonnade Headed Employee Cell
+-- >>> printVeryCompactHtml (encodeCellTable customAttrs tableEmpB employees)
+-- <table class="stylish-table" id="main-table">
+--     <thead>
+--         <tr><th>Dept.</th></tr>
+--     </thead>
+--     <tbody>
+--         <tr><td class="sales">Sales</td></tr>
+--         <tr><td class="engineering">Engineering</td></tr>
+--         <tr><td class="management">Management</td></tr>
+--     </tbody>
+-- </table>
+-- 
+-- This table shows the department of each of our three employees, additionally
+-- making a lowercased version of the department into a class name for the @\<td\>@.
+-- This table is nice for illustrative purposes, but it does not provide all the
+-- information that we have about the employees. If we combine it with the
+-- earlier table we wrote, we can present everything in the table. One small
+-- roadblock is that the types of @tableEmpA@ and @tableEmpB@ do not match, which
+-- prevents a straightforward monoidal append:
+--
+-- >>> :t tableEmpA
+-- tableEmpA :: Colonnade Headed Employee Html
+-- >>> :t tableEmpB
+-- tableEmpB :: Colonnade Headed Employee Cell
+--
+-- We can upcast the content type with 'fmap'.
+-- Monoidal append is then well-typed, and the resulting 'Colonnade'
+-- can be applied to the employees:
+--
+-- >>> let tableEmpC = fmap htmlCell tableEmpA <> tableEmpB
+-- >>> :t tableEmpC
+-- tableEmpC :: Colonnade Headed Employee Cell
+-- >>> printCompactHtml (encodeCellTable customAttrs tableEmpC employees)
+-- <table class="stylish-table" id="main-table">
+--     <thead>
+--         <tr>
+--             <th>Name</th>
+--             <th>Age</th>
+--             <th>Dept.</th>
+--         </tr>
+--     </thead>
+--     <tbody>
+--         <tr>
+--             <td>Thaddeus</td>
+--             <td>34</td>
+--             <td class="sales">Sales</td>
+--         </tr>
+--         <tr>
+--             <td><strong>Lucia</strong></td>
+--             <td>33</td>
+--             <td class="engineering">Engineering</td>
+--         </tr>
+--         <tr>
+--             <td>Pranav</td>
+--             <td>57</td>
+--             <td class="management">Management</td>
+--         </tr>
+--     </tbody>
+-- </table>
+
+-- $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 = Cell
+  { cellAttribute :: !Attribute
+  , cellHtml :: !Html
+  }
+
+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 = (<>)
+
+-- | Create a 'Cell' from a 'Widget'
+htmlCell :: Html -> Cell
+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. 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 :: forall h f a c. (Foldable f, E.Headedness h)
+  => h (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'
+  -> Attribute -- ^ Attributes of @\<table\>@ element
+  -> Colonnade h a c -- ^ How to encode data as a row
+  -> f a -- ^ Collection of data
+  -> Html
+encodeTable mtheadAttrs tbodyAttrs trAttrs wrapContent tableAttrs colonnade xs =
+  H.table ! tableAttrs $ do
+    case E.headednessExtractForall of
+      Nothing -> return mempty
+      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"))
+-- >>> printCompactHtml (encodeCappedCellTable mempty fascia cor [head employees])
+-- <table>
+--     <thead>
+--         <tr class="category">
+--             <th colspan="2">Personal</th>
+--             <th colspan="1">Work</th>
+--         </tr>
+--         <tr class="subcategory">
+--             <th colspan="1">Name</th>
+--             <th colspan="1">Age</th>
+--             <th colspan="1">Dept.</th>
+--         </tr>
+--     </thead>
+--     <tbody>
+--         <tr>
+--             <td>Thaddeus</td>
+--             <td>34</td>
+--             <td class="sales">Sales</td>
+--         </tr>
+--     </tbody>
+-- </table>
+
+encodeCappedCellTable :: Foldable f
+  => Attribute -- ^ Attributes of @\<table\>@ element
+  -> Fascia p Attribute -- ^ Attributes for @\<tr\>@ elements in the @\<thead\>@
+  -> Cornice Headed p a Cell 
+  -> f a -- ^ Collection of data
+  -> Html
+encodeCappedCellTable = encodeCappedTable mempty mempty (const mempty) htmlFromCell
+
+-- | Encode a table with tiered header rows. This is the most general function
+--   in this library for encoding a 'Cornice'.
+--
+encodeCappedTable :: Foldable f
+  => Attribute -- ^ Attributes of @\<thead\>@ 
+  -> Attribute -- ^ Attributes of @\<tbody\>@ element
+  -> (a -> Attribute) -- ^ Attributes of each @\<tr\>@ element in the @\<tbody\>@
+  -> ((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 Headed p a c 
+  -> f a -- ^ Collection of data
+  -> Html
+encodeCappedTable theadAttrs tbodyAttrs trAttrs wrapContent tableAttrs fascia cornice xs = do
+  let colonnade = E.discard cornice
+      annCornice = E.annotate cornice
+  H.table ! tableAttrs $ do
+    H.thead ! theadAttrs $ do
+      E.headersMonoidal 
+        (Just (fascia, \attrs theHtml -> H.tr ! attrs $ theHtml))
+        [ ( \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
+      -- E.headerMonoidalGeneral colonnade (wrapContent H.th)
+    encodeBody trAttrs wrapContent tbodyAttrs colonnade xs
+
+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
+  -> Colonnade h a c -- ^ How to encode data as a row
+  -> f a -- ^ Collection of data
+  -> Html
+encodeBody trAttrs wrapContent tbodyAttrs colonnade xs = do
+  H.tbody ! tbodyAttrs $ do
+    forM_ xs $ \x -> do
+      H.tr ! trAttrs x $ E.rowMonoidal colonnade (wrapContent H.td) x
+  
+
+-- | Encode a table. Table cells may have attributes
+--   applied to them.
+encodeCellTable :: 
+     Foldable f
+  => Attribute -- ^ Attributes of @\<table\>@ element
+  -> Colonnade Headed a Cell -- ^ How to encode data as columns
+  -> f a -- ^ Collection of data
+  -> Html
+encodeCellTable = encodeTable
+  (E.headednessPure (mempty,mempty)) mempty (const mempty) htmlFromCell 
+
+-- | Encode a table. Table cell element do not have 
+--   any attributes applied to them.
+encodeHtmlTable :: 
+     (Foldable f, E.Headedness h)
+  => Attribute -- ^ Attributes of @\<table\>@ element
+  -> Colonnade h a Html -- ^ How to encode data as columns
+  -> f a -- ^ Collection of data
+  -> Html
+encodeHtmlTable = encodeTable
+  (E.headednessPure (mempty,mempty)) mempty (const mempty) ($) 
+
+-- | Convert a 'Cell' to 'Html' by wrapping the content with a tag
+-- and applying the 'Cell' attributes to that tag.
+htmlFromCell :: (Html -> Html) -> Cell -> Html
+htmlFromCell f (Cell attr content) = f ! attr $ content
+
+data St = St
+  { stContext :: [String]
+  , stTagStatus :: TagStatus
+  , stResult :: String -> String -- ^ difference list
+  }
+
+data TagStatus 
+  = TagStatusSomeTag 
+  | TagStatusOpening (String -> String)
+  | TagStatusOpeningAttrs 
+  | TagStatusNormal 
+  | TagStatusClosing (String -> String)
+  | TagStatusAfterTag
+
+removeWhitespaceAfterTag :: String -> String -> String
+removeWhitespaceAfterTag chosenTag = 
+  either id (\st -> stResult st "") . foldlM (flip f) (St [] TagStatusNormal id)
+  where
+  f :: Char -> St -> Either String St
+  f c (St ctx status res) = case status of
+    TagStatusNormal
+      | c == '<' -> Right (St ctx TagStatusSomeTag likelyRes)
+      | isSpace c -> if Just chosenTag == listToMaybe ctx
+          then Right (St ctx TagStatusNormal res) -- drops the whitespace
+          else Right (St ctx TagStatusNormal likelyRes)
+      | otherwise -> Right (St ctx TagStatusNormal likelyRes)
+    TagStatusSomeTag
+      | c == '/' -> Right (St ctx (TagStatusClosing id) likelyRes)
+      | c == '>' -> Left "unexpected >"
+      | c == '<' -> Left "unexpected <"
+      | otherwise -> Right (St ctx (TagStatusOpening (c:)) likelyRes)
+    TagStatusOpening tag
+      | c == '>' -> Right (St (tag "" : ctx) TagStatusAfterTag likelyRes)
+      | isSpace c -> Right (St (tag "" : ctx) TagStatusOpeningAttrs likelyRes)
+      | otherwise -> Right (St ctx (TagStatusOpening (tag . (c:))) likelyRes)
+    TagStatusOpeningAttrs
+      | c == '>' -> Right (St ctx TagStatusAfterTag likelyRes)
+      | otherwise -> Right (St ctx TagStatusOpeningAttrs likelyRes)
+    TagStatusClosing tag
+      | c == '>' -> do
+          otherTags <- case ctx of
+            [] -> Left "closing tag without any opening tag"
+            closestTag : otherTags -> if closestTag == tag ""
+              then Right otherTags
+              else Left $ "closing tag <" ++ tag "" ++ "> did not match opening tag <" ++ closestTag ++ ">"
+          Right (St otherTags TagStatusAfterTag likelyRes)
+      | otherwise -> Right (St ctx (TagStatusClosing (tag . (c:))) likelyRes)
+    TagStatusAfterTag
+      | c == '<' -> Right (St ctx TagStatusSomeTag likelyRes)
+      | isSpace c -> if Just chosenTag == listToMaybe ctx
+          then Right (St ctx TagStatusAfterTag res) -- drops the whitespace
+          else Right (St ctx TagStatusNormal likelyRes)
+      | otherwise -> Right (St ctx TagStatusNormal likelyRes)
+    where 
+    likelyRes :: String -> String
+    likelyRes = res . (c:)
+
+-- | Pretty print an HTML table, stripping whitespace from inside @\<td\>@,
+--   @\<th\>@, and common inline tags. The implementation is inefficient and is
+--   incorrect in many corner cases. It is only provided to reduce the line
+--   count of the HTML printed by GHCi examples in this module\'s documentation.
+--   Use of this function is discouraged.
+printCompactHtml :: Html -> IO ()
+printCompactHtml = putStrLn 
+  . List.dropWhileEnd (== '\n')
+  . removeWhitespaceAfterTag "td" 
+  . removeWhitespaceAfterTag "th" 
+  . removeWhitespaceAfterTag "strong" 
+  . removeWhitespaceAfterTag "span" 
+  . removeWhitespaceAfterTag "em" 
+  . Pretty.renderHtml
+
+-- | Similar to 'printCompactHtml'. Additionally strips all whitespace inside
+--   @\<tr\>@ elements and @\<thead\>@ elements.
+printVeryCompactHtml :: Html -> IO ()
+printVeryCompactHtml = putStrLn 
+  . List.dropWhileEnd (== '\n')
+  . removeWhitespaceAfterTag "td" 
+  . removeWhitespaceAfterTag "th" 
+  . removeWhitespaceAfterTag "strong" 
+  . removeWhitespaceAfterTag "span" 
+  . removeWhitespaceAfterTag "em" 
+  . removeWhitespaceAfterTag "tr" 
+  . Pretty.renderHtml
+
+
+-- $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 Cell a -> f a -> Html
+--
+-- The 'Colonnade' content type is 'Cell', but the content
+-- type of the result is 'Html'. It may not be immidiately clear why
+-- this is useful 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 Html a -> f a -> Html
+--
+-- 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.
+
+

blaze-colonnade/test/Main.hs

@@ -0,0 +1,6 @@
+import Test.DocTest
+
+main :: IO ()
+main = doctest
+  [ "src/Text/Blaze/Colonnade.hs"
+  ]

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,45 +1,62 @@
-name:                colonnade
-version:             0.4.7
-synopsis:            Generic types and functions for columnar encoding and decoding
-description:         Please see README.md
-homepage:            https://github.com/andrewthad/colonnade#readme
-license:             BSD3
-license-file:        LICENSE
-author:              Andrew Martin
-maintainer:          andrew.thaddeus@gmail.com
-copyright:           2016 Andrew Martin
-category:            web
-build-type:          Simple
-cabal-version:       >=1.10
+name: colonnade
+version: 1.2.0.2
+synopsis: Generic types and functions for columnar encoding and decoding
+description:
+  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.
+  Most users will also want to one a companion packages
+  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
+  .
+  * <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
+license: BSD3
+license-file: LICENSE
+author: Andrew Martin
+maintainer: andrew.thaddeus@gmail.com
+copyright: 2016 Andrew Martin
+category: web
+build-type: Simple
+cabal-version: >=1.10
 
 library
   hs-source-dirs:      src
   exposed-modules:
-    Colonnade.Types
-    Colonnade.Encoding
-    Colonnade.Encoding.Text
-    Colonnade.Encoding.ByteString.Char8
-    Colonnade.Decoding
-    Colonnade.Decoding.Text
-    Colonnade.Decoding.ByteString.Char8
-    Colonnade.Internal
+    Colonnade
+    Colonnade.Encode
   build-depends:
-      base >= 4.7 && < 5
-    , contravariant >= 1.2 && < 1.5
-    , vector >= 0.10 && < 0.12
+      base >= 4.8 && < 5
+    , contravariant >= 1.2 && < 1.6
+    , vector >= 0.10 && < 0.13
     , text >= 1.0 && < 1.3
     , bytestring >= 0.10 && < 0.11
+    , 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
-  hs-source-dirs:   test
-  main-is:          Main.hs
+  type: exitcode-stdio-1.0
+  hs-source-dirs: test
+  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/examples/ex1.hs

@@ -1,63 +0,0 @@
-import Colonnade.Encoding
-import Colonnade.Types
-import Data.Functor.Contravariant
-
-data Color = Red | Green | Blue deriving (Show)
-data Person = Person { personName :: String, personAge :: Int }
-data House = House { houseColor :: Color, housePrice :: Int }
-
-encodingPerson :: Encoding Headed String Person
-encodingPerson = mconcat
-  [ headed "Name" personName
-  , headed "Age" (show . personAge)
-  ]
-
-encodingHouse :: Encoding Headed String House
-encodingHouse = mconcat
-  [ headed "Color" (show . houseColor)
-  , headed "Price" (('$':) . show . housePrice)
-  ]
-
-encodingPerson2 :: Encoding Headless String Person
-encodingPerson2 = mconcat
-  [ headless personName
-  , headless (show . personAge)
-  ]
-
-people :: [Person]
-people = [Person "David" 63, Person "Ava" 34, Person "Sonia" 12]
-
-houses :: [House]
-houses = [House Green 170000, House Blue 115000]
-
-peopleInHouses :: [(Person,House)]
-peopleInHouses = (,) <$> people <*> houses
-
-encodingPersonHouse :: Encoding Headed String (Person,House)
-encodingPersonHouse = mconcat
-  [ contramap fst encodingPerson
-  , contramap snd encodingHouse
-  ]
-
-owners :: [(Person,Maybe House)]
-owners =
-  [ (Person "Jordan" 18, Nothing)
-  , (Person "Ruth" 25, Just (House Red 125000))
-  , (Person "Sonia" 12, Just (House Green 145000))
-  ]
-
-encodingOwners :: Encoding Headed String (Person,Maybe House)
-encodingOwners = mconcat
-  [ contramap fst encodingPerson
-  , contramap snd (fromMaybe "(none)" encodingHouse)
-  ]
-
-main :: IO ()
-main = do
-  putStr $ ascii encodingPerson people
-  putStrLn ""
-  putStr $ ascii encodingHouse houses
-  putStrLn ""
-  putStr $ ascii encodingOwners owners
-  putStrLn ""
-

colonnade/shell.nix

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

colonnade/src/Colonnade.hs

@@ -0,0 +1,438 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE RankNTypes #-}
+
+{-# 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.
+module Colonnade
+  ( -- * Example
+    -- $setup
+    -- * Types
+    Colonnade
+  , Headed(..)
+  , Headless(..)
+    -- * Typeclasses
+  , E.Headedness(..)
+    -- * Create
+  , headed
+  , headless
+  , singleton
+    -- * Transform
+    -- ** Body
+  , fromMaybe
+  , columns
+  , bool
+  , replaceWhen
+  , modifyWhen
+    -- ** Header
+  , mapHeaderContent
+  , mapHeadedness
+  , toHeadless
+    -- * Cornice
+    -- ** Types
+  , Cornice
+  , Pillar(..)
+  , Fascia(..)
+    -- ** Create
+  , cap
+  , recap
+    -- * Ascii Table
+  , ascii
+  , asciiCapped
+  ) where
+
+import Colonnade.Encode (Colonnade,Cornice,
+  Pillar(..),Fascia(..),Headed(..),Headless(..))
+import Data.Foldable
+import Control.Monad
+import qualified Data.Bool
+import qualified Data.Maybe
+import qualified Colonnade.Encode as E
+import qualified Data.List as List
+import qualified Data.Vector as Vector
+
+-- $setup
+--
+-- First, let\'s bring in some neccessary imports that will be
+-- used for the remainder of the examples in the docs:
+--
+-- >>> import Data.Monoid (mconcat,(<>))
+-- >>> import Data.Profunctor (lmap)
+--
+-- The data types we wish to encode are:
+--
+-- >>> data Color = Red | Green | Blue deriving (Show,Eq)
+-- >>> data Person = Person { name :: String, age :: Int }
+-- >>> data House = House { color :: Color, price :: Int }
+--
+-- One potential columnar encoding of a @Person@ would be:
+--
+-- >>> :{
+-- let colPerson :: Colonnade Headed Person String
+--     colPerson = mconcat
+--       [ headed "Name" name
+--       , headed "Age" (show . age)
+--       ]
+-- :}
+--
+-- The type signature on @colPerson@ is not neccessary
+-- but is included for clarity. We can feed data into this encoding
+-- to build a table:
+--
+-- >>> let people = [Person "David" 63, Person "Ava" 34, Person "Sonia" 12]
+-- >>> putStr (ascii colPerson people)
+-- +-------+-----+
+-- | Name  | Age |
+-- +-------+-----+
+-- | David | 63  |
+-- | Ava   | 34  |
+-- | Sonia | 12  |
+-- +-------+-----+
+--
+-- Similarly, we can build a table of houses with:
+--
+-- >>> let showDollar = (('$':) . show) :: Int -> String
+-- >>> colHouse = mconcat [headed "Color" (show . color), headed "Price" (showDollar . price)]
+-- >>> :t colHouse
+-- colHouse :: Colonnade Headed House [Char]
+-- >>> let houses = [House Green 170000, House Blue 115000, House Green 150000]
+-- >>> putStr (ascii colHouse houses)
+-- +-------+---------+
+-- | Color | Price   |
+-- +-------+---------+
+-- | Green | $170000 |
+-- | Blue  | $115000 |
+-- | Green | $150000 |
+-- +-------+---------+
+
+
+-- | A single column with a header.
+headed :: c -> (a -> c) -> Colonnade Headed a c
+headed h = singleton (Headed h)
+
+-- | A single column without a header.
+headless :: (a -> c) -> Colonnade Headless a c
+headless = singleton Headless
+
+-- | A single column with any kind of header. This is not typically needed.
+singleton :: h c -> (a -> c) -> Colonnade h a c
+singleton h = E.Colonnade . Vector.singleton . E.OneColonnade h
+
+-- | Map over the content in the header. This is similar performing 'fmap'
+--   on a 'Colonnade' except that the body content is unaffected.
+mapHeaderContent :: Functor h => (c -> c) -> Colonnade h a c -> Colonnade h a c
+mapHeaderContent f (E.Colonnade v) = 
+  E.Colonnade (Vector.map (\(E.OneColonnade h e) -> E.OneColonnade (fmap f h) e) v)
+
+-- | Map over the header type of a 'Colonnade'.
+mapHeadedness :: (forall x. h x -> h' x) -> Colonnade h a c -> Colonnade h' a c
+mapHeadedness f (E.Colonnade v) =
+  E.Colonnade (Vector.map (\(E.OneColonnade h e) -> E.OneColonnade (f h) e) v)
+
+-- | Remove the heading from a 'Colonnade'.
+toHeadless :: Colonnade h a c -> Colonnade Headless a c
+toHeadless = mapHeadedness (const Headless)
+  
+
+-- | Lift a column over a 'Maybe'. For example, if some people
+--   have houses and some do not, the data that pairs them together
+--   could be represented as:
+--
+-- >>> :{
+-- let owners :: [(Person,Maybe House)]
+--     owners =
+--       [ (Person "Jordan" 18, Nothing)
+--       , (Person "Ruth" 25, Just (House Red 125000))
+--       , (Person "Sonia" 12, Just (House Green 145000))
+--       ]
+-- :}
+--
+-- The column encodings defined earlier can be reused with
+-- the help of 'fromMaybe':
+--
+-- >>> :{
+-- let colOwners :: Colonnade Headed (Person,Maybe House) String
+--     colOwners = mconcat
+--       [ lmap fst colPerson
+--       , lmap snd (fromMaybe "" colHouse)
+--       ]
+-- :}
+--
+-- >>> putStr (ascii colOwners owners)
+-- +--------+-----+-------+---------+
+-- | Name   | Age | Color | Price   |
+-- +--------+-----+-------+---------+
+-- | Jordan | 18  |       |         |
+-- | Ruth   | 25  | Red   | $125000 |
+-- | Sonia  | 12  | Green | $145000 |
+-- +--------+-----+-------+---------+
+fromMaybe :: c -> Colonnade f a c -> Colonnade f (Maybe a) c
+fromMaybe c (E.Colonnade v) = E.Colonnade $ flip Vector.map v $
+  \(E.OneColonnade h encode) -> E.OneColonnade h (maybe c encode)
+
+-- | Convert a collection of @b@ values into a columnar encoding of
+--   the same size. Suppose we decide to show a house\'s color
+--   by putting a check mark in the column corresponding to
+--   the color instead of by writing out the name of the color:
+--
+-- >>> let allColors = [Red,Green,Blue]
+-- >>> let encColor = columns (\c1 c2 -> if c1 == c2 then "✓" else "") (Headed . show) allColors
+-- >>> :t encColor
+-- encColor :: Colonnade Headed Color [Char]
+-- >>> let encHouse = headed "Price" (showDollar . price) <> lmap color encColor
+-- >>> :t encHouse
+-- encHouse :: Colonnade Headed House [Char]
+-- >>> putStr (ascii encHouse houses)
+-- +---------+-----+-------+------+
+-- | Price   | Red | Green | Blue |
+-- +---------+-----+-------+------+
+-- | $170000 |     | ✓     |      |
+-- | $115000 |     |       | ✓    |
+-- | $150000 |     | ✓     |      |
+-- +---------+-----+-------+------+
+columns :: Foldable g
+  => (b -> a -> c) -- ^ Cell content function
+  -> (b -> f c) -- ^ Header content function
+  -> g b -- ^ Basis for column encodings
+  -> Colonnade f a c
+columns getCell getHeader = id
+  . E.Colonnade
+  . Vector.map (\b -> E.OneColonnade (getHeader b) (getCell b))
+  . Vector.fromList
+  . toList
+
+bool ::
+     f c -- ^ Heading
+  -> (a -> Bool) -- ^ Predicate
+  -> (a -> c) -- ^ Contents when predicate is false
+  -> (a -> c) -- ^ Contents when predicate is true
+  -> Colonnade f a c
+bool h p onTrue onFalse = singleton h (Data.Bool.bool <$> onFalse <*> onTrue <*> p)
+
+-- | Modify the contents of cells in rows whose values satisfy the
+--   given predicate. Header content is unaffected. With an HTML backend, 
+--   this can be used to strikethrough the contents of cells with data that is
+--   considered invalid.
+modifyWhen ::
+     (c -> c) -- ^ Content change
+  -> (a -> Bool) -- ^ Row predicate
+  -> Colonnade f a c -- ^ Original 'Colonnade'
+  -> Colonnade f a c
+modifyWhen changeContent p (E.Colonnade v) = E.Colonnade
+  ( Vector.map
+    (\(E.OneColonnade h encode) -> E.OneColonnade h $ \a ->
+      if p a then changeContent (encode a) else encode a
+    ) v
+  )
+
+-- | Replace the contents of cells in rows whose values satisfy the
+--   given predicate. Header content is unaffected.
+replaceWhen ::
+     c -- ^ New content
+  -> (a -> Bool) -- ^ Row predicate
+  -> Colonnade f a c -- ^ Original 'Colonnade'
+  -> Colonnade f a c
+replaceWhen = modifyWhen . const
+
+-- | Augment a 'Colonnade' with a header spans over all of the
+--   existing headers. This is best demonstrated by example. 
+--   Let\'s consider how we might encode a pairing of the people 
+--   and houses from the initial example:
+--   
+--   >>> let personHomePairs = zip people houses
+--   >>> let colPersonFst = lmap fst colPerson
+--   >>> let colHouseSnd = lmap snd colHouse
+--   >>> putStr (ascii (colPersonFst <> colHouseSnd) personHomePairs)
+--   +-------+-----+-------+---------+
+--   | Name  | Age | Color | Price   |
+--   +-------+-----+-------+---------+
+--   | David | 63  | Green | $170000 |
+--   | Ava   | 34  | Blue  | $115000 |
+--   | Sonia | 12  | Green | $150000 |
+--   +-------+-----+-------+---------+
+--   
+--   This tabular encoding leaves something to be desired. The heading
+--   not indicate that the name and age refer to a person and that
+--   the color and price refer to a house. Without reaching for 'Cornice',
+--   we can still improve this situation with 'mapHeaderContent':
+--
+--   >>> let colPersonFst' = mapHeaderContent ("Person " ++) colPersonFst
+--   >>> let colHouseSnd' = mapHeaderContent ("House " ++) colHouseSnd
+--   >>> putStr (ascii (colPersonFst' <> colHouseSnd') personHomePairs)
+--   +-------------+------------+-------------+-------------+
+--   | Person Name | Person Age | House Color | House Price |
+--   +-------------+------------+-------------+-------------+
+--   | David       | 63         | Green       | $170000     |
+--   | Ava         | 34         | Blue        | $115000     |
+--   | Sonia       | 12         | Green       | $150000     |
+--   +-------------+------------+-------------+-------------+
+--
+--   This is much better, but for longer tables, the redundancy
+--   of prefixing many column headers can become annoying. The solution
+--   that a 'Cornice' offers is to nest headers:
+--   
+--   >>> let cor = mconcat [cap "Person" colPersonFst, cap "House" colHouseSnd]
+--   >>> :t cor
+--   cor :: Cornice Headed ('Cap 'Base) (Person, House) [Char]
+--   >>> putStr (asciiCapped cor personHomePairs)
+--   +-------------+-----------------+
+--   | Person      | House           |
+--   +-------+-----+-------+---------+
+--   | Name  | Age | Color | Price   |
+--   +-------+-----+-------+---------+
+--   | David | 63  | Green | $170000 |
+--   | Ava   | 34  | Blue  | $115000 |
+--   | Sonia | 12  | Green | $150000 |
+--   +-------+-----+-------+---------+
+--   
+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
+--   this can be applied:
+--   
+--   >>> data Day = Weekday | Weekend deriving (Show)
+--   >>> :{
+--   let cost :: Int -> Day -> String
+--       cost base w = case w of
+--         Weekday -> showDollar base
+--         Weekend -> showDollar (base + 1)
+--       colStandard = foldMap (\c -> headed c (cost 8)) ["Yt","Ad","Sr"]
+--       colSpecial = mconcat [headed "Stud" (cost 6), headed "Mltry" (cost 7)]
+--       corStatus = mconcat
+--         [ cap "Standard" colStandard
+--         , cap "Special" colSpecial
+--         ] 
+--       corShowtime = mconcat
+--         [ recap "" (cap "" (headed "Day" show))
+--         , foldMap (\c -> recap c corStatus) ["Matinee","Evening"]
+--         ]
+--   :}
+--
+--   >>> putStr (asciiCapped corShowtime [Weekday,Weekend])
+--   +---------+-----------------------------+-----------------------------+
+--   |         | Matinee                     | Evening                     |
+--   +---------+--------------+--------------+--------------+--------------+
+--   |         | Standard     | Special      | Standard     | Special      |
+--   +---------+----+----+----+------+-------+----+----+----+------+-------+
+--   | Day     | Yt | Ad | Sr | Stud | Mltry | Yt | Ad | Sr | Stud | Mltry |
+--   +---------+----+----+----+------+-------+----+----+----+------+-------+
+--   | 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 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 Headed p a String -- ^ columnar encoding
+  -> f a -- ^ rows
+  -> String
+asciiCapped cor xs =
+  let annCor = E.annotateFinely (\x y -> x + y + 3) id 
+        List.length xs cor
+      sizedCol = E.uncapAnnotated annCor
+   in E.headersMonoidal
+        Nothing 
+        [ ( \msz _ -> case msz of
+              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
+      
+
+-- | Render a collection of rows as an ascii table. The table\'s columns are
+-- specified by the given 'Colonnade'. This implementation is inefficient and
+-- does not provide any wrapping behavior. It is provided so that users can
+-- try out @colonnade@ in ghci and so that @doctest@ can verify example
+-- code in the haddocks.
+ascii :: Foldable f
+  => Colonnade Headed a String -- ^ columnar encoding
+  -> f a -- ^ rows
+  -> String
+ascii col xs = 
+  let sizedCol = E.sizeColumns List.length xs col
+      divider = concat
+        [ E.headerMonoidalFull sizedCol 
+             (\(E.Sized msz _) -> case msz of
+               Just sz -> "+" ++ hyphens (sz + 2)
+               Nothing -> ""
+             )
+        , "+\n"
+        ]
+   in List.concat
+      [ divider
+      , concat
+         [ E.headerMonoidalFull sizedCol
+             (\(E.Sized msz (Headed h)) -> case msz of
+               Just sz -> "| " ++ rightPad sz ' ' h ++ " "
+               Nothing -> ""
+             )
+         , "|\n"
+         ]
+      , asciiBody sizedCol xs
+      ]
+
+asciiBody :: Foldable f
+  => Colonnade (E.Sized (Maybe Int) Headed) a String
+  -> f a
+  -> String
+asciiBody sizedCol xs =
+  let divider = concat
+        [ E.headerMonoidalFull sizedCol 
+             (\(E.Sized msz _) -> case msz of
+               Just sz -> "+" ++ hyphens (sz + 2)
+               Nothing -> ""
+             )
+        , "+\n"
+        ]
+      rowContents = foldMap
+        (\x -> concat
+           [ E.rowMonoidalHeader 
+               sizedCol
+               (\(E.Sized msz _) c -> case msz of
+                 Nothing -> ""
+                 Just sz -> "| " ++ rightPad sz ' ' c ++ " "
+               )
+               x
+           , "|\n"
+           ]
+        ) xs
+   in List.concat
+      [ divider
+      , rowContents
+      , divider
+      ]
+      
+hyphens :: Int -> String
+hyphens n = List.replicate n '-'
+
+rightPad :: Int -> a -> [a] -> [a]
+rightPad m a xs = take m $ xs ++ repeat a
+
+-- data Company = Company String String Int
+-- 
+-- data Company = Company
+--   { companyName :: String
+--   , companyCountry :: String
+--   , companyValue :: Int
+--   } deriving (Show)
+-- 
+-- myCompanies :: [Company]
+-- myCompanies =
+--   [ Company "eCommHub" "United States" 50
+--   , Company "Layer 3 Communications" "United States" 10000000
+--   , Company "Microsoft" "England" 500000000
+--   ]
+
+
+
+
+
+

colonnade/src/Colonnade/Decoding.hs

@@ -1,160 +0,0 @@
-{-# LANGUAGE RankNTypes          #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE BangPatterns        #-}
-module Colonnade.Decoding where
-
-import Colonnade.Internal (EitherWrap(..),mapLeft)
-import Colonnade.Types
-import Data.Functor.Contravariant
-import Data.Vector (Vector)
-import qualified Data.Vector as Vector
-import Data.Char (chr)
-
--- | Converts the content type of a 'Decoding'. The @'Contravariant' f@
--- constraint means that @f@ can be 'Headless' but not 'Headed'.
-contramapContent :: forall c1 c2 f a. Contravariant f => (c2 -> c1) -> Decoding f c1 a -> Decoding f c2 a
-contramapContent f = go
-  where
-  go :: forall b. Decoding f c1 b -> Decoding f c2 b
-  go (DecodingPure x) = DecodingPure x
-  go (DecodingAp h decode apNext) =
-    DecodingAp (contramap f h) (decode . f) (go apNext)
-
-headless :: (content -> Either String a) -> Decoding Headless content a
-headless f = DecodingAp Headless f (DecodingPure id)
-
-headed :: content -> (content -> Either String a) -> Decoding Headed content a
-headed h f = DecodingAp (Headed h) f (DecodingPure id)
-
-indexed :: Int -> (content -> Either String a) -> Decoding (Indexed Headless) content a
-indexed ix f = DecodingAp (Indexed ix Headless) f (DecodingPure id)
-
-maxIndex :: forall f c a. Decoding (Indexed f) c a -> Int
-maxIndex = go 0 where
-  go :: forall b. Int -> Decoding (Indexed f) c b -> Int
-  go !ix (DecodingPure _) = ix
-  go !ix1 (DecodingAp (Indexed ix2 _) decode apNext) =
-    go (max ix1 ix2) apNext
-
--- | This function uses 'unsafeIndex' to access
---   elements of the 'Vector'.
-uncheckedRunWithRow ::
-     Int
-  -> Decoding (Indexed f) content a
-  -> Vector content
-  -> Either (DecodingRowError f content) a
-uncheckedRunWithRow i d v = mapLeft (DecodingRowError i . RowErrorDecode) (uncheckedRun d v)
-
--- | This function does not check to make sure that the indicies in
---   the 'Decoding' are in the 'Vector'.
-uncheckedRun :: forall content a f.
-                Decoding (Indexed f) content a
-             -> Vector content
-             -> Either (DecodingCellErrors f content) a
-uncheckedRun dc v = getEitherWrap (go dc)
-  where
-  go :: forall b.
-        Decoding (Indexed f) content b
-     -> EitherWrap (DecodingCellErrors f content) b
-  go (DecodingPure b) = EitherWrap (Right b)
-  go (DecodingAp ixed@(Indexed ix h) decode apNext) =
-    let rnext = go apNext
-        content = Vector.unsafeIndex v ix
-        rcurrent = mapLeft (DecodingCellErrors . Vector.singleton . DecodingCellError content ixed) (decode content)
-    in rnext <*> (EitherWrap rcurrent)
-
-headlessToIndexed :: forall c a.
-  Decoding Headless c a -> Decoding (Indexed Headless) c a
-headlessToIndexed = go 0 where
-  go :: forall b. Int -> Decoding Headless c b -> Decoding (Indexed Headless) c b
-  go !ix (DecodingPure a) = DecodingPure a
-  go !ix (DecodingAp Headless decode apNext) =
-    DecodingAp (Indexed ix Headless) decode (go (ix + 1) apNext)
-
-length :: forall f c a. Decoding f c a -> Int
-length = go 0 where
-  go :: forall b. Int -> Decoding f c b -> Int
-  go !a (DecodingPure _) = a
-  go !a (DecodingAp _ _ apNext) = go (a + 1) apNext
-
--- | Maps over a 'Decoding' that expects headers, converting these
---   expected headers into the indices of the columns that they
---   correspond to.
-headedToIndexed :: forall content a. Eq content
-                => Vector content -- ^ Headers in the source document
-                -> Decoding Headed content a -- ^ Decoding that contains expected headers
-                -> Either (HeadingErrors content) (Decoding (Indexed Headed) content a)
-headedToIndexed v = getEitherWrap . go
-  where
-  go :: forall b. Eq content
-     => Decoding Headed content b
-     -> EitherWrap (HeadingErrors content) (Decoding (Indexed Headed) content b)
-  go (DecodingPure b) = EitherWrap (Right (DecodingPure b))
-  go (DecodingAp hd@(Headed h) decode apNext) =
-    let rnext = go apNext
-        ixs = Vector.elemIndices h v
-        ixsLen = Vector.length ixs
-        rcurrent
-          | ixsLen == 1 = Right (Vector.unsafeIndex ixs 0)
-          | ixsLen == 0 = Left (HeadingErrors (Vector.singleton h) Vector.empty)
-          | otherwise   = Left (HeadingErrors Vector.empty (Vector.singleton (h,ixsLen)))
-    in (\ix ap -> DecodingAp (Indexed ix hd) decode ap)
-       <$> EitherWrap rcurrent
-       <*> rnext
-
--- | This adds one to the index because text editors consider
---   line number to be one-based, not zero-based.
-prettyError :: (c -> String) -> DecodingRowError f c -> String
-prettyError toStr (DecodingRowError ix e) = unlines
-  $ ("Decoding error on line " ++ show (ix + 1) ++ " of file.")
-  : ("Error Category: " ++ descr)
-  : map ("  " ++) errDescrs
-  where (descr,errDescrs) = prettyRowError toStr e
-
-prettyRowError :: (content -> String) -> RowError f content -> (String, [String])
-prettyRowError toStr x = case x of
-  RowErrorParse err -> (,) "CSV Parsing"
-    [ "The line could not be parsed into cells correctly."
-    , "Original parser error: " ++ err
-    ]
-  RowErrorSize reqLen actualLen -> (,) "Row Length"
-    [ "Expected the row to have exactly " ++ show reqLen ++ " cells."
-    , "The row only has " ++ show actualLen ++ " cells."
-    ]
-  RowErrorMinSize reqLen actualLen -> (,) "Row Min Length"
-    [ "Expected the row to have at least " ++ show reqLen ++ " cells."
-    , "The row only has " ++ show actualLen ++ " cells."
-    ]
-  RowErrorMalformed enc -> (,) "Text Decoding"
-    [ "Tried to decode the input as " ++ enc ++ " text"
-    , "There is a mistake in the encoding of the text."
-    ]
-  RowErrorHeading errs -> (,) "Header" (prettyHeadingErrors toStr errs)
-  RowErrorDecode errs -> (,) "Cell Decoding" (prettyCellErrors toStr errs)
-
-prettyCellErrors :: (c -> String) -> DecodingCellErrors f c -> [String]
-prettyCellErrors toStr (DecodingCellErrors errs) = drop 1 $
-  flip concatMap errs $ \(DecodingCellError content (Indexed ix _) msg) ->
-    let str = toStr content in
-    [ "-----------"
-    , "Column " ++ columnNumToLetters ix
-    , "Original parse error: " ++ msg
-    , "Cell Content Length: " ++ show (Prelude.length str)
-    , "Cell Content: " ++ if null str
-        then "[empty cell]"
-        else str
-    ]
-
-prettyHeadingErrors :: (c -> String) -> HeadingErrors c -> [String]
-prettyHeadingErrors conv (HeadingErrors missing duplicates) = concat
-  [ concatMap (\h -> ["The header " ++ conv h ++ " was missing."]) missing
-  , concatMap (\(h,n) -> ["The header " ++ conv h ++ " occurred " ++ show n ++ " times."]) duplicates
-  ]
-
-columnNumToLetters :: Int -> String
-columnNumToLetters i
-  | i >= 0 && i < 25 = [chr (i + 65)]
-  | otherwise = "Beyond Z. Fix this."
-
-
-

colonnade/src/Colonnade/Decoding/ByteString/Char8.hs

@@ -1,26 +0,0 @@
-module Colonnade.Decoding.ByteString.Char8 where
-
-import Data.ByteString (ByteString)
-import qualified Data.ByteString as ByteString
-import qualified Data.ByteString.Char8 as BC8
-
-char :: ByteString -> Either String Char
-char b = case BC8.length b of
-  1 -> Right (BC8.head b)
-  0 -> Left "cannot decode Char from empty bytestring"
-  _ -> Left "cannot decode Char from multi-character bytestring"
-
-int :: ByteString -> Either String Int
-int b = do
-  (a,bsRem) <- maybe (Left "could not parse int") Right (BC8.readInt b)
-  if ByteString.null bsRem
-    then Right a
-    else Left "found extra characters after int"
-
-bool :: ByteString -> Either String Bool
-bool b
-  | b == BC8.pack "true" = Right True
-  | b == BC8.pack "false" = Right False
-  | otherwise = Left "must be true or false"
-
-

colonnade/src/Colonnade/Decoding/Text.hs

@@ -1,47 +0,0 @@
-module Colonnade.Decoding.Text where
-
-import Prelude hiding (map)
-import Data.Text (Text)
-import qualified Data.Text as Text
-import qualified Data.Text.Read as TextRead
-
-char :: Text -> Either String Char
-char t = case Text.length t of
-  1 -> Right (Text.head t)
-  0 -> Left "cannot decode Char from empty text"
-  _ -> Left "cannot decode Char from multi-character text"
-
-text :: Text -> Either String Text
-text = Right
-
-int :: Text -> Either String Int
-int t = do
-  (a,tRem) <- TextRead.decimal t
-  if Text.null tRem
-    then Right a
-    else Left "found extra characters after int"
-
-trueFalse :: Text -> Text -> Text -> Either String Bool
-trueFalse t f txt
-  | txt == t = Right True
-  | txt == f = Right False
-  | otherwise = Left $ concat
-      ["must be [", Text.unpack t, "] or [", Text.unpack f, "]"]
-
--- | This refers to the 'TextRead.Reader' from @Data.Text.Read@, not
---   to the @Reader@ monad.
-fromReader :: TextRead.Reader a -> Text -> Either String a
-fromReader f t = do
-  (a,tRem) <- f t
-  if Text.null tRem
-    then Right a
-    else Left "found extra characters at end of text"
-
-optional :: (Text -> Either String a) -> Text -> Either String (Maybe a)
-optional f t = if Text.null t
-  then Right Nothing
-  else fmap Just (f t)
-
-map :: (a -> b) -> (Text -> Either String a) -> Text -> Either String b
-map f g t = fmap f (g t)
-

colonnade/src/Colonnade/Encode.hs

@@ -0,0 +1,691 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+{-# OPTIONS_HADDOCK not-home #-}
+{-# 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'
+--   to a collection of values, building a table from them. Ultimately, 
+--   a function that applies a @Colonnade Headed MyCell a@ 
+--   to data will have roughly the following type:
+--
+-- > myTableRenderer :: Foldable g => Colonnade Headed MyCell a -> g a -> MyContent
+--
+--   In the companion packages @yesod-colonnade@ and
+--   @reflex-dom-colonnade@, functions with
+--   similar type signatures are readily available.
+--   These packages use the functions provided here
+--   in the implementations of their rendering functions.
+--   It is recommended that users who believe they may need
+--   this module look at the source of the companion packages 
+--   to see an example of how this module\'s functions are used.
+--   Other backends are encouraged to use these functions
+--   to build monadic or monoidal content from a 'Colonnade'.
+--
+--   The functions exported here take a 'Colonnade' and 
+--   convert it to a fragment of content. The functions whose
+--   names start with @row@ take at least a @Colonnade f c a@ and an @a@
+--   value to generate a row of content. The functions whose names
+--   start with @header@ need the @Colonnade f c a@ but not
+--   an @a@ value since a value is not needed to build a header.
+--   
+module Colonnade.Encode
+  ( -- * Colonnade
+    -- ** Types
+    Colonnade(..)
+  , OneColonnade(..)
+  , Headed(..)
+  , Headless(..)
+  , Sized(..)
+  , ExtractForall(..)
+    -- ** Typeclasses
+  , Headedness(..)
+    -- ** Row
+  , row
+  , rowMonadic
+  , rowMonadic_
+  , rowMonadicWith
+  , rowMonoidal
+  , rowMonoidalHeader
+    -- ** Header
+  , header
+  , headerMonadic
+  , headerMonadic_
+  , headerMonadicGeneral
+  , headerMonadicGeneral_
+  , headerMonoidalGeneral
+  , headerMonoidalFull
+    -- ** Other
+  , bothMonadic_
+  , sizeColumns
+    -- * Cornice
+    -- ** Types
+  , Cornice(..)
+  , AnnotatedCornice(..)
+  , OneCornice(..)
+  , Pillar(..)
+  , ToEmptyCornice(..)
+  , Fascia(..)
+    -- ** Encoding
+  , annotate
+  , annotateFinely
+  , size
+  , endow
+  , discard
+  , headersMonoidal
+  , uncapAnnotated
+  ) where
+
+import Data.Vector (Vector)
+import Data.Foldable
+import Control.Monad.ST (ST,runST)
+import Data.Monoid
+import Data.Functor.Contravariant (Contravariant(..))
+import Data.Profunctor (Profunctor(..))
+import Data.Semigroup (Semigroup)
+import Data.List.NonEmpty (NonEmpty((:|)))
+import Data.Foldable (toList)
+import qualified Data.Semigroup as Semigroup
+import qualified Data.Vector as Vector
+import qualified Data.Vector as V
+import qualified Data.Vector.Unboxed.Mutable as MVU
+import qualified Data.Vector.Unboxed as VU
+import qualified Data.Vector as V
+import qualified Data.Vector as Vector
+import qualified Data.Vector.Generic as GV
+
+-- | Consider providing a variant the produces a list
+-- instead. It may allow more things to get inlined
+-- in to a loop.
+row :: (c1 -> c2) -> Colonnade f a c1 -> a -> Vector c2
+row g (Colonnade v) a = flip Vector.map v $
+  \(OneColonnade _ encode) -> g (encode a)
+
+bothMonadic_ :: Monad m
+  => Colonnade Headed a c
+  -> (c -> c -> m b)
+  -> a
+  -> m ()
+bothMonadic_ (Colonnade v) g a =
+  forM_ v $ \(OneColonnade (Headed h) encode) -> g h (encode a)
+
+rowMonadic :: 
+  (Monad m, Monoid b)
+  => Colonnade f a c
+  -> (c -> m b)
+  -> a
+  -> m b
+rowMonadic (Colonnade v) g a =
+  flip foldlMapM v
+  $ \e -> g (oneColonnadeEncode e a)
+
+rowMonadic_ :: 
+     Monad m
+  => Colonnade f a c
+  -> (c -> m b)
+  -> a
+  -> m ()
+rowMonadic_ (Colonnade v) g a =
+  forM_ v $ \e -> g (oneColonnadeEncode e a)
+
+rowMonoidal ::
+     Monoid m
+  => Colonnade h a c
+  -> (c -> m)
+  -> a
+  -> m
+rowMonoidal (Colonnade v) g a =
+  foldMap (\(OneColonnade _ encode) -> g (encode a)) v
+
+rowMonoidalHeader ::
+     Monoid m
+  => Colonnade h a c
+  -> (h c -> c -> m)
+  -> a
+  -> m
+rowMonoidalHeader (Colonnade v) g a =
+  foldMap (\(OneColonnade h encode) -> g h (encode a)) v
+
+rowUpdateSize ::
+     (c -> Int) -- ^ Get size from content
+  -> MutableSizedColonnade s h a c
+  -> a
+  -> ST s ()
+rowUpdateSize toSize (MutableSizedColonnade v mv) a = if MVU.length mv /= V.length v
+  then error "rowMonoidalSize: vector sizes mismatched"
+  else V.imapM_ (\ix (OneColonnade _ encode) ->
+      MVU.modify mv (\oldSize -> max oldSize (toSize (encode a))) ix
+    ) v
+
+headerUpdateSize :: Foldable h
+  => (c -> Int) -- ^ Get size from content
+  -> MutableSizedColonnade s h a c
+  -> ST s ()
+headerUpdateSize toSize (MutableSizedColonnade v mv) = if MVU.length mv /= V.length v
+  then error "rowMonoidalSize: vector sizes mismatched"
+  else V.imapM_ (\ix (OneColonnade h _) -> 
+      MVU.modify mv (\oldSize -> max oldSize (foldl' (\sz c -> max sz (toSize c)) 0 h)) ix
+    ) v
+
+sizeColumns :: (Foldable f, Foldable h)
+  => (c -> Int) -- ^ Get size from content
+  -> f a
+  -> Colonnade h a c
+  -> Colonnade (Sized (Maybe Int) h) a c
+sizeColumns toSize rows colonnade = runST $ do
+  mcol <- newMutableSizedColonnade colonnade
+  headerUpdateSize toSize mcol 
+  mapM_ (rowUpdateSize toSize mcol) rows
+  freezeMutableSizedColonnade mcol
+
+newMutableSizedColonnade :: Colonnade h a c -> ST s (MutableSizedColonnade s h a c)
+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 (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 (Just sz) h) enc)
+        $ V.zip v (GV.convert sizeVec)
+
+rowMonadicWith :: 
+  (Monad m)
+  => b
+  -> (b -> b -> b)
+  -> Colonnade f a c
+  -> (c -> m b)
+  -> a
+  -> m b
+rowMonadicWith bempty bappend (Colonnade v) g a =
+  foldlM (\bl e -> do
+    br <- g (oneColonnadeEncode e a)
+    return (bappend bl br)
+  ) bempty v
+
+header :: (c1 -> c2) -> Colonnade Headed a c1 -> Vector c2
+header g (Colonnade v) =
+  Vector.map (g . getHeaded . oneColonnadeHead) v
+
+-- | This function is a helper for abusing 'Foldable' to optionally
+--   render a header. Its future is uncertain.
+headerMonadicGeneral :: (Monad m, Monoid b, Foldable h)
+  => Colonnade h a c
+  -> (c -> m b)
+  -> m b
+headerMonadicGeneral (Colonnade v) g = id
+  $ fmap (mconcat . Vector.toList)
+  $ Vector.mapM (foldlMapM g . oneColonnadeHead) v
+
+headerMonadic :: 
+     (Monad m, Monoid b)
+  => Colonnade Headed a c
+  -> (c -> m b)
+  -> m b
+headerMonadic (Colonnade v) g =
+  fmap (mconcat . Vector.toList) $ Vector.mapM (g . getHeaded . oneColonnadeHead) v
+
+headerMonadicGeneral_ :: 
+     (Monad m, Headedness h)
+  => Colonnade h a c
+  -> (c -> m b)
+  -> m ()
+headerMonadicGeneral_ (Colonnade v) g = case headednessExtract of
+  Nothing -> return ()
+  Just f -> Vector.mapM_ (g . f . oneColonnadeHead) v
+
+headerMonoidalGeneral ::
+     (Monoid m, Foldable h)
+  => Colonnade h a c
+  -> (c -> m)
+  -> m
+headerMonoidalGeneral (Colonnade v) g =
+  foldMap (foldMap g . oneColonnadeHead) v
+
+headerMonoidalFull ::
+     Monoid m
+  => Colonnade h a c
+  -> (h c -> m)
+  -> m
+headerMonoidalFull (Colonnade v) g = foldMap (g . oneColonnadeHead) v
+
+headerMonadic_ ::
+     (Monad m)
+  => Colonnade Headed a c
+  -> (c -> m b)
+  -> m ()
+headerMonadic_ (Colonnade v) g = Vector.mapM_ (g . getHeaded . oneColonnadeHead) v
+
+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 h p a c -> Colonnade h a c
+discard = go where
+  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 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 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 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 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 Headed p a c -> AnnotatedCornice (Maybe Int) Headed p a c
+annotate = go where
+  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 (Just 1)) c)
+  go (CorniceCap children) =
+    let annChildren = fmap (mapOneCorniceBody go) children
+     in AnnotatedCorniceCap 
+          ( ( ( V.foldl' (combineJustInt (+))
+              ) Nothing . V.map (size . oneCorniceBody)
+            ) annChildren
+          )
+          annChildren
+
+combineJustInt :: (Int -> Int -> Int) -> Maybe Int -> Maybe Int -> Maybe Int
+combineJustInt f acc el = case acc of
+  Nothing -> case el of 
+    Nothing -> Nothing
+    Just i -> Just i
+  Just i -> case el of
+    Nothing -> Just i
+    Just j -> Just (f i j)
+
+mapJustInt :: (Int -> Int) -> Maybe Int -> Maybe Int
+mapJustInt _ Nothing = Nothing
+mapJustInt f (Just i) = Just (f i)
+
+annotateFinely :: Foldable f
+  => (Int -> Int -> Int) -- ^ fold function
+  -> (Int -> Int) -- ^ finalize
+  -> (c -> Int) -- ^ Get size from content
+  -> f a
+  -> Cornice Headed 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
+  freezeMutableSizedCornice g finish m
+
+sizeColonnades :: forall f s p a c.
+     Foldable f
+  => (c -> Int) -- ^ Get size from content
+  -> f a
+  -> MutableSizedCornice s p a c 
+  -> ST s ()
+sizeColonnades toSize xs cornice = do
+  goHeader cornice
+  mapM_ (goRow cornice) xs 
+  where
+  goRow :: forall p'. MutableSizedCornice s p' a c -> a -> ST s ()
+  goRow (MutableSizedCorniceBase c) a = rowUpdateSize toSize c a
+  goRow (MutableSizedCorniceCap children) a = mapM_ (flip goRow a . oneCorniceBody) children
+  goHeader :: forall p'. MutableSizedCornice s p' a c -> ST s ()
+  goHeader (MutableSizedCorniceBase c) = headerUpdateSize toSize c
+  goHeader (MutableSizedCorniceCap children) = mapM_ (goHeader . oneCorniceBody) children
+  
+freezeMutableSizedCornice :: forall s p a c.
+     (Int -> Int -> Int) -- ^ fold function
+  -> (Int -> Int) -- ^ finalize
+  -> MutableSizedCornice s 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 (Maybe Int) Headed p' a' c')
+  go (MutableSizedCorniceBase msc) = do
+    szCol <- freezeMutableSizedColonnade msc
+    let sz = 
+          ( mapJustInt finish 
+          . V.foldl' (combineJustInt step) Nothing 
+          . V.map (sizedSize . oneColonnadeHead)
+          ) (getColonnade szCol)
+    return (AnnotatedCorniceBase sz szCol)
+  go (MutableSizedCorniceCap v1) = do
+    v2 <- V.mapM (traverseOneCorniceBody go) v1
+    let sz = 
+          ( mapJustInt finish 
+          . V.foldl' (combineJustInt step) Nothing 
+          . V.map (size . oneCorniceBody)
+          ) v2
+    return $ AnnotatedCorniceCap sz v2
+
+newMutableSizedCornice :: forall s p a c.
+     Cornice Headed p a c 
+  -> ST s (MutableSizedCornice s p a c)
+newMutableSizedCornice = go where
+  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)
+    
+traverseOneCorniceBody :: Monad m => (k p a c -> m (j p a c)) -> OneCornice k p a c -> m (OneCornice j p a c)
+traverseOneCorniceBody f (OneCornice h b) = fmap (OneCornice h) (f b)
+
+mapHeadedness :: (forall x. h x -> h' x) -> Colonnade h a c -> Colonnade h' a c
+mapHeadedness f (Colonnade v) = 
+  Colonnade (V.map (\(OneColonnade h c) -> OneColonnade (f h) c) v)
+
+
+-- | This is an O(1) operation, sort of
+size :: AnnotatedCornice sz h p a c -> sz
+size x = case x of
+  AnnotatedCorniceBase m _ -> m
+  AnnotatedCorniceCap sz _ -> sz
+
+mapOneCorniceBody :: (forall p' a' c'. k p' a' c' -> j p' a' c') -> OneCornice k p a c -> OneCornice j p a c
+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 sz r m c p a h.
+     (Monoid m, Headedness h)
+  => Maybe (Fascia p r, r -> m -> m) -- ^ Apply the Fascia header row content
+  -> [(sz -> c -> m, m -> m)] -- ^ Build content from cell content and size
+  -> AnnotatedCornice sz h p a c
+  -> m
+headersMonoidal wrapRow fromContentList = go wrapRow
+  where
+  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 case headednessExtract of
+          Just unhead -> g $ foldMap (\(fromContent,wrap) -> wrap 
+            (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) -> 
+          (fromContent (size b) h)) v)) fromContentList)
+          <> case ef of
+               Nothing -> case flattenAnnotated v of
+                 Nothing -> mempty
+                 Just annCoreNext -> go Nothing annCoreNext
+               Just (FasciaCap _ fn, f) -> case flattenAnnotated v of
+                 Nothing -> mempty
+                 Just annCoreNext -> go (Just (fn,f)) annCoreNext
+
+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 ::
+     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 ::
+     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 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
+  MutableSizedCorniceBase :: 
+       {-# UNPACK #-} !(MutableSizedColonnade s Headed a c) 
+    -> MutableSizedCornice s Base a c
+  MutableSizedCorniceCap :: 
+       {-# UNPACK #-} !(Vector (OneCornice (MutableSizedCornice s) p a c))
+    -> MutableSizedCornice s (Cap p) a c
+
+data MutableSizedColonnade s h a c = MutableSizedColonnade
+  { _mutableSizedColonnadeColumns :: {-# UNPACK #-} !(Vector (OneColonnade h a c))
+  , _mutableSizedColonnadeSizes :: {-# UNPACK #-} !(MVU.STVector s Int)
+  }
+
+-- | As the first argument to the 'Colonnade' type 
+--   constructor, this indictates that the columnar encoding has 
+--   a header. This type is isomorphic to 'Identity' but is 
+--   given a new name to clarify its intent:
+--
+-- > example :: Colonnade Headed Foo Text
+--
+--   The term @example@ represents a columnar encoding of @Foo@
+--   in which the columns have headings.
+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 
+--   given a new name to clarify its intent:
+--
+-- > example :: Colonnade Headless Foo Text
+--
+--   The term @example@ represents a columnar encoding of @Foo@
+--   in which the columns do not have headings.
+data Headless a = Headless
+  deriving (Eq,Ord,Functor,Show,Read,Foldable)
+
+instance Applicative Headless where
+  pure _ = Headless
+  Headless <*> Headless = Headless
+
+data Sized sz f a = Sized
+  { sizedSize :: !sz
+  , sizedContent :: !(f a)
+  } deriving (Functor, Foldable)
+
+instance Contravariant Headless where
+  contramap _ Headless = Headless
+
+-- | Encodes a header and a cell.
+data OneColonnade h a c = OneColonnade
+  { oneColonnadeHead   :: !(h c)
+  , oneColonnadeEncode :: !(a -> c)
+  } deriving (Functor)
+
+instance Functor h => Profunctor (OneColonnade h) where
+  rmap = fmap
+  lmap f (OneColonnade h e) = OneColonnade h (e . f)
+
+-- | An columnar encoding of @a@. The type variable @h@ determines what
+--   is present in each column in the header row. It is typically instantiated
+--   to 'Headed' and occasionally to 'Headless'. There is nothing that
+--   restricts it to these two types, although they satisfy the majority
+--   of use cases. The type variable @c@ is the content type. This can
+--   be @Text@, @String@, or @ByteString@. In the companion libraries
+--   @reflex-dom-colonnade@ and @yesod-colonnade@, additional types
+--   that represent HTML with element attributes are provided that serve
+--   as the content type. Presented more visually:
+--
+-- >             +---- Value consumed to build a row
+-- >             |
+-- >             v
+-- > Colonnade h a c
+-- >           ^   ^
+-- >           |   |
+-- >           |   +-- Content (Text, ByteString, Html, etc.)
+-- >           |
+-- >           +------ Headedness (Headed or Headless)
+--
+--   Internally, a 'Colonnade' is represented as a 'Vector' of individual
+--   column encodings. It is possible to use any collection type with
+--   'Alternative' and 'Foldable' instances. However, 'Vector' was chosen to
+--   optimize the data structure for the use case of building the structure
+--   once and then folding over it many times. It is recommended that
+--   'Colonnade's are defined at the top-level so that GHC avoids reconstructing
+--   them every time they are used.
+newtype Colonnade h a c = Colonnade
+  { getColonnade :: Vector (OneColonnade h a c)
+  } deriving (Monoid,Functor)
+
+instance Functor h => Profunctor (Colonnade h) where
+  rmap = fmap
+  lmap f (Colonnade v) = Colonnade (Vector.map (lmap f) v)
+
+instance Semigroup (Colonnade h a c) where
+  Colonnade a <> Colonnade b = Colonnade (a Vector.++ b)
+  sconcat xs = Colonnade (vectorConcatNE (fmap getColonnade xs))
+
+-- | Isomorphic to the natural numbers. Only the promoted version of
+--   this type is used.
+data Pillar = Cap !Pillar | Base
+
+class ToEmptyCornice (p :: Pillar) where
+  toEmptyCornice :: Cornice h p a c
+
+instance ToEmptyCornice Base where
+  toEmptyCornice = CorniceBase mempty
+
+instance ToEmptyCornice (Cap p) where
+  toEmptyCornice = CorniceCap Vector.empty
+
+data Fascia (p :: Pillar) r where
+  FasciaBase :: !r -> Fascia Base r
+  FasciaCap :: !r -> Fascia p r -> Fascia (Cap p) r
+
+data OneCornice k (p :: Pillar) a c = OneCornice
+  { oneCorniceHead :: !c
+  , oneCorniceBody :: !(k p a c)
+  } deriving (Functor)
+
+data Cornice h (p :: Pillar) a c where
+  CorniceBase :: !(Colonnade h a c) -> Cornice h Base a c
+  CorniceCap :: {-# UNPACK #-} !(Vector (OneCornice (Cornice h) p a c)) -> Cornice h (Cap p) a c
+
+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 h p a c) where
+  mempty = toEmptyCornice
+  mappend = (Semigroup.<>)
+  mconcat xs1 = case xs1 of
+    [] -> toEmptyCornice
+    x : xs2 -> Semigroup.sconcat (x :| xs2)
+
+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 h (Cap p) a c -> Vector (OneCornice (Cornice h) p a c)
+getCorniceCap (CorniceCap c) = c
+
+data AnnotatedCornice sz h (p :: Pillar) a c where
+  AnnotatedCorniceBase ::
+       !sz
+    -> !(Colonnade (Sized sz h) a c)
+    -> AnnotatedCornice sz h Base a c
+  AnnotatedCorniceCap :: 
+       !sz
+    -> {-# UNPACK #-} !(Vector (OneCornice (AnnotatedCornice sz h) 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 
+--   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 }
+

colonnade/src/Colonnade/Encoding.hs

@@ -1,344 +0,0 @@
--- | Build backend-agnostic columnar encodings that can be used to visualize data.
-
-module Colonnade.Encoding
-  ( -- * Example
-    -- $setup
-    -- * Create
-    headed
-  , headless
-  , singleton
-    -- * Transform
-  , fromMaybe
-  , columns
-  , bool
-  , replaceWhen
-  , mapContent
-    -- * Render
-  , runRow
-  , runRowMonadic
-  , runRowMonadic_
-  , runRowMonadicWith
-  , runHeader
-  , runHeaderMonadic
-  , runHeaderMonadic_
-  , runHeaderMonadicGeneral
-  , runHeaderMonadicGeneral_
-  , runBothMonadic_
-    -- * Ascii Table
-  , ascii
-  ) where
-
-import Colonnade.Types
-import Data.Vector (Vector)
-import Data.Foldable
-import Data.Monoid (Endo(..))
-import Control.Monad
-import Data.Functor.Contravariant
-import qualified Data.Bool
-import qualified Data.Maybe
-import qualified Data.List as List
-import qualified Data.Vector as Vector
-import qualified Colonnade.Internal as Internal
-
--- $setup
---
--- First, let\'s bring in some neccessary imports that will be
--- used for the remainder of the examples in the docs:
---
--- >>> import Data.Monoid (mconcat,(<>))
--- >>> import Data.Functor.Contravariant (contramap)
---
--- Assume that the data we wish to encode is:
---
--- >>> data Color = Red | Green | Blue deriving (Show,Eq)
--- >>> data Person = Person { name :: String, age :: Int }
--- >>> data House = House { color :: Color, price :: Int }
---
--- One potential columnar encoding of a @Person@ would be:
---
--- >>> :{
--- let encodingPerson :: Encoding Headed String Person
---     encodingPerson = mconcat
---       [ headed "Name" name
---       , headed "Age" (show . age)
---       ]
--- :}
---
--- The type signature on @basicPersonEncoding@ is not neccessary
--- but is included for clarity. We can feed data into this encoding
--- to build a table:
---
--- >>> let people = [Person "David" 63, Person "Ava" 34, Person "Sonia" 12]
--- >>> putStr (ascii encodingPerson people)
--- +-------+-----+
--- | Name  | Age |
--- +-------+-----+
--- | David | 63  |
--- | Ava   | 34  |
--- | Sonia | 12  |
--- +-------+-----+
---
--- Similarly, we can build a table of houses with:
---
--- >>> let showDollar = (('$':) . show) :: Int -> String
--- >>> :{
--- let encodingHouse :: Encoding Headed String House
---     encodingHouse = mconcat
---       [ headed "Color" (show . color)
---       , headed "Price" (showDollar . price)
---       ]
--- :}
---
--- >>> let houses = [House Green 170000, House Blue 115000, House Green 150000]
--- >>> putStr (ascii encodingHouse houses)
--- +-------+---------+
--- | Color | Price   |
--- +-------+---------+
--- | Green | $170000 |
--- | Blue  | $115000 |
--- | Green | $150000 |
--- +-------+---------+
-
-
--- | A single column with a header.
-headed :: c -> (a -> c) -> Encoding Headed c a
-headed h = singleton (Headed h)
-
--- | A single column without a header.
-headless :: (a -> c) -> Encoding Headless c a
-headless = singleton Headless
-
--- | A single column with any kind of header. This is not typically needed.
-singleton :: f c -> (a -> c) -> Encoding f c a
-singleton h = Encoding . Vector.singleton . OneEncoding h
-
--- | Lift a column over a 'Maybe'. For example, if some people
---   have houses and some do not, the data that pairs them together
---   could be represented as:
---
--- >>> :{
--- >>> let owners :: [(Person,Maybe House)]
--- >>>     owners =
--- >>>       [ (Person "Jordan" 18, Nothing)
--- >>>       , (Person "Ruth" 25, Just (House Red 125000))
--- >>>       , (Person "Sonia" 12, Just (House Green 145000))
--- >>>       ]
--- >>> :}
---
--- The column encodings defined earlier can be reused with
--- the help of 'fromMaybe':
---
--- >>> :{
--- >>> let encodingOwners :: Encoding Headed String (Person,Maybe House)
--- >>>     encodingOwners = mconcat
--- >>>       [ contramap fst encodingPerson
--- >>>       , contramap snd (fromMaybe "" encodingHouse)
--- >>>       ]
--- >>> :}
---
--- >>> putStr (ascii encodingOwners owners)
--- +--------+-----+-------+---------+
--- | Name   | Age | Color | Price   |
--- +--------+-----+-------+---------+
--- | Jordan | 18  |       |         |
--- | Ruth   | 25  | Red   | $125000 |
--- | Sonia  | 12  | Green | $145000 |
--- +--------+-----+-------+---------+
-fromMaybe :: c -> Encoding f c a -> Encoding f c (Maybe a)
-fromMaybe c (Encoding v) = Encoding $ flip Vector.map v $
-  \(OneEncoding h encode) -> OneEncoding h (maybe c encode)
-
--- | Convert a collection of @b@ values into a columnar encoding of
---   the same size. Suppose we decide to show a house\'s color
---   by putting a check mark in the column corresponding to
---   the color instead of by writing out the name of the color:
---
--- >>> let allColors = [Red,Green,Blue]
--- >>> let encColor = columns (\c1 c2 -> if c1 == c2 then "✓" else "") (Headed . show) allColors
--- >>> :t encColor
--- encColor :: Encoding Headed [Char] Color
--- >>> let encHouse = headed "Price" (showDollar . price) <> contramap color encColor
--- >>> :t encHouse
--- encHouse :: Encoding Headed [Char] House
--- >>> putStr (ascii encHouse houses)
--- +---------+-----+-------+------+
--- | Price   | Red | Green | Blue |
--- +---------+-----+-------+------+
--- | $170000 |     | ✓     |      |
--- | $115000 |     |       | ✓    |
--- | $150000 |     | ✓     |      |
--- +---------+-----+-------+------+
-columns :: Foldable g
-  => (b -> a -> c) -- ^ Cell content function
-  -> (b -> f c) -- ^ Header content function
-  -> g b -- ^ Basis for column encodings
-  -> Encoding f c a
-columns getCell getHeader = id
-  . Encoding
-  . Vector.map (\b -> OneEncoding (getHeader b) (getCell b))
-  . Vector.fromList
-  . toList
-
-bool ::
-     f c -- ^ Heading
-  -> (a -> Bool) -- ^ Predicate
-  -> (a -> c) -- ^ Contents when predicate is false
-  -> (a -> c) -- ^ Contents when predicate is true
-  -> Encoding f c a
-bool h p onTrue onFalse = singleton h (Data.Bool.bool <$> onFalse <*> onTrue <*> p)
-
-replaceWhen ::
-     c
-  -> (a -> Bool)
-  -> Encoding f c a
-  -> Encoding f c a
-replaceWhen newContent p (Encoding v) = Encoding
-  ( Vector.map
-    (\(OneEncoding h encode) -> OneEncoding h $ \a ->
-      if p a then newContent else encode a
-    ) v
-  )
-
--- | 'Encoding' is covariant in its content type. Consequently, it can be
---   mapped over. There is no standard typeclass for types that are covariant
---   in their second-to-last argument, so this function is provided for
---   situations that require this.
-mapContent :: Functor f => (c1 -> c2) -> Encoding f c1 a -> Encoding f c2 a
-mapContent f (Encoding v) = Encoding
-  $ Vector.map (\(OneEncoding h c) -> (OneEncoding (fmap f h) (f . c))) v
-
--- | Consider providing a variant the produces a list
--- instead. It may allow more things to get inlined
--- in to a loop.
-runRow :: (c1 -> c2) -> Encoding f c1 a -> a -> Vector c2
-runRow g (Encoding v) a = flip Vector.map v $
-  \(OneEncoding _ encode) -> g (encode a)
-
-runBothMonadic_ :: Monad m
-  => Encoding Headed content a
-  -> (content -> content -> m b)
-  -> a
-  -> m ()
-runBothMonadic_ (Encoding v) g a =
-  forM_ v $ \(OneEncoding (Headed h) encode) -> g h (encode a)
-
-runRowMonadic :: (Monad m, Monoid b)
-              => Encoding f content a
-              -> (content -> m b)
-              -> a
-              -> m b
-runRowMonadic (Encoding v) g a =
-  flip Internal.foldlMapM v
-  $ \e -> g (oneEncodingEncode e a)
-
-runRowMonadic_ :: Monad m
-  => Encoding f content a
-  -> (content -> m b)
-  -> a
-  -> m ()
-runRowMonadic_ (Encoding v) g a =
-  forM_ v $ \e -> g (oneEncodingEncode e a)
-
-runRowMonadicWith :: (Monad m)
-              => b
-              -> (b -> b -> b)
-              -> Encoding f content a
-              -> (content -> m b)
-              -> a
-              -> m b
-runRowMonadicWith bempty bappend (Encoding v) g a =
-  foldlM (\bl e -> do
-    br <- g (oneEncodingEncode e a)
-    return (bappend bl br)
-  ) bempty v
-
-runHeader :: (c1 -> c2) -> Encoding Headed c1 a -> Vector c2
-runHeader g (Encoding v) =
-  Vector.map (g . getHeaded . oneEncodingHead) v
-
--- | This function is a helper for abusing 'Foldable' to optionally
---   render a header. Its future is uncertain.
-runHeaderMonadicGeneral :: (Monad m, Monoid b, Foldable h)
-  => Encoding h content a
-  -> (content -> m b)
-  -> m b
-runHeaderMonadicGeneral (Encoding v) g = id
-  $ fmap (mconcat . Vector.toList)
-  $ Vector.mapM (Internal.foldlMapM g . oneEncodingHead) v
-
-runHeaderMonadic :: (Monad m, Monoid b)
-                 => Encoding Headed content a
-                 -> (content -> m b)
-                 -> m b
-runHeaderMonadic (Encoding v) g =
-  fmap (mconcat . Vector.toList) $ Vector.mapM (g . getHeaded . oneEncodingHead) v
-
-runHeaderMonadicGeneral_ :: (Monad m, Monoid b, Foldable h)
-  => Encoding h content a
-  -> (content -> m b)
-  -> m ()
-runHeaderMonadicGeneral_ (Encoding v) g =
-  Vector.mapM_ (Internal.foldlMapM g . oneEncodingHead) v
-
-runHeaderMonadic_ ::
-     (Monad m)
-  => Encoding Headed content a
-  -> (content -> m b)
-  -> m ()
-runHeaderMonadic_ (Encoding v) g = Vector.mapM_ (g . getHeaded . oneEncodingHead) v
-
--- | Render a collection of rows as an ascii table. The table\'s columns are
--- specified by the given 'Encoding'. This implementation is inefficient and
--- does not provide any wrapping behavior. It is provided so that users can
--- try out @colonnade@ in ghci and so that @doctest@ can verify examples
--- code in the haddocks.
-ascii :: Foldable f
-  => Encoding Headed String a -- ^ columnar encoding
-  -> f a -- ^ rows
-  -> String
-ascii enc xs =
-  let theHeader :: [(Int,String)]
-      theHeader = (zip (enumFrom 0) . map (\s -> " " ++ s ++ " ")) (toList (runHeader id enc))
-      theBody :: [[(Int,String)]]
-      theBody = map (zip (enumFrom 0) . map (\s -> " " ++ s ++ " ") . toList . runRow id enc) (toList xs)
-      sizes :: [Int]
-      sizes = ($ replicate (length theHeader) 1) $ appEndo $ mconcat
-        [ foldMap (\(i,str) -> Endo (replaceAt i (length str))) theHeader
-        , (foldMap . foldMap) (\(i,str) -> Endo (replaceAt i (length str))) theBody
-        ]
-      paddedHeader :: [String]
-      paddedHeader = map (\(i,str) -> rightPad (atDef 1 sizes i) ' ' str) theHeader
-      paddedBody :: [[String]]
-      paddedBody = (map . map) (\(i,str) -> rightPad (atDef 1 sizes i) ' ' str) theBody
-      divider :: String
-      divider = "+" ++ join (List.intersperse "+" (map (\i -> replicate i '-') sizes)) ++ "+"
-      headerStr :: String
-      headerStr = "|" ++ join (List.intersperse "|" paddedHeader) ++ "|"
-      bodyStr :: String
-      bodyStr = List.unlines (map ((\s -> "|" ++ s ++ "|") . join . List.intersperse "|") paddedBody)
-   in divider ++ "\n" ++ headerStr
-              ++ "\n" ++ divider
-              ++ "\n" ++ bodyStr ++ divider ++ "\n"
-
-
--- this has no effect if the index is out of bounds
-replaceAt :: Ord a => Int -> a -> [a] -> [a]
-replaceAt _ _ [] = []
-replaceAt n v (a:as) = if n > 0
-  then a : replaceAt (n - 1) v as
-  else (max v a) : as
-
-rightPad :: Int -> a -> [a] -> [a]
-rightPad m a xs = take m $ xs ++ repeat a
-
-atDef :: a -> [a] -> Int -> a
-atDef def = Data.Maybe.fromMaybe def .^ atMay where
-  (.^) f g x1 x2 = f (g x1 x2)
-  atMay = eitherToMaybe .^ at_
-  eitherToMaybe = either (const Nothing) Just
-  at_ xs o | o < 0 = Left $ "index must not be negative, index=" ++ show o
-           | otherwise = f o xs
-      where f 0 (z:_) = Right z
-            f i (_:zs) = f (i-1) zs
-            f i [] = Left $ "index too large, index=" ++ show o ++ ", length=" ++ show (o-i)
-

colonnade/src/Colonnade/Encoding/ByteString/Char8.hs

@@ -1,24 +0,0 @@
-module Colonnade.Encoding.ByteString.Char8 where
-
-import Data.ByteString (ByteString)
-import qualified Data.ByteString as ByteString
-import qualified Data.ByteString.Char8 as BC8
-import qualified Data.ByteString.Builder    as Builder
-import qualified Data.ByteString.Lazy       as LByteString
-
-char :: Char -> ByteString
-char = BC8.singleton
-
-int :: Int -> ByteString
-int = LByteString.toStrict
-    . Builder.toLazyByteString 
-    . Builder.intDec
-
-bool :: Bool -> ByteString
-bool x = case x of
-  True -> BC8.pack "true"
-  False -> BC8.pack "false"
-
-byteString :: ByteString -> ByteString
-byteString = id
-

colonnade/src/Colonnade/Encoding/Text.hs

@@ -1,24 +0,0 @@
-module Colonnade.Encoding.Text where
-
-import Data.Text
-import qualified Data.Text as Text
-import qualified Data.Text.Lazy as LText
-import qualified Data.Text.Lazy.Builder as Builder
-import qualified Data.Text.Lazy.Builder.Int as Builder
-
-char :: Char -> Text
-char = Text.singleton
-
-int :: Int -> Text
-int = LText.toStrict
-    . Builder.toLazyText
-    . Builder.decimal
-
-text :: Text -> Text
-text = id
-
-bool :: Bool -> Text
-bool x = case x of
-  True -> Text.pack "true"
-  False -> Text.pack "false"
-

colonnade/src/Colonnade/Internal.hs

@@ -1,23 +0,0 @@
-{-# LANGUAGE DeriveFunctor #-}
-module Colonnade.Internal where
-
-import Data.Foldable (foldrM,foldlM)
-
-newtype EitherWrap a b = EitherWrap
-  { getEitherWrap :: Either a b
-  } deriving (Functor)
-
-instance Monoid a => Applicative (EitherWrap a) where
-  pure = EitherWrap . Right
-  EitherWrap (Left a1) <*> EitherWrap (Left a2) = EitherWrap (Left (mappend a1 a2))
-  EitherWrap (Left a1) <*> EitherWrap (Right _) = EitherWrap (Left a1)
-  EitherWrap (Right _) <*> EitherWrap (Left a2) = EitherWrap (Left a2)
-  EitherWrap (Right f) <*> EitherWrap (Right b) = EitherWrap (Right (f b))
-
-mapLeft :: (a -> b) -> Either a c -> Either b c
-mapLeft _ (Right a) = Right a
-mapLeft f (Left a) = Left (f a)
-
-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
-

colonnade/src/Colonnade/Types.hs

@@ -1,152 +0,0 @@
-{-# LANGUAGE DeriveFunctor              #-}
-{-# LANGUAGE DeriveFoldable             #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE GADTs                      #-}
-module Colonnade.Types
-  ( Encoding(..)
-  , Decoding(..)
-  , OneEncoding(..)
-  , Headed(..)
-  , Headless(..)
-  , Indexed(..)
-  , HeadingErrors(..)
-  , DecodingCellError(..)
-  , DecodingRowError(..)
-  , DecodingCellErrors(..)
-  , RowError(..)
-  ) where
-
-import Data.Vector (Vector)
-import Data.Functor.Contravariant (Contravariant(..))
-import Data.Functor.Contravariant.Divisible (Divisible(..))
-import Control.Exception (Exception)
-import Data.Typeable (Typeable)
-import qualified Data.Vector as Vector
-
--- | This type is isomorphic to 'Identity'.
-newtype Headed a = Headed { getHeaded :: a }
-  deriving (Eq,Ord,Functor,Show,Read,Foldable)
-
--- | This type is isomorphic to 'Proxy'
-data Headless a = Headless
-  deriving (Eq,Ord,Functor,Show,Read,Foldable)
-
-data Indexed f a = Indexed
-  { indexedIndex :: !Int
-  , indexedHeading :: !(f a)
-  } deriving (Eq,Ord,Functor,Show,Read)
-
-data HeadingErrors content = HeadingErrors
-  { headingErrorsMissing   :: Vector content       -- ^ headers that were missing
-  , headingErrorsDuplicate :: Vector (content,Int) -- ^ headers that occurred more than once
-  } deriving (Show,Read,Eq)
-
-instance (Show content, Typeable content) => Exception (HeadingErrors content)
-
-instance Monoid (HeadingErrors content) where
-  mempty = HeadingErrors Vector.empty Vector.empty
-  mappend (HeadingErrors a1 b1) (HeadingErrors a2 b2) = HeadingErrors
-    (a1 Vector.++ a2) (b1 Vector.++ b2)
-
-data DecodingCellError f content = DecodingCellError
-  { decodingCellErrorContent :: !content
-  , decodingCellErrorHeader  :: !(Indexed f content)
-  , decodingCellErrorMessage :: !String
-  } deriving (Show,Read,Eq)
-
--- instance (Show (f content), Typeable content) => Exception (DecodingError f content)
-
-newtype DecodingCellErrors f content = DecodingCellErrors
-  { getDecodingCellErrors :: Vector (DecodingCellError f content)
-  } deriving (Monoid,Show,Read,Eq)
-
--- newtype ParseRowError = ParseRowError String
-
--- TODO: rewrite the instances for this by hand. They
--- currently use FlexibleContexts.
-data DecodingRowError f content = DecodingRowError
-  { decodingRowErrorRow   :: !Int
-  , decodingRowErrorError :: !(RowError f content)
-  } deriving (Show,Read,Eq)
-
--- TODO: rewrite the instances for this by hand. They
--- currently use FlexibleContexts.
-data RowError f content
-  = RowErrorParse !String -- ^ Error occurred parsing the document into cells
-  | RowErrorDecode !(DecodingCellErrors f content) -- ^ Error decoding the content
-  | RowErrorSize !Int !Int -- ^ Wrong number of cells in the row
-  | RowErrorHeading !(HeadingErrors content)
-  | RowErrorMinSize !Int !Int
-  | RowErrorMalformed !String -- ^ Error decoding unicode content
-  deriving (Show,Read,Eq)
-
--- instance (Show (f content), Typeable content) => Exception (DecodingErrors f content)
-
-instance Contravariant Headless where
-  contramap _ Headless = Headless
-
--- | This just actually a specialization of the free applicative.
---   Check out @Control.Applicative.Free@ in the @free@ library to
---   learn more about this. The meanings of the fields are documented
---   slightly more in the source code. Unfortunately, haddock does not
---   play nicely with GADTs.
-data Decoding f content a where
-  DecodingPure :: !a -- function
-               -> Decoding f content a
-  DecodingAp :: !(f content) -- header
-             -> !(content -> Either String a) -- decoding function
-             -> !(Decoding f content (a -> b)) -- next decoding
-             -> Decoding f content b
-
-instance Functor (Decoding f content) where
-  fmap f (DecodingPure a) = DecodingPure (f a)
-  fmap f (DecodingAp h c apNext) = DecodingAp h c ((f .) <$> apNext)
-
-instance Applicative (Decoding f content) where
-  pure = DecodingPure
-  DecodingPure f <*> y = fmap f y
-  DecodingAp h c y <*> z = DecodingAp h c (flip <$> y <*> z)
-
--- | Encodes a header and a cell.
-data OneEncoding f content a = OneEncoding
-  { oneEncodingHead   :: !(f content)
-  , oneEncodingEncode :: !(a -> content)
-  }
-
-instance Contravariant (OneEncoding f content) where
-  contramap f (OneEncoding h e) = OneEncoding h (e . f)
-
--- | An columnar encoding of @a@. The type variable @f@ determines what
---   is present in each column in the header row. It is typically instantiated
---   to 'Headed' and occasionally to 'Headless'. There is nothing that
---   restricts it to these two types, although they satisfy the majority
---   of use cases. The type variable @c@ is the content type. This can
---   be @Text@, @String@, or @ByteString@. In the companion libraries
---   @reflex-dom-colonnade@ and @yesod-colonnade@, additional types
---   that represent HTML with element attributes are provided that serve
---   as the content type.
---
---   Internally, an 'Encoding' is represented as a 'Vector' of individual
---   column encodings. It is possible to use any collection type with
---   'Alternative' and 'Foldable' instances. However, 'Vector' was chosen to
---   optimize the data structure for the use case of building the structure
---   once and then folding over it many times. It is recommended that
---   'Encoding's are defined at the top-level so that GHC avoid reconstructing
---   them every time they are used.
-newtype Encoding f c a = Encoding
-  { getEncoding :: Vector (OneEncoding f c a)
-  } deriving (Monoid)
-
-instance Contravariant (Encoding f content) where
-  contramap f (Encoding v) = Encoding
-    (Vector.map (contramap f) v)
-
-instance Divisible (Encoding f content) where
-  conquer = Encoding Vector.empty
-  divide f (Encoding a) (Encoding b) =
-    Encoding $ (Vector.++)
-      (Vector.map (contramap (fst . f)) a)
-      (Vector.map (contramap (snd . f)) b)
-      -- (Vector.map (\(OneEncoding h c) -> (h,c . fst . f)) a)
-      -- (Vector.map (\(OneEncoding h c) -> (h,c . snd . f)) b)
-

colonnade/test/Main.hs

@@ -2,5 +2,5 @@ import Test.DocTest
 
 main :: IO ()
 main = doctest
-  [ "src/Colonnade/Encoding.hs"
+  [ "src"
   ]

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

@@ -0,0 +1,73 @@
+{ frontend ? false }:
+
+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 pkgs.fetchFromGitHub {
+        name = "${repo}-${commit.rev}";
+        inherit owner repo;
+        inherit (commit) rev sha256;
+      };
+      
+    reflex-platform = import (fetch-github-json "layer-3-communications" "reflex-platform" ./reflex-platform.json) {};
+    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;
+        with reflex-platform.lib;
+        with reflex-platform.nixpkgs.haskell.lib;
+        with reflex-platform.nixpkgs.haskellPackages; 
+        let
+          cp              = file: (self.callPackage (./deps + "/${file}.nix") {});
+          build-from-json = name: str: self.callCabal2nix name str {};
+          build           = name: path: self.callCabal2nix name (builtins.filterSource filterPredicate path) {};
+        in
+        {
+          gtk2hs-buildtools = self.callPackage ./gtk2hs-buildtools.nix {};
+          colonnade = build "colonnade" ../colonnade;
+          siphon    = build "siphon" ../siphon;
+          reflex-dom-colonnade = build "reflex-dom-colonnade" ../reflex-dom-colonnade;
+          lucid-colonnade = build "lucid-colonnade" ../lucid-colonnade;
+          blaze-colonnade = build "blaze-colonnade" ../blaze-colonnade;
+          yesod-colonnade = build "yesod-colonnade" ../yesod-colonnade;
+        } //
+        {
+          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"));
+        };
+
+    };
+in rec {
+  inherit reflex-platform fetch-github-json overrides nixpkgs pkgs;
+  colonnade = overrides.colonnade;
+  siphon    = overrides.siphon;
+  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/overrides.nix

@@ -0,0 +1,7 @@
+{ options ? (x: x), filterPredicate ? (x: true), lib, cabal2nixResult, self, super }:
+let build = path: options (self.callPackage (cabal2nixResult (builtins.filterSource filterPredicate path)) {});
+in {
+  # Core Libraries
+  colonnade = lib.dontCheck (build ../colonnade);
+  reflex-dom-colonnade = build ../reflex-dom-colonnade;
+}

nix/reflex-platform.json

@@ -0,0 +1,7 @@
+{
+  "url": "https://github.com/reflex-frp/reflex-platform",
+  "rev": "0446e9df3adfc7271015c278a2ec5b7e7a6a46f3",
+  "date": "2017-05-05T11:40:26-04:00",
+  "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

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

reflex-dom-colonnade/overrides-ghc.nix

@@ -0,0 +1,7 @@
+{ reflex-platform, ... }:
+let dc = reflex-platform.nixpkgs.haskell.lib.dontCheck;
+in reflex-platform.ghc.override {
+  overrides = self: super: {
+    colonnade = dc (self.callPackage (reflex-platform.cabal2nixResult ../colonnade) {});
+  };
+}

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

@@ -1,33 +1,33 @@
-name:                reflex-dom-colonnade
-version:             0.4.6
-synopsis:            Use colonnade with reflex-dom
-description:         Please see README.md
-homepage:            https://github.com/andrewthad/colonnade#readme
-license:             BSD3
-license-file:        LICENSE
-author:              Andrew Martin
-maintainer:          andrew.thaddeus@gmail.com
-copyright:           2016 Andrew Martin
-category:            web
-build-type:          Simple
-cabal-version:       >=1.10
+name: reflex-dom-colonnade
+version: 0.6.0
+synopsis: Use colonnade with reflex-dom
+description: Please see README.md
+homepage: https://github.com/andrewthad/colonnade#readme
+license: BSD3
+license-file: LICENSE
+author: Andrew Martin
+maintainer: andrew.thaddeus@gmail.com
+copyright: 2016 Andrew Martin
+category: web
+build-type: Simple
+cabal-version: >=1.10
 
 library
   hs-source-dirs:      src
   exposed-modules:
     Reflex.Dom.Colonnade
   build-depends:
-      base >= 4.7 && < 5.0
-    , colonnade >= 0.4.6 && < 0.5
+      base >= 4.9 && < 5.0
+    , 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
-    , reflex-dom
+    , reflex == 0.5.*
+    , reflex-dom == 0.4.*
     , containers >= 0.5 && < 0.6
-    , semigroups >= 0.16 && < 0.19
+    , profunctors >= 5.2 && < 5.3
+    , transformers >= 0.5 && < 0.6
   default-language: Haskell2010
-  ghc-options:      -Wall
 
 source-repository head
   type:     git

reflex-dom-colonnade/shell.nix

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

siphon/siphon.cabal

@@ -1,44 +1,48 @@
-name:                siphon
-version:             0.2
-synopsis:            Generic types and functions for columnar encoding and decoding
-description:         Please see README.md
-homepage:            https://github.com/andrewthad/colonnade#readme
-license:             BSD3
-license-file:        LICENSE
-author:              Andrew Martin
-maintainer:          andrew.thaddeus@gmail.com
-copyright:           2016 Andrew Martin
-category:            web
-build-type:          Simple
-cabal-version:       >=1.10
+name: siphon
+version: 0.8.1.1
+synopsis: Encode and decode CSV files
+description: Please see README.md
+homepage: https://github.com/andrewthad/colonnade#readme
+license: BSD3
+license-file: LICENSE
+author: Andrew Martin
+maintainer: andrew.thaddeus@gmail.com
+copyright: 2016 Andrew Martin
+category: web
+build-type: Simple
+cabal-version: >=1.10
 
 library
-  hs-source-dirs:      src
+  hs-source-dirs: src
   exposed-modules:
-    Siphon.Text
-    Siphon.ByteString.Char8
     Siphon
     Siphon.Types
-    Siphon.Content
-    Siphon.Encoding
-    Siphon.Decoding
-    Siphon.Internal
-    Siphon.Internal.Text
   build-depends:
-      base >= 4.7 && < 5
-    , colonnade >= 0.4 && < 0.5
-    , text
+      base >= 4.8 && < 5
+    , colonnade >= 1.2 && < 1.3
+    , text >= 1.0 && < 1.3
     , bytestring
-    , contravariant
     , vector
-    , pipes
+    , streaming >= 0.1.4 && < 0.3
     , attoparsec
-  default-language:    Haskell2010
+    , transformers >= 0.4.2 && < 0.6
+    , semigroups >= 0.18.2 && < 0.20
+  default-language: Haskell2010
 
-test-suite siphon-test
-  type:                exitcode-stdio-1.0
-  hs-source-dirs:      test
-  main-is:             Test.hs
+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
   build-depends:
       base
     , either
@@ -53,9 +57,10 @@ test-suite siphon-test
     , pipes
     , HUnit
     , test-framework-hunit
-  ghc-options:         -threaded -rtsopts -with-rtsopts=-N
-  default-language:    Haskell2010
+    , profunctors
+    , streaming
+  default-language: Haskell2010
 
 source-repository head
-  type:     git
+  type: git
   location: https://github.com/andrewthad/colonnade

siphon/src/Siphon.hs

@@ -1,11 +1,769 @@
-module Siphon where
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE RankNTypes #-}
 
--- encode :: Pipe a (Vector c) m x
--- encode
--- decode :: Pipe (Vector c) a m x
+{-# OPTIONS_GHC -Wall -fno-warn-unused-imports #-}
 
--- encode ::
+-- | 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
+  ( -- * Encode CSV
+    encodeCsv
+  , encodeCsvStream
+  , encodeCsvUtf8
+  , encodeCsvStreamUtf8
+    -- * Decode CSV
+  , decodeCsvUtf8
+    -- * Build Siphon
+  , headed
+  , headless
+  , indexed
+    -- * Types
+  , Siphon
+  , SiphonError(..)
+  , Indexed(..)
+    -- * Utility
+  , humanizeSiphonError
+    -- * Imports
+    -- $setup
+  ) where
 
--- row :: Vector (Escaped Text) -> Text
--- row = Vector.
+import Siphon.Types
+import Data.Monoid
+import Control.Applicative
+import Control.Monad
+
+import qualified Data.ByteString.Char8 as BC8
+import qualified Data.Attoparsec.ByteString as A
+import qualified Data.Attoparsec.Lazy as AL
+import qualified Data.Attoparsec.Zepto as Z
+import qualified Data.ByteString as S
+import qualified Data.ByteString.Unsafe as S
+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
+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)
+import Data.Vector (Vector)
+import Data.ByteString (ByteString)
+import Data.Coerce (coerce)
+import Data.Char (chr)
+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 !c !Ended
+  deriving (Show)
+
+decodeCsvUtf8 :: Monad m 
+  => Siphon CE.Headed ByteString a
+  -> Stream (Of ByteString) m () -- ^ encoded csv
+  -> Stream (Of a) m (Maybe SiphonError)
+decodeCsvUtf8 headedSiphon s1 = do
+  e <- lift (consumeHeaderRowUtf8 s1)
+  case e of
+    Left err -> return (Just err)
+    Right (v :> s2) -> case headedToIndexed utf8ToStr v headedSiphon of
+      Left err -> return (Just err)
+      Right ixedSiphon -> do
+        let requiredLength = V.length v
+        consumeBodyUtf8 1 requiredLength ixedSiphon s2
+
+encodeCsvStreamUtf8 :: (Monad m, CE.Headedness h)
+  => CE.Colonnade h a ByteString
+  -> Stream (Of a) m r
+  -> Stream (Of ByteString) m r
+encodeCsvStreamUtf8 =
+  encodeCsvInternal escapeChar8 (B.singleton comma) (B.singleton newline)
+
+-- | 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 h a c
+  -> Stream (Of a) m r
+  -> Stream (Of c) m r
+encodeCsvInternal escapeFunc separatorStr newlineStr colonnade s = do
+  case CE.headednessExtract of
+    Just toContent -> encodeHeader toContent escapeFunc separatorStr newlineStr colonnade
+    Nothing -> return ()
+  encodeRows escapeFunc separatorStr newlineStr colonnade s
+
+encodeHeader :: Monad m
+  => (h c -> c)
+  -> (c -> Escaped c)
+  -> c -- ^ separator
+  -> c -- ^ newline
+  -> CE.Colonnade h a c
+  -> Stream (Of c) m ()
+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 h _) -> do
+    SMP.yield (getEscaped (escapeFunc (toContent h)))
+  V.forM_ ws $ \(CE.OneColonnade h _) -> do
+    SMP.yield separatorStr
+    SMP.yield (getEscaped (escapeFunc (toContent h)))
+  SMP.yield newlineStr
+
+mapStreamM :: Monad m
+  => (a -> Stream (Of b) m x)
+  -> Stream (Of a) m r
+  -> Stream (Of b) m r
+mapStreamM f = SM.concats . SM.mapsM (\(a :> s) -> return (f a >> return s))
+
+encodeRows :: Monad m
+  => (c -> Escaped c)
+  -> c -- ^ separator
+  -> c -- ^ newline
+  -> CE.Colonnade f a c
+  -> Stream (Of a) m r
+  -> Stream (Of c) m r
+encodeRows escapeFunc separatorStr newlineStr colonnade = mapStreamM $ \a -> 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 _ encode) -> SMP.yield (getEscaped (escapeFunc (encode a)))
+  V.forM_ ws $ \(CE.OneColonnade _ encode) -> do
+    SMP.yield separatorStr
+    SMP.yield (getEscaped (escapeFunc (encode a)))
+  SMP.yield newlineStr
+
+data IndexedHeader a = IndexedHeader
+  { indexedHeaderIndexed :: {-# UNPACK #-} !Int
+  , indexedHeaderHeader :: !a
+  } 
+
+-- | Maps over a 'Decolonnade' that expects headers, converting these
+--   expected headers into the indices of the columns that they
+--   correspond to.
+headedToIndexed :: forall c a. Eq c
+  => (c -> T.Text)
+  -> Vector c -- ^ Headers in the source document
+  -> Siphon CE.Headed c a -- ^ Decolonnade that contains expected headers
+  -> Either SiphonError (Siphon IndexedHeader c a)
+headedToIndexed toStr v =
+    mapLeft (\(HeaderErrors a b c) -> SiphonError 0 (RowErrorHeaders a b c)) 
+  . getEitherWrap
+  . go
+  where
+  go :: forall b.
+        Siphon CE.Headed c b
+     -> EitherWrap HeaderErrors (Siphon IndexedHeader c b)
+  go (SiphonPure b) = EitherWrap (Right (SiphonPure b))
+  go (SiphonAp (CE.Headed h) decode apNext) =
+    let rnext = go apNext
+        ixs = V.elemIndices h v
+        ixsLen = V.length ixs
+        rcurrent
+          | ixsLen == 1 = Right (ixs V.! 0) -- (V.unsafeIndex ixs 0)
+          | ixsLen == 0 = Left (HeaderErrors V.empty (V.singleton (toStr h)) V.empty)
+          | otherwise =
+              let dups = V.singleton (V.map (\ix -> CellError ix (toStr (v V.! ix) {- (V.unsafeIndex v ix) -} )) ixs)
+               in Left (HeaderErrors dups V.empty V.empty)
+    in (\ix nextSiphon -> SiphonAp (IndexedHeader ix h) decode nextSiphon)
+       <$> EitherWrap rcurrent
+       <*> rnext
+
+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 = (SG.<>)
+
+-- byteStringChar8 :: Siphon ByteString
+-- byteStringChar8 = Siphon
+--   escape
+--   encodeRow
+--   (A.parse (row comma))
+--   B.null
+
+escapeChar8 :: ByteString -> Escaped ByteString
+escapeChar8 t = case B.find (\c -> c == newline || c == cr || c == comma || c == doubleQuote) t of
+  Nothing -> Escaped t
+  Just _  -> escapeAlways t
+
+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.
+escapeAlways :: ByteString -> Escaped ByteString
+escapeAlways t = Escaped $ LByteString.toStrict $ Builder.toLazyByteString $
+     Builder.word8 doubleQuote
+  <> B.foldl
+      (\ acc b -> acc <> if b == doubleQuote
+          then Builder.byteString
+            (B.pack [doubleQuote,doubleQuote])
+          else Builder.word8 b)
+      mempty
+      t
+  <> Builder.word8 doubleQuote
+
+-- Suboptimal for similar reason as escapeAlways.
+textEscapeAlways :: Text -> Escaped Text
+textEscapeAlways t = Escaped $ LT.toStrict $ TB.toLazyText $
+     TB.singleton '"'
+  <> T.foldl
+      (\ acc b -> acc <> if b == '"'
+          then TB.fromString "\"\""
+          else TB.singleton b
+      )
+      mempty
+      t
+  <> TB.singleton '"'
+
+-- 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
+-- {-# INLINE row #-}
+-- 
+-- rowNoNewline :: Word8  -- ^ Field delimiter
+--              -> AL.Parser (Vector ByteString)
+-- rowNoNewline !delim = V.fromList <$!> field delim `sepByDelim1'` delim
+-- {-# INLINE rowNoNewline #-}
+-- 
+-- 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
+--   but not a newline that follows a field. If we are positioned
+--   at a newline when it starts, that newline will be consumed
+--   and we return CellResultNewline.
+field :: Word8 -> AL.Parser (CellResult ByteString)
+field !delim = do
+  mb <- A.peekWord8
+  -- We purposely don't use <|> as we want to commit to the first
+  -- choice if we see a double quote.
+  case mb of
+    Just b
+      | b == doubleQuote -> do
+          (bs,tc) <- escapedField
+          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 B.empty EndedYes)
+            else return (CellResultNewline B.empty EndedNo)
+      | otherwise -> do
+          (bs,tc) <- unescapedField delim
+          case tc of
+            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 :: AL.Parser (S.ByteString,TrailChar)
+escapedField = do
+  _ <- dquote
+  -- The scan state is 'True' if the previous character was a double
+  -- quote.  We need to drop a trailing double quote left by scan.
+  s <- S.init <$>
+    ( A.scan False $ \s c ->
+      if c == doubleQuote
+        then Just (not s)
+        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
+      Right r  -> return (r,trailChar)
+      Left err -> fail err
+    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,TrailChar)
+unescapedField !delim = do
+  bs <- A.takeWhile $ \c -> 
+    c /= doubleQuote &&
+    c /= newline &&
+    c /= delim &&
+    c /= cr
+  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 '"'
+
+-- | This could be improved. We could avoid the builder and just
+-- write to a buffer directly.
+unescape :: Z.Parser S.ByteString
+unescape = (LByteString.toStrict . toLazyByteString) <$!> go mempty where
+  go acc = do
+    h <- Z.takeWhile (/= doubleQuote)
+    let rest = do
+          start <- Z.take 2
+          if (S.unsafeHead start == doubleQuote &&
+              S.unsafeIndex start 1 == doubleQuote)
+              then go (acc `mappend` byteString h `mappend` byteString (BC8.singleton '"'))
+              else fail "invalid CSV escape sequence"
+    done <- Z.atEnd
+    if done
+      then return (acc `mappend` byteString h)
+      else rest
+
+-- | Is this an empty record (i.e. a blank line)?
+blankLine :: V.Vector B.ByteString -> Bool
+blankLine v = V.length v == 1 && (B.null (V.head v))
+
+doubleQuote, newline, cr, comma :: Word8
+doubleQuote = 34
+newline = 10
+cr = 13
+comma = 44
+
+-- | This adds one to the index because text editors consider
+--   line number to be one-based, not zero-based.
+humanizeSiphonError :: SiphonError -> String
+humanizeSiphonError (SiphonError ix e) = unlines
+  $ ("Decolonnade error on line " ++ show (ix + 1) ++ " of file.")
+  : ("Error Category: " ++ descr)
+  : map ("  " ++) errDescrs
+  where (descr,errDescrs) = prettyRowError e
+
+prettyRowError :: RowError -> (String, [String])
+prettyRowError x = case x of
+  RowErrorParse -> (,) "CSV Parsing"
+    [ "The cells were malformed."
+    ]
+  RowErrorSize reqLen actualLen -> (,) "Row Length"
+    [ "Expected the row to have exactly " ++ show reqLen ++ " cells."
+    , "The row only has " ++ show actualLen ++ " cells."
+    ]
+  RowErrorHeaderSize reqLen actualLen -> (,) "Minimum Header Length"
+    [ "Expected the row to have at least " ++ show reqLen ++ " cells."
+    , "The row only has " ++ show actualLen ++ " cells."
+    ]
+  RowErrorMalformed column -> (,) "Text Decolonnade"
+    [ "Tried to decode input input in column " ++ columnNumToLetters column ++ " text"
+    , "There is a mistake in the encoding of the text."
+    ]
+  RowErrorHeaders dupErrs namedErrs unnamedErrs -> (,) "Missing Headers" $ concat
+    [ if V.length namedErrs > 0 then prettyNamedMissingHeaders namedErrs else []
+    , if V.length unnamedErrs > 0 then ["Missing unnamed headers"] else []
+    , if V.length dupErrs > 0 then prettyHeadingErrors dupErrs else []
+    ]
+  RowErrorDecode errs -> (,) "Cell Decolonnade" (prettyCellErrors errs)
+
+prettyCellErrors :: Vector CellError -> [String]
+prettyCellErrors errs = drop 1 $
+  flip concatMap errs $ \(CellError ix content) ->
+    let str = T.unpack content in
+    [ "-----------"
+    , "Column " ++ columnNumToLetters ix
+    , "Cell Content Length: " ++ show (Prelude.length str)
+    , "Cell Content: " ++ if null str
+        then "[empty cell]"
+        else str
+    ]
+
+prettyNamedMissingHeaders :: Vector T.Text -> [String]
+prettyNamedMissingHeaders missing = concat
+  [ concatMap (\h -> ["The header " ++ T.unpack h ++ " was missing."]) missing
+  ]
+
+prettyHeadingErrors :: Vector (Vector CellError) -> [String]
+prettyHeadingErrors missing = join (V.toList (fmap f missing))
+  where
+  f :: Vector CellError -> [String]
+  f v
+    | not (V.null w) && V.all (== V.head w) (V.tail w) =
+        [ "The header ["
+        , T.unpack (V.head w)
+        , "] appears in columns "
+        , L.intercalate ", " (V.toList (V.map (\(CellError ix _) -> columnNumToLetters ix) v))
+        ]
+    | otherwise = multiMsg : V.toList
+        (V.map (\(CellError ix content) -> "  Column " ++ columnNumToLetters ix ++ ": " ++ T.unpack content) v)
+    where
+    w :: Vector T.Text
+    w = V.map cellErrorContent v
+    multiMsg :: String
+    multiMsg = "Multiple headers matched the same predicate:"
+
+columnNumToLetters :: Int -> String
+columnNumToLetters i
+  | i >= 0 && i < 25 = [chr (i + 65)]
+  | otherwise = "Beyond Z. Fix this."
+
+newtype EitherWrap a b = EitherWrap
+  { getEitherWrap :: Either a b
+  } deriving (Functor)
+
+instance Monoid a => Applicative (EitherWrap a) where
+  pure = EitherWrap . Right
+  EitherWrap (Left a1) <*> EitherWrap (Left a2) = EitherWrap (Left (mappend a1 a2))
+  EitherWrap (Left a1) <*> EitherWrap (Right _) = EitherWrap (Left a1)
+  EitherWrap (Right _) <*> EitherWrap (Left a2) = EitherWrap (Left a2)
+  EitherWrap (Right f) <*> EitherWrap (Right b) = EitherWrap (Right (f b))
+
+mapLeft :: (a -> b) -> Either a c -> Either b c
+mapLeft _ (Right a) = Right a
+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 (A.parse (field comma)) B.null B.empty (\() -> True)
+
+consumeBodyUtf8 :: forall m a. Monad m
+  => Int -- ^ index of first row, usually zero or one
+  -> Int -- ^ Required row length
+  -> Siphon IndexedHeader ByteString a
+  -> Stream (Of ByteString) m ()
+  -> Stream (Of a) m (Maybe SiphonError)
+consumeBodyUtf8 = consumeBody utf8ToStr
+  (A.parse (field comma)) B.null B.empty (\() -> True)
+
+utf8ToStr :: ByteString -> T.Text
+utf8ToStr = either (\_ -> T.empty) id . decodeUtf8'
+
+consumeHeaderRow :: forall m r c. Monad m
+  => (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 parseCell isNull emptyStr isGood s0 = go 0 StrictListNil s0
+  where
+  go :: Int
+     -> StrictList c
+     -> Stream (Of c) m r
+     -> m (Either SiphonError (Of (Vector c) (Stream (Of c) m r)))
+  go !cellsLen !cells !s1 = do
+    e <- skipWhile isNull s1
+    case e of
+      Left r -> return $ if isGood r
+        then Right (reverseVectorStrictList cellsLen cells :> return r)
+        else Left (SiphonError 0 RowErrorParse)
+      Right (c :> s2) -> handleResult cellsLen cells (parseCell c) s2
+  handleResult :: Int -> StrictList c 
+               -> ATYP.IResult c (CellResult c)
+               -> Stream (Of c) m r
+               -> m (Either SiphonError (Of (Vector c) (Stream (Of c) m r)))
+  handleResult !cellsLen !cells !result s1 = case result of
+    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 cd _ -> do
+        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
+        else handleResult (cellsLen + 1) (StrictListCons cd cells) (parseCell c1) s1
+    ATYP.Partial k -> do
+      e <- skipWhile isNull s1
+      case e of
+        Left r -> handleResult cellsLen cells (k emptyStr) (return r)
+        Right (c1 :> s2) -> handleResult cellsLen cells (k c1) s2
+
+consumeBody :: forall m r c a. Monad m
+  => (c -> T.Text)
+  -> (c -> ATYP.IResult c (CellResult c))
+  -> (c -> Bool)
+  -> c
+  -> (r -> Bool) -- ^ True if termination is acceptable. False if it is because of a decoding error.
+  -> Int -- ^ index of first row, usually zero or one
+  -> Int -- ^ Required row length
+  -> Siphon IndexedHeader c a
+  -> Stream (Of c) m r
+  -> Stream (Of a) m (Maybe SiphonError)
+consumeBody toStr parseCell isNull emptyStr isGood row0 reqLen siphon s0 =
+  go row0 0 StrictListNil s0
+  where
+  go :: Int -> Int -> StrictList c -> Stream (Of c) m r -> Stream (Of a) m (Maybe SiphonError)
+  go !row !cellsLen !cells !s1 = do
+    e <- lift (skipWhile isNull s1)
+    case e of
+      Left r -> return $ if isGood r
+        then Nothing
+        else Just (SiphonError row RowErrorParse)
+      Right (c :> s2) -> handleResult row cellsLen cells (parseCell c) s2
+  handleResult :: Int -> Int -> StrictList c 
+               -> ATYP.IResult c (CellResult c)
+               -> Stream (Of c) m r
+               -> Stream (Of a) m (Maybe SiphonError)
+  handleResult !row !cellsLen !cells !result s1 = case result of
+    ATYP.Fail _ _ _ -> return $ Just $ SiphonError row RowErrorParse
+    ATYP.Done !c1 !res -> case res of
+      CellResultNewline !cd !ended -> do
+        case decodeRow row (reverseVectorStrictList (cellsLen + 1) (StrictListCons cd cells)) of
+          Left err -> return (Just err)
+          Right a -> do
+            SMP.yield a
+            case ended of
+              EndedYes -> do
+                e <- lift (SM.inspect s1)
+                case e of
+                  Left r -> return $ if isGood r
+                    then Nothing
+                    else Just (SiphonError row RowErrorParse)
+                  Right _ -> error "siphon: logical error, stream should be exhausted"
+              EndedNo -> if isNull c1 
+                then go (row + 1) 0 StrictListNil s1
+                else handleResult (row + 1) 0 StrictListNil (parseCell c1) s1
+      CellResultData !cd -> if isNull c1
+        then go row (cellsLen + 1) (StrictListCons cd cells) s1
+        else handleResult row (cellsLen + 1) (StrictListCons cd cells) (parseCell c1) s1
+    ATYP.Partial k -> do
+      e <- lift (skipWhile isNull s1)
+      case e of
+        Left r -> handleResult row cellsLen cells (k emptyStr) (return r)
+        Right (c1 :> s2) -> handleResult row cellsLen cells (k c1) s2
+  decodeRow :: Int -> Vector c -> Either SiphonError a
+  decodeRow rowIx v =
+    let vlen = V.length v in
+    if vlen /= reqLen
+      then Left $ SiphonError rowIx $ RowErrorSize reqLen vlen
+      else uncheckedRunWithRow toStr rowIx siphon v
+
+-- | You must pass the length of the list and as the first argument.
+--   Passing the wrong length will lead to an error.
+reverseVectorStrictList :: forall c. Int -> StrictList c -> Vector c
+reverseVectorStrictList len sl0 = V.create $ do
+  mv <- MV.new len
+  go1 mv
+  return mv
+  where
+  go1 :: forall s. MVector s c -> ST s ()
+  go1 !mv = go2 0 sl0
+    where
+    go2 :: Int -> StrictList c -> ST s ()
+    go2 _ StrictListNil = return ()
+    go2 !ix (StrictListCons c slNext) = do
+      MV.write mv ix c
+      go2 (ix + 1) slNext
+
+
+skipWhile :: forall m a r. Monad m
+  => (a -> Bool)
+  -> Stream (Of a) m r
+  -> m (Either r (Of a (Stream (Of a) m r)))
+skipWhile f = go where
+  go :: Stream (Of a) m r
+     -> m (Either r (Of a (Stream (Of a) m r)))
+  go s1 = do
+    e <- SM.inspect s1
+    case e of
+      Left _ -> return e
+      Right (a :> s2) -> if f a
+        then go s2
+        else return e
+
+-- | Strict in the spine and in the values
+data StrictList a = StrictListNil | StrictListCons !a !(StrictList a)
+
+-- | This function uses 'unsafeIndex' to access
+--   elements of the 'Vector'.
+uncheckedRunWithRow ::
+     (c -> T.Text)
+  -> Int
+  -> Siphon IndexedHeader c a
+  -> Vector c
+  -> Either SiphonError a
+uncheckedRunWithRow toStr i d v =
+  mapLeft (SiphonError i . RowErrorDecode) (uncheckedRun toStr d v)
+
+-- | This function does not check to make sure that the indicies in
+--   the 'Decolonnade' are in the 'Vector'. Only use this if you have
+--   already verified that none of the indices in the siphon are
+--   out of the bounds.
+uncheckedRun :: forall c a.
+     (c -> T.Text)
+  -> Siphon IndexedHeader c a
+  -> Vector c
+  -> Either (Vector CellError) a
+uncheckedRun toStr dc v = getEitherWrap (go dc)
+  where
+  go :: forall b.
+        Siphon IndexedHeader c b
+     -> EitherWrap (Vector CellError) b
+  go (SiphonPure b) = EitherWrap (Right b)
+  go (SiphonAp (IndexedHeader ix _) decode apNext) =
+    let rnext = go apNext
+        content = v V.! ix -- V.unsafeIndex v ix
+        rcurrent = maybe
+          (Left (V.singleton (CellError ix (toStr content))))
+          Right
+          (decode content)
+    in rnext <*> (EitherWrap rcurrent)
+
+siphonLength :: forall f c a. Siphon f c a -> Int
+siphonLength = go 0 where
+  go :: forall b. Int -> Siphon f c b -> Int
+  go !a (SiphonPure _) = a
+  go !a (SiphonAp _ _ apNext) = go (a + 1) apNext
+
+maxIndex :: forall c a. Siphon IndexedHeader c a -> Int
+maxIndex = go 0 where
+  go :: forall b. Int -> Siphon IndexedHeader c b -> Int
+  go !ix (SiphonPure _) = ix
+  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/src/Siphon/Decoding.hs

@@ -1,24 +1,35 @@
-{-# LANGUAGE RankNTypes   #-}
+{-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE DeriveFunctor #-}
 
-module Siphon.Decoding where
+module Siphon.Decoding 
+  ( mkParseError
+  , headlessPipe
+  , indexedPipe
+  , headedPipe
+  , consumeGeneral
+  , pipeGeneral
+  , convertDecodeError
+  ) where
 
 import Siphon.Types
-import Colonnade.Types
+import Colonnade (Headed(..),Headless(..))
 import Siphon.Internal (row,comma)
 import Data.Text (Text)
 import Data.ByteString (ByteString)
 import Pipes (yield,Pipe,Consumer',Producer,await)
 import Data.Vector (Vector)
+import Data.Functor.Contravariant (Contravariant(..))
+import Data.Char (chr)
 import qualified Data.Vector as Vector
-import qualified Colonnade.Decoding as Decoding
 import qualified Data.Attoparsec.ByteString as AttoByteString
 import qualified Data.ByteString.Char8 as ByteString
 import qualified Data.Attoparsec.Types as Atto
 
-mkParseError :: Int -> [String] -> String -> DecodingRowError f content
+mkParseError :: Int -> [String] -> String -> DecolonnadeRowError f content
 mkParseError i ctxs msg = id
-  $ DecodingRowError i
+  $ DecolonnadeRowError i
   $ RowErrorParse $ concat
     [ "Contexts: ["
     , concat ctxs
@@ -28,37 +39,37 @@ mkParseError i ctxs msg = id
     ]
 
 -- | This is a convenience function for working with @pipes-text@.
---   It will convert a UTF-8 decoding error into a `DecodingRowError`,
+--   It will convert a UTF-8 decoding error into a `DecolonnadeRowError`,
 --   so the pipes can be properly chained together.
-convertDecodeError :: String -> Either (Producer ByteString m ()) () -> Maybe (DecodingRowError f c)
-convertDecodeError encodingName (Left _) = Just (DecodingRowError 0 (RowErrorMalformed encodingName))
+convertDecodeError :: String -> Either (Producer ByteString m ()) () -> Maybe (DecolonnadeRowError f c)
+convertDecodeError encodingName (Left _) = Just (DecolonnadeRowError 0 (RowErrorMalformed encodingName))
 convertDecodeError _ (Right ()) = Nothing
 
 -- | This is seldom useful but is included for completeness.
 headlessPipe :: Monad m
   => Siphon c
-  -> Decoding Headless c a
-  -> Pipe c a m (DecodingRowError Headless c)
+  -> Decolonnade Headless c a
+  -> Pipe c a m (DecolonnadeRowError Headless c)
 headlessPipe sd decoding = uncheckedPipe requiredLength 0 sd indexedDecoding Nothing
   where
-  indexedDecoding = Decoding.headlessToIndexed decoding
-  requiredLength = Decoding.length indexedDecoding
+  indexedDecoding = headlessToIndexed decoding
+  requiredLength = decLength indexedDecoding
 
 indexedPipe :: Monad m
   => Siphon c
-  -> Decoding (Indexed Headless) c a
-  -> Pipe c a m (DecodingRowError Headless c)
+  -> Decolonnade (Indexed Headless) c a
+  -> Pipe c a m (DecolonnadeRowError Headless c)
 indexedPipe sd decoding = do
   e <- consumeGeneral 0 sd mkParseError
   case e of
     Left err -> return err
     Right (firstRow, mleftovers) ->
-      let req = Decoding.maxIndex decoding
+      let req = maxIndex decoding
           vlen = Vector.length firstRow
        in if vlen < req
-            then return (DecodingRowError 0 (RowErrorMinSize req vlen))
-            else case Decoding.uncheckedRun decoding firstRow of
-              Left cellErr -> return $ DecodingRowError 0 $ RowErrorDecode cellErr
+            then return (DecolonnadeRowError 0 (RowErrorMinSize req vlen))
+            else case uncheckedRun decoding firstRow of
+              Left cellErr -> return $ DecolonnadeRowError 0 $ RowErrorDecode cellErr
               Right a -> do
                 yield a
                 uncheckedPipe vlen 1 sd decoding mleftovers
@@ -66,15 +77,15 @@ indexedPipe sd decoding = do
 
 headedPipe :: (Monad m, Eq c)
   => Siphon c
-  -> Decoding Headed c a
-  -> Pipe c a m (DecodingRowError Headed c)
+  -> Decolonnade Headed c a
+  -> Pipe c a m (DecolonnadeRowError Headed c)
 headedPipe sd decoding = do
   e <- consumeGeneral 0 sd mkParseError
   case e of
     Left err -> return err
     Right (headers, mleftovers) ->
-      case Decoding.headedToIndexed headers decoding of
-        Left headingErrs -> return (DecodingRowError 0 (RowErrorHeading headingErrs))
+      case headedToIndexed headers decoding of
+        Left headingErrs -> return (DecolonnadeRowError 0 (RowErrorHeading headingErrs))
         Right indexedDecoding ->
           let requiredLength = Vector.length headers
            in uncheckedPipe requiredLength 1 sd indexedDecoding mleftovers
@@ -84,18 +95,18 @@ uncheckedPipe :: Monad m
   => Int -- ^ expected length of each row
   -> Int -- ^ index of first row, usually zero or one
   -> Siphon c
-  -> Decoding (Indexed f) c a
+  -> Decolonnade (Indexed f) c a
   -> Maybe c
-  -> Pipe c a m (DecodingRowError f c)
+  -> Pipe c a m (DecolonnadeRowError f c)
 uncheckedPipe requiredLength ix sd d mleftovers =
   pipeGeneral ix sd mkParseError checkedRunWithRow mleftovers
   where
   checkedRunWithRow rowIx v =
     let vlen = Vector.length v in
     if vlen /= requiredLength
-      then Left $ DecodingRowError rowIx
+      then Left $ DecolonnadeRowError rowIx
                 $ RowErrorSize requiredLength vlen
-      else Decoding.uncheckedRunWithRow rowIx d v
+      else uncheckedRunWithRow rowIx d v
 
 consumeGeneral :: Monad m
   => Int
@@ -157,4 +168,169 @@ awaitSkip f = go where
     a <- await
     if f a then go else return a
 
+-- | Converts the content type of a 'Decolonnade'. The @'Contravariant' f@
+-- constraint means that @f@ can be 'Headless' but not 'Headed'.
+contramapContent :: forall c1 c2 f a. Contravariant f => (c2 -> c1) -> Decolonnade f c1 a -> Decolonnade f c2 a
+contramapContent f = go
+  where
+  go :: forall b. Decolonnade f c1 b -> Decolonnade f c2 b
+  go (DecolonnadePure x) = DecolonnadePure x
+  go (DecolonnadeAp h decode apNext) =
+    DecolonnadeAp (contramap f h) (decode . f) (go apNext)
+
+headless :: (content -> Either String a) -> Decolonnade Headless content a
+headless f = DecolonnadeAp Headless f (DecolonnadePure id)
+
+headed :: content -> (content -> Either String a) -> Decolonnade Headed content a
+headed h f = DecolonnadeAp (Headed h) f (DecolonnadePure id)
+
+indexed :: Int -> (content -> Either String a) -> Decolonnade (Indexed Headless) content a
+indexed ix f = DecolonnadeAp (Indexed ix Headless) f (DecolonnadePure id)
+
+maxIndex :: forall f c a. Decolonnade (Indexed f) c a -> Int
+maxIndex = go 0 where
+  go :: forall b. Int -> Decolonnade (Indexed f) c b -> Int
+  go !ix (DecolonnadePure _) = ix
+  go !ix1 (DecolonnadeAp (Indexed ix2 _) decode apNext) =
+    go (max ix1 ix2) apNext
+
+-- | This function uses 'unsafeIndex' to access
+--   elements of the 'Vector'.
+uncheckedRunWithRow ::
+     Int
+  -> Decolonnade (Indexed f) content a
+  -> Vector content
+  -> Either (DecolonnadeRowError f content) a
+uncheckedRunWithRow i d v = mapLeft (DecolonnadeRowError i . RowErrorDecode) (uncheckedRun d v)
+
+-- | This function does not check to make sure that the indicies in
+--   the 'Decolonnade' are in the 'Vector'.
+uncheckedRun :: forall content a f.
+                Decolonnade (Indexed f) content a
+             -> Vector content
+             -> Either (DecolonnadeCellErrors f content) a
+uncheckedRun dc v = getEitherWrap (go dc)
+  where
+  go :: forall b.
+        Decolonnade (Indexed f) content b
+     -> EitherWrap (DecolonnadeCellErrors f content) b
+  go (DecolonnadePure b) = EitherWrap (Right b)
+  go (DecolonnadeAp ixed@(Indexed ix h) decode apNext) =
+    let rnext = go apNext
+        content = Vector.unsafeIndex v ix
+        rcurrent = mapLeft (DecolonnadeCellErrors . Vector.singleton . DecolonnadeCellError content ixed) (decode content)
+    in rnext <*> (EitherWrap rcurrent)
+
+headlessToIndexed :: forall c a.
+  Decolonnade Headless c a -> Decolonnade (Indexed Headless) c a
+headlessToIndexed = go 0 where
+  go :: forall b. Int -> Decolonnade Headless c b -> Decolonnade (Indexed Headless) c b
+  go !ix (DecolonnadePure a) = DecolonnadePure a
+  go !ix (DecolonnadeAp Headless decode apNext) =
+    DecolonnadeAp (Indexed ix Headless) decode (go (ix + 1) apNext)
+
+decLength :: forall f c a. Decolonnade f c a -> Int
+decLength = go 0 where
+  go :: forall b. Int -> Decolonnade f c b -> Int
+  go !a (DecolonnadePure _) = a
+  go !a (DecolonnadeAp _ _ apNext) = go (a + 1) apNext
+
+-- | Maps over a 'Decolonnade' that expects headers, converting these
+--   expected headers into the indices of the columns that they
+--   correspond to.
+headedToIndexed :: forall content a. Eq content
+                => Vector content -- ^ Headers in the source document
+                -> Decolonnade Headed content a -- ^ Decolonnade that contains expected headers
+                -> Either (HeadingErrors content) (Decolonnade (Indexed Headed) content a)
+headedToIndexed v = getEitherWrap . go
+  where
+  go :: forall b. Eq content
+     => Decolonnade Headed content b
+     -> EitherWrap (HeadingErrors content) (Decolonnade (Indexed Headed) content b)
+  go (DecolonnadePure b) = EitherWrap (Right (DecolonnadePure b))
+  go (DecolonnadeAp hd@(Headed h) decode apNext) =
+    let rnext = go apNext
+        ixs = Vector.elemIndices h v
+        ixsLen = Vector.length ixs
+        rcurrent
+          | ixsLen == 1 = Right (Vector.unsafeIndex ixs 0)
+          | ixsLen == 0 = Left (HeadingErrors (Vector.singleton h) Vector.empty)
+          | otherwise   = Left (HeadingErrors Vector.empty (Vector.singleton (h,ixsLen)))
+    in (\ix ap -> DecolonnadeAp (Indexed ix hd) decode ap)
+       <$> EitherWrap rcurrent
+       <*> rnext
+
+-- | This adds one to the index because text editors consider
+--   line number to be one-based, not zero-based.
+prettyError :: (c -> String) -> DecolonnadeRowError f c -> String
+prettyError toStr (DecolonnadeRowError ix e) = unlines
+  $ ("Decolonnade error on line " ++ show (ix + 1) ++ " of file.")
+  : ("Error Category: " ++ descr)
+  : map ("  " ++) errDescrs
+  where (descr,errDescrs) = prettyRowError toStr e
+
+prettyRowError :: (content -> String) -> RowError f content -> (String, [String])
+prettyRowError toStr x = case x of
+  RowErrorParse err -> (,) "CSV Parsing"
+    [ "The line could not be parsed into cells correctly."
+    , "Original parser error: " ++ err
+    ]
+  RowErrorSize reqLen actualLen -> (,) "Row Length"
+    [ "Expected the row to have exactly " ++ show reqLen ++ " cells."
+    , "The row only has " ++ show actualLen ++ " cells."
+    ]
+  RowErrorMinSize reqLen actualLen -> (,) "Row Min Length"
+    [ "Expected the row to have at least " ++ show reqLen ++ " cells."
+    , "The row only has " ++ show actualLen ++ " cells."
+    ]
+  RowErrorMalformed enc -> (,) "Text Decolonnade"
+    [ "Tried to decode the input as " ++ enc ++ " text"
+    , "There is a mistake in the encoding of the text."
+    ]
+  RowErrorHeading errs -> (,) "Header" (prettyHeadingErrors toStr errs)
+  RowErrorDecode errs -> (,) "Cell Decolonnade" (prettyCellErrors toStr errs)
+
+prettyCellErrors :: (c -> String) -> DecolonnadeCellErrors f c -> [String]
+prettyCellErrors toStr (DecolonnadeCellErrors errs) = drop 1 $
+  flip concatMap errs $ \(DecolonnadeCellError content (Indexed ix _) msg) ->
+    let str = toStr content in
+    [ "-----------"
+    , "Column " ++ columnNumToLetters ix
+    , "Original parse error: " ++ msg
+    , "Cell Content Length: " ++ show (Prelude.length str)
+    , "Cell Content: " ++ if null str
+        then "[empty cell]"
+        else str
+    ]
+
+prettyHeadingErrors :: (c -> String) -> HeadingErrors c -> [String]
+prettyHeadingErrors conv (HeadingErrors missing duplicates) = concat
+  [ concatMap (\h -> ["The header " ++ conv h ++ " was missing."]) missing
+  , concatMap (\(h,n) -> ["The header " ++ conv h ++ " occurred " ++ show n ++ " times."]) duplicates
+  ]
+
+columnNumToLetters :: Int -> String
+columnNumToLetters i
+  | i >= 0 && i < 25 = [chr (i + 65)]
+  | otherwise = "Beyond Z. Fix this."
+
+
+newtype EitherWrap a b = EitherWrap
+  { getEitherWrap :: Either a b
+  } deriving (Functor)
+
+instance Monoid a => Applicative (EitherWrap a) where
+  pure = EitherWrap . Right
+  EitherWrap (Left a1) <*> EitherWrap (Left a2) = EitherWrap (Left (mappend a1 a2))
+  EitherWrap (Left a1) <*> EitherWrap (Right _) = EitherWrap (Left a1)
+  EitherWrap (Right _) <*> EitherWrap (Left a2) = EitherWrap (Left a2)
+  EitherWrap (Right f) <*> EitherWrap (Right b) = EitherWrap (Right (f b))
+
+mapLeft :: (a -> b) -> Either a c -> Either b c
+mapLeft _ (Right a) = Right a
+mapLeft f (Left a) = Left (f a)
+
+
+
+
 

siphon/src/Siphon/Encoding.hs

@@ -1,33 +1,28 @@
 module Siphon.Encoding where
 
 import Siphon.Types
-import Colonnade.Types
+import Colonnade (Colonnade,Headed)
 import Pipes (Pipe,yield)
 import qualified Pipes.Prelude as Pipes
-import qualified Colonnade.Encoding as Encoding
+import qualified Colonnade.Encode as E
 
-row :: Siphon c
-    -> Encoding f c a
-    -> a
-    -> c
+row :: Siphon c -> Colonnade f a c -> a -> c
 row (Siphon escape intercalate _ _) e =
-  intercalate . Encoding.runRow escape e
+  intercalate . E.row escape e
 
-header :: Siphon c
-       -> Encoding Headed c a
-       -> c
+header :: Siphon c -> Colonnade Headed a c -> c
 header (Siphon escape intercalate _ _) e =
-  intercalate (Encoding.runHeader escape e)
+  intercalate (E.header escape e)
 
 pipe :: Monad m
   => Siphon c
-  -> Encoding f c a
+  -> Colonnade f a c
   -> Pipe a c m x
 pipe siphon encoding = Pipes.map (row siphon encoding)
 
 headedPipe :: Monad m
   => Siphon c
-  -> Encoding Headed c a
+  -> Colonnade Headed a c
   -> Pipe a c m x
 headedPipe siphon encoding = do
   yield (header siphon encoding)

siphon/src/Siphon/Types.hs

@@ -1,45 +1,77 @@
-module Siphon.Types where
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+{-# OPTIONS_GHC -Wall -Werror #-}
+
+module Siphon.Types
+  ( Siphon(..)
+  , Indexed(..)
+  , SiphonError(..)
+  , RowError(..)
+  , CellError(..)
+  ) where
 
 import Data.Vector (Vector)
-import Colonnade.Types (DecodingRowError)
-import qualified Data.Attoparsec.Types as Atto
+import Control.Exception (Exception)
+import Data.Text (Text)
 
-newtype Escaped c = Escaped { getEscaped :: c }
+data CellError = CellError
+  { cellErrorColumn :: !Int
+  , cellErrorContent :: !Text
+  } deriving (Show,Read,Eq)
 
-data Siphon c = Siphon
-  { siphonEscape      :: !(c -> Escaped c)
-  , siphonIntercalate :: !(Vector (Escaped c) -> c)
-  , siphonParseRow    :: c -> Atto.IResult c (Vector c)
-  , siphonNull        :: c -> Bool
-  }
+newtype Indexed a = Indexed
+  { indexedIndex :: Int
+  } deriving (Eq,Ord,Functor,Show,Read)
 
--- -- | This type is provided for convenience with @pipes-text@
--- data CsvResult f c
---   = CsvResultSuccess
---   | CsvResultTextDecodeError
---   | CsvResultDecodeError (DecodingRowError f c)
---   deriving (Show,Read,Eq)
+data SiphonError = SiphonError
+  { siphonErrorRow :: !Int
+  , siphonErrorCause :: !RowError
+  } deriving (Show,Read,Eq)
 
+instance Exception SiphonError
 
--- | Consider changing out the use of 'Vector' here
--- with the humble list instead. It might fuse away
--- better. Not sure though.
--- data SiphonX c1 c2 = SiphonX
---   { siphonXEscape :: !(c1 -> Escaped c2)
---   , siphonXIntercalate :: !(Vector (Escaped c2) -> c2)
---   }
---
--- data SiphonDecoding c1 c2 = SiphonDecoding
---   { siphonDecodingParse :: c1 -> Atto.IResult c1 (Vector c2)
---   , siphonDecodingNull  :: c1 -> Bool
---   }
+data RowError
+  = RowErrorParse
+    -- ^ Error occurred parsing the document into cells
+  | RowErrorDecode !(Vector CellError)
+    -- ^ Error decoding the content
+  | RowErrorSize !Int !Int
+    -- ^ Wrong number of cells in the row
+  | RowErrorHeaders !(Vector (Vector CellError)) !(Vector Text) !(Vector Int)
+    -- ^ Three parts:
+    --   (a) Multiple header cells matched the same expected cell, 
+    --   (b) Headers that were missing, 
+    --   (c) Missing headers that were lambdas. They cannot be
+    --   shown so instead their positions in the 'Siphon' are given.
+  | RowErrorHeaderSize !Int !Int
+    -- ^ Not enough cells in header, expected, actual
+  | RowErrorMalformed !Int
+    -- ^ Error decoding unicode content, column number
+  deriving (Show,Read,Eq)
 
--- data WithEnd c = WithEnd
---   { withEndEnded :: !Bool
---   , withEndContent :: !c
---   }
+-- | This just actually a specialization of the free applicative.
+--   Check out @Control.Applicative.Free@ in the @free@ library to
+--   learn more about this. The meanings of the fields are documented
+--   slightly more in the source code. Unfortunately, haddock does not
+--   play nicely with GADTs.
+data Siphon f c a where
+  SiphonPure ::
+       !a -- function
+    -> Siphon f c a
+  SiphonAp ::
+       !(f c) -- header
+    -> !(c -> Maybe a) -- decoding function
+    -> !(Siphon f c (a -> b)) -- next decoding
+    -> Siphon f c b
 
--- data SiphonDecodingError
---   { clarify
---   }
+instance Functor (Siphon f c) where
+  fmap f (SiphonPure a) = SiphonPure (f a)
+  fmap f (SiphonAp h c apNext) = SiphonAp h c ((f .) <$> apNext)
+
+instance Applicative (Siphon f c) where
+  pure = SiphonPure
+  SiphonPure f <*> y = fmap f y
+  SiphonAp h c y <*> z = SiphonAp h c (flip <$> y <*> z)
 

siphon/test/Doctest.hs

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

siphon/test/Test.hs

@@ -1,38 +1,42 @@
+{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE DeriveGeneric     #-}
 
 module Main (main) where
 
-import Test.QuickCheck                      (Gen, Arbitrary(..), choose, elements)
-import Test.HUnit                           (Assertion,(@?=))
-import Test.Framework                       (defaultMain, testGroup, Test)
+import Test.QuickCheck (Gen, Arbitrary(..), choose, elements, Property)
+import Test.QuickCheck.Property (Result, succeeded, exception)
+import Test.HUnit (Assertion,(@?=))
+import Test.Framework (defaultMain, testGroup, Test)
 import Test.Framework.Providers.QuickCheck2 (testProperty)
-import Test.Framework.Providers.HUnit       (testCase)
-import Data.ByteString                      (ByteString)
-import Data.Text                            (Text)
-import GHC.Generics                         (Generic)
+import Test.Framework.Providers.HUnit (testCase)
+import Data.ByteString (ByteString)
+import Data.Text (Text)
+import GHC.Generics (Generic)
 import Data.Either.Combinators
-import Colonnade.Types
 import Siphon.Types
 import Data.Functor.Identity
 import Data.Functor.Contravariant           (contramap)
 import Data.Functor.Contravariant.Divisible (divided,conquered)
-import qualified Data.Text                  as Text
-import qualified Data.ByteString.Builder    as Builder
-import qualified Data.ByteString.Lazy       as LByteString
-import qualified Data.ByteString            as ByteString
-import qualified Data.ByteString.Char8      as BC8
-import qualified Colonnade.Decoding         as Decoding
-import qualified Colonnade.Encoding         as Encoding
-import qualified Colonnade.Decoding.ByteString.Char8 as CDB
-import qualified Colonnade.Encoding.ByteString.Char8 as CEB
-import qualified Colonnade.Decoding.Text    as CDT
-import qualified Colonnade.Encoding.Text    as CET
-import qualified Siphon.Encoding            as SE
-import qualified Siphon.Decoding            as SD
-import qualified Siphon.Content             as SC
-import qualified Pipes.Prelude              as Pipes
-import Pipes
+import Colonnade (headed,headless,Colonnade,Headed,Headless)
+import Data.Profunctor (lmap)
+import Streaming (Stream,Of(..))
+import Control.Exception
+import Debug.Trace
+import Data.Word (Word8)
+import Data.Char (ord)
+import qualified Data.Text as Text
+import qualified Data.ByteString.Builder as Builder
+import qualified Data.ByteString.Lazy as LByteString
+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
+import qualified Data.Text.Lazy.Builder as TBuilder
+import qualified Data.Text.Lazy.Builder.Int as TBuilder
 
 main :: IO ()
 main = defaultMain tests
@@ -40,63 +44,80 @@ main = defaultMain tests
 tests :: [Test]
 tests =
   [ testGroup "ByteString encode/decode"
-    [ testCase "Headless Encoding (int,char,bool)"
-        $ runTestScenario
-            SC.byteStringChar8
-            SE.pipe
-            encodingA
-            "4,c,false\n"
-    , testProperty "Headless Isomorphism (int,char,bool)"
-        $ propIsoPipe $
-          (SE.pipe SC.byteStringChar8 encodingA)
-          >->
-          (void $ SD.headlessPipe SC.byteStringChar8 decodingA)
-    , testCase "Headed Encoding (int,char,bool)"
-        $ runTestScenario
-            SC.byteStringChar8
-            SE.headedPipe
+    [ testCase "Headed Encoding (int,char,bool)"
+        $ runTestScenario [(4,intToWord8 (ord 'c'),False)]
+            S.encodeCsvStreamUtf8
             encodingB
             $ ByteString.concat
               [ "number,letter,boolean\n"
               , "4,c,false\n"
               ]
     , testCase "Headed Encoding (int,char,bool) monoidal building"
-        $ runTestScenario
-            SC.byteStringChar8
-            SE.headedPipe
+        $ runTestScenario [(4,'c',False)]
+            S.encodeCsvStreamUtf8
             encodingC
             $ ByteString.concat
               [ "boolean,letter\n"
               , "false,c\n"
               ]
+    , testCase "Headed Encoding (escaped characters)"
+        $ runTestScenario ["bob","there,be,commas","the \" quote"]
+            S.encodeCsvStreamUtf8
+            encodingF
+            $ ByteString.concat
+              [ "name\n"
+              , "bob\n"
+              , "\"there,be,commas\"\n"
+              , "\"the \"\" quote\"\n"
+              ]
+    , testCase "Headed Decoding (int,char,bool)"
+        $ ( runIdentity . SMP.toList )
+            ( S.decodeCsvUtf8 decodingB
+              ( mapM_ (SMP.yield . BC8.singleton) $ concat
+                [ "number,letter,boolean\n"
+                , "244,z,true\n"
+                ]
+              )
+            ) @?= ([(244,intToWord8 (ord 'z'),True)] :> Nothing)
+    , testCase "Headed Decoding (geolite)"
+        $ ( runIdentity . SMP.toList )
+            ( 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"
+                , "\"martin, drew\"\n"
+                ]
+              )
+            ) @?= (["drew","martin, drew"] :> Nothing)
     , testProperty "Headed Isomorphism (int,char,bool)"
-        $ propIsoPipe $
-          (SE.headedPipe SC.byteStringChar8 encodingB)
-          >->
-          (void $ SD.headedPipe SC.byteStringChar8 decodingB)
-    ]
-  , testGroup "Text encode/decode"
-    [ testCase "Headless Encoding (int,char,bool)"
-        $ runTestScenario
-            SC.text
-            SE.pipe
-            encodingW
-            "4,c,false\n"
-    , testCase "Headless Encoding (Foo,Foo,Foo)"
-        $ runCustomTestScenario
-            SC.text
-            SE.pipe
-            encodingY
-            (FooA,FooA,FooC)
-            "Simple,Simple,\"More\"\"Escaped,\"\"\"\"Chars\"\n"
-    , testProperty "Headless Isomorphism (Foo,Foo,Foo)"
-        $ propIsoPipe $
-          (SE.pipe SC.text encodingY)
-          >->
-          (void $ SD.headlessPipe SC.text decodingY)
+        $ propIsoStream BC8.unpack
+          (S.decodeCsvUtf8 decodingB)
+          (S.encodeCsvStreamUtf8 encodingB)
     ]
   ]
 
+intToWord8 :: Int -> Word8
+intToWord8 = fromIntegral
+
 data Foo = FooA | FooB | FooC
   deriving (Generic,Eq,Ord,Show,Read,Bounded,Enum)
 
@@ -112,96 +133,128 @@ fooToString x = case x of
 encodeFoo :: (String -> c) -> Foo -> c
 encodeFoo f = f . fooToString
 
-fooFromString :: String -> Either String Foo
+fooFromString :: String -> Maybe Foo
 fooFromString x = case x of
-  "Simple" -> Right FooA
-  "With,Escaped\nChars" -> Right FooB
-  "More\"Escaped,\"\"Chars" -> Right FooC
-  _ -> Left "failed to decode Foo"
+  "Simple" -> Just FooA
+  "With,Escaped\nChars" -> Just FooB
+  "More\"Escaped,\"\"Chars" -> Just FooC
+  _ -> Nothing
 
-decodeFoo :: (c -> String) -> c -> Either String Foo
+decodeFoo :: (c -> String) -> c -> Maybe Foo
 decodeFoo f = fooFromString . f
 
-decodingA :: Decoding Headless ByteString (Int,Char,Bool)
+decodingA :: Siphon Headless ByteString (Int,Char,Bool)
 decodingA = (,,)
-  <$> Decoding.headless CDB.int
-  <*> Decoding.headless CDB.char
-  <*> Decoding.headless CDB.bool
+  <$> S.headless dbInt
+  <*> S.headless dbChar
+  <*> S.headless dbBool
 
-decodingB :: Decoding Headed ByteString (Int,Char,Bool)
+decodingB :: Siphon Headed ByteString (Int,Word8,Bool)
 decodingB = (,,)
-  <$> Decoding.headed "number" CDB.int
-  <*> Decoding.headed "letter" CDB.char
-  <*> Decoding.headed "boolean" CDB.bool
+  <$> S.headed "number" dbInt
+  <*> S.headed "letter" dbWord8
+  <*> S.headed "boolean" dbBool
 
-encodingA :: Encoding Headless ByteString (Int,Char,Bool)
-encodingA = contramap tripleToPairs
-  $ divided (Encoding.headless CEB.int)
-  $ divided (Encoding.headless CEB.char)
-  $ divided (Encoding.headless CEB.bool)
-  $ conquered
+decodingF :: Siphon Headed ByteString ByteString
+decodingF = S.headed "name" Just
 
-encodingW :: Encoding Headless Text (Int,Char,Bool)
-encodingW = contramap tripleToPairs
-  $ divided (Encoding.headless CET.int)
-  $ divided (Encoding.headless CET.char)
-  $ divided (Encoding.headless CET.bool)
-  $ conquered
+decodingGeolite :: Siphon Headed ByteString (Int,Word8,Word8)
+decodingGeolite = (,,)
+  <$> S.headed "network" dbInt
+  <*> S.headed "autonomous_system_number" dbWord8
+  <*> S.headed "autonomous_system_organization" dbWord8
 
-encodingY :: Encoding Headless Text (Foo,Foo,Foo)
-encodingY = contramap tripleToPairs
-  $ divided (Encoding.headless $ encodeFoo Text.pack)
-  $ divided (Encoding.headless $ encodeFoo Text.pack)
-  $ divided (Encoding.headless $ encodeFoo Text.pack)
-  $ conquered
 
-decodingY :: Decoding Headless Text (Foo,Foo,Foo)
+encodingA :: Colonnade Headless (Int,Char,Bool) ByteString
+encodingA = mconcat
+  [ lmap fst3 (headless ebInt)
+  , lmap snd3 (headless ebChar)
+  , lmap thd3 (headless ebBool)
+  ]
+
+encodingW :: Colonnade Headless (Int,Char,Bool) Text
+encodingW = mconcat
+  [ lmap fst3 (headless etInt)
+  , lmap snd3 (headless etChar)
+  , lmap thd3 (headless etBool)
+  ]
+
+encodingY :: Colonnade Headless (Foo,Foo,Foo) Text
+encodingY = mconcat
+  [ lmap fst3 (headless $ encodeFoo Text.pack)
+  , lmap snd3 (headless $ encodeFoo Text.pack)
+  , lmap thd3 (headless $ encodeFoo Text.pack)
+  ]
+
+decodingY :: Siphon Headless Text (Foo,Foo,Foo)
 decodingY = (,,)
-  <$> Decoding.headless (decodeFoo Text.unpack)
-  <*> Decoding.headless (decodeFoo Text.unpack)
-  <*> Decoding.headless (decodeFoo Text.unpack)
+  <$> S.headless (decodeFoo Text.unpack)
+  <*> S.headless (decodeFoo Text.unpack)
+  <*> S.headless (decodeFoo Text.unpack)
 
-encodingB :: Encoding Headed ByteString (Int,Char,Bool)
-encodingB = contramap tripleToPairs
-  $ divided (Encoding.headed "number" CEB.int)
-  $ divided (Encoding.headed "letter" CEB.char)
-  $ divided (Encoding.headed "boolean" CEB.bool)
-  $ conquered
+encodingF :: Colonnade Headed ByteString ByteString
+encodingF = headed "name" id
 
-encodingC :: Encoding Headed ByteString (Int,Char,Bool)
+encodingB :: Colonnade Headed (Int,Word8,Bool) ByteString
+encodingB = mconcat
+  [ lmap fst3 (headed "number" ebInt)
+  , lmap snd3 (headed "letter" ebWord8)
+  , lmap thd3 (headed "boolean" ebBool)
+  ]
+
+encodingC :: Colonnade Headed (Int,Char,Bool) ByteString
 encodingC = mconcat
-  [ contramap thd3 $ Encoding.headed "boolean" CEB.bool
-  , contramap snd3 $ Encoding.headed "letter" CEB.char
+  [ lmap thd3 $ headed "boolean" ebBool
+  , lmap snd3 $ headed "letter" ebChar
   ]
 
 tripleToPairs :: (a,b,c) -> (a,(b,(c,())))
 tripleToPairs (a,b,c) = (a,(b,(c,())))
 
-propIsoPipe :: Eq a => Pipe a a Identity () -> [a] -> Bool
-propIsoPipe p as = (Pipes.toList $ each as >-> p) == as
+propIsoStream :: (Eq a, Show a, Monoid c)
+  => (c -> String)
+  -> (Stream (Of c) Identity () -> Stream (Of a) Identity (Maybe SiphonError))
+  -> (Stream (Of a) Identity () -> Stream (Of c) Identity ())
+  -> [a]
+  -> Result
+propIsoStream toStr decode encode as =
+  let asNew :> m = runIdentity $ SMP.toList $ decode $ encode $ SMP.each as
+   in case m of
+        Nothing -> if as == asNew
+          then succeeded
+          else exception ("expected " ++ show as ++ " but got " ++ show asNew) myException
+        Just err ->
+          let csv = toStr $ mconcat $ runIdentity $ SMP.toList_ $ encode $ SMP.each as
+           in exception (S.humanizeSiphonError err ++ "\nGenerated CSV\n" ++ csv) myException
 
-runTestScenario :: (Monoid c, Eq c, Show c)
-  => Siphon c
-  -> (Siphon c -> Encoding f c (Int,Char,Bool) -> Pipe (Int,Char,Bool) c Identity ())
-  -> Encoding f c (Int,Char,Bool)
+data MyException = MyException
+  deriving (Show,Read,Eq)
+instance Exception MyException
+
+myException :: SomeException
+myException = SomeException MyException
+
+runTestScenario :: (Monoid c, Eq c, Show c, Eq a, Show a)
+  => [a]
+  -> (Colonnade f a c -> Stream (Of a) Identity () -> Stream (Of c) Identity ())
+  -> Colonnade f a c
   -> c
   -> Assertion
-runTestScenario s p e c =
-  ( mconcat $ Pipes.toList $
-    Pipes.yield (4,'c',False) >-> p s e
+runTestScenario as p e c =
+  ( mconcat (runIdentity (SMP.toList_ (p e (mapM_ SMP.yield as))))
   ) @?= c
 
-runCustomTestScenario :: (Monoid c, Eq c, Show c)
-  => Siphon c
-  -> (Siphon c -> Encoding f c a -> Pipe a c Identity ())
-  -> Encoding f c a
-  -> a
-  -> c
-  -> Assertion
-runCustomTestScenario s p e a c =
-  ( mconcat $ Pipes.toList $
-    Pipes.yield a >-> p s e
-  ) @?= c
+-- runCustomTestScenario :: (Monoid c, Eq c, Show c)
+--   => Siphon c
+--   -> (Siphon c -> Colonnade f a c -> Pipe a c Identity ())
+--   -> Colonnade f a c
+--   -> a
+--   -> c
+--   -> Assertion
+-- runCustomTestScenario s p e a c =
+--   ( mconcat $ Pipes.toList $
+--     Pipes.yield a >-> p s e
+--   ) @?= c
 
 -- testEncodingA :: Assertion
 -- testEncodingA = runTestScenario encodingA "4,c,false\n"
@@ -225,3 +278,63 @@ snd3 (a,b,c) = b
 thd3 :: (a,b,c) -> c
 thd3 (a,b,c) = c
 
+
+dbChar :: ByteString -> Maybe Char
+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
+  if ByteString.null bsRem
+    then Just a
+    else Nothing
+
+dbBool :: ByteString -> Maybe Bool
+dbBool b
+  | b == BC8.pack "true" = Just True
+  | b == BC8.pack "false" = Just False
+  | otherwise = Nothing
+
+ebChar :: Char -> ByteString
+ebChar = BC8.singleton
+
+ebWord8 :: Word8 -> ByteString
+ebWord8 = B.singleton
+
+ebInt :: Int -> ByteString
+ebInt = LByteString.toStrict
+    . Builder.toLazyByteString 
+    . Builder.intDec
+
+ebBool :: Bool -> ByteString
+ebBool x = case x of
+  True -> BC8.pack "true"
+  False -> BC8.pack "false"
+
+ebByteString :: ByteString -> ByteString
+ebByteString = id
+
+
+etChar :: Char -> Text
+etChar = Text.singleton
+
+etInt :: Int -> Text
+etInt = LText.toStrict
+    . TBuilder.toLazyText
+    . TBuilder.decimal
+
+etText :: Text -> Text
+etText = id
+
+etBool :: Bool -> Text
+etBool x = case x of
+  True -> Text.pack "true"
+  False -> Text.pack "false"
+

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,58 +1,14 @@
-# This file was automatically generated by 'stack init'
-#
-# Some commonly used options have been documented as comments in this file.
-# For advanced use and comprehensive documentation of the format, please see:
-# http://docs.haskellstack.org/en/stable/yaml_configuration/
-
-# Resolver to choose a 'specific' stackage snapshot or a compiler version.
-# A snapshot resolver dictates the compiler version and the set of packages
-# to be used for project dependencies. For example:
-#
-# resolver: lts-3.5
-# resolver: nightly-2015-09-21
-# resolver: ghc-7.10.2
-# resolver: ghcjs-0.1.0_ghc-7.10.2
-# resolver:
-#  name: custom-snapshot
-#  location: "./custom-snapshot.yaml"
-resolver: lts-6.4
-
-# 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.
+resolver: nightly-2018-06-11
 packages:
 - 'colonnade'
-- 'yesod-colonnade'
-- 'reflex-dom-colonnade'
+- 'blaze-colonnade'
+- 'lucid-colonnade'
 - 'siphon'
-- 'geolite-csv'
-# Dependency packages to be pulled from upstream that are not in the resolver
-# (e.g., acme-missiles-0.3)
-extra-deps:
-- 'reflex-dom-0.3'
-- 'ref-tf-0.4'
-- 'reflex-0.4.0'
-- 'aeson-0.9.0.1'
-- 'haskell-src-exts-1.16.0.1'
-- 'syb-0.5.1'
-- 'ip-0.8.4'
-- 'lmdb-0.2.5'
+- 'yesod-colonnade'
+# - 'geolite-csv'
 
+extra-deps:
+- 'yesod-elements-1.1'
 
 # Override default flag values for local packages and extra-deps
 flags: {}

yesod-colonnade/src/Yesod/Colonnade.hs

@@ -1,138 +1,183 @@
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE QuasiQuotes #-}
-
+-- | Build HTML tables using @yesod@ and @colonnade@. To learn
+--   how to use this module, first read the documentation for @colonnade@,
+--   and then read the documentation for @blaze-colonnade@. This library
+--   and @blaze-colonnade@ are entirely distinct; neither depends on the
+--   other. However, the interfaces they expose are very similar, and
+--   the explanations provided counterpart are sufficient to understand
+--   this library.
 module Yesod.Colonnade
-  ( table
-  , listItems
-  , Cell(..)
+  ( -- * Build
+    Cell(..)
   , cell
   , stringCell
   , textCell
   , builderCell
   , anchorCell
+  , anchorWidget
+    -- * Apply
+  , encodeWidgetTable
+  , encodeCellTable
+  , encodeDefinitionTable
+  , encodeListItems
   ) where
 
 import Yesod.Core
-import Colonnade.Types
+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 qualified Colonnade.Encoding as Encoding
+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
 import qualified Data.Text as Text
 import qualified Data.Text.Lazy as LText
 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 :: ![(Text,Text)]
-  , cellContents :: !(WidgetT site IO ())
+  { cellAttrs :: [Attribute]
+  , 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
-  mappend (Cell a1 c1) (Cell a2 c2) = Cell (mappend a1 a2) (mappend c1 c2)
+  mempty = Cell mempty mempty
+  mappend = (SG.<>)
 
-cell :: WidgetT site IO () -> Cell site
-cell = Cell []
+-- | Create a 'Cell' from a 'Widget'
+cell :: WidgetFor site () -> Cell site
+cell = Cell mempty
 
+-- | Create a 'Cell' from a 'String'
 stringCell :: String -> Cell site
 stringCell = cell . fromString
 
+-- | Create a 'Cell' from a 'Text'
 textCell :: Text -> Cell site
 textCell = cell . toWidget . toHtml
 
+-- | Create a 'Cell' from a text builder
 builderCell :: TBuilder.Builder -> Cell site
 builderCell = cell . toWidget . toHtml . LText.toStrict . TBuilder.toLazyText
 
-anchorCell :: (a -> Route site) -> (a -> WidgetT site IO ()) -> a -> Cell site
-anchorCell getRoute getContent a = cell $ do
+-- | Create a 'Cell' whose content is hyperlinked by wrapping
+--   it in an @\<a\>@.
+anchorCell :: 
+     (a -> Route site) -- ^ Route that will go in @href@ attribute
+  -> (a -> WidgetFor site ()) -- ^ Content wrapped by @<a>@ tag
+  -> a -- ^ Value
+  -> Cell site
+anchorCell getRoute getContent = cell . anchorWidget getRoute getContent
+
+-- | Create a widget whose content is hyperlinked by wrapping
+--   it in an @\<a\>@.
+anchorWidget :: 
+     (a -> Route site) -- ^ Route that will go in @href@ attribute
+  -> (a -> WidgetFor site ()) -- ^ Content wrapped by @<a>@ tag
+  -> a -- ^ Value
+  -> WidgetFor site ()
+anchorWidget getRoute getContent a = do
   urlRender <- getUrlRender
-  aTag [(Text.pack "href",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.
-listItems :: Foldable f
-  => (WidgetT site IO () -> WidgetT site IO ())
+--   attributes with the data\'s attributes. 
+encodeListItems :: 
+     (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
-  -> Encoding Headed (Cell site) a
+  -> Colonnade Headed a (Cell site)
      -- ^ How to encode data as a row
-  -> f a
-     -- ^ Rows of data
-  -> WidgetT site IO ()
-listItems ulWrap combine enc xs =
-  forM_ xs $ ulWrap . Encoding.runBothMonadic_ enc
+  -> a
+     -- ^ The value to display
+  -> WidgetFor site ()
+encodeListItems ulWrap combine enc =
+  ulWrap . E.bothMonadic_ enc
     (\(Cell ha hc) (Cell ba bc) ->
-      li (ha ++ ba) (combine hc bc)
+      li_ (ha <> ba) (combine hc bc)
     )
 
--- | If you are using the bootstrap css framework, then you may want
+-- | A two-column table with the header content displayed in the
+--   first column and the data displayed in the second column. Note
+--   that the generated HTML table does not have a @thead@.
+encodeDefinitionTable ::
+     [Attribute]
+     -- ^ Attributes of @table@ element.
+  -> Colonnade Headed a (Cell site)
+     -- ^ How to encode data as a row
+  -> a
+     -- ^ The value to display
+  -> WidgetFor site ()
+encodeDefinitionTable attrs enc a = table_ attrs $ tbody_ [] $ 
+  E.bothMonadic_ enc
+    (\theKey theValue -> tr_ [] $ do
+      widgetFromCell td_ theKey
+      widgetFromCell td_ theValue
+    ) a
+
+-- | 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:
 --
---   > table [("class","table table-striped")] ...
-table :: Foldable f
-  => [(Text,Text)] -- ^ Attributes of @table@ element
-  -> Encoding Headed (Cell site) a -- ^ How to encode data as a row
+--   > encodeCellTable (HA.class_ "table table-striped") ...
+encodeCellTable :: (Foldable f, E.Headedness h)
+  => [Attribute] -- ^ Attributes of @table@ element
+  -> Colonnade h a (Cell site) -- ^ How to encode data as a row
   -> f a -- ^ Rows of data
-  -> WidgetT site IO ()
-table attrs enc xs = tableEl attrs $ do
-  thead [] $ Encoding.runHeaderMonadic enc (widgetFromCell th)
-  tableBody enc xs
+  -> WidgetFor site ()
+encodeCellTable = encodeTable
+  (E.headednessPure mempty) mempty (const mempty) widgetFromCell 
 
-tableHeadless :: Foldable f
-  => [(Text,Text)] -- ^ Attributes of @table@ element
-  -> Encoding Headless (Cell site) a -- ^ How to encode data as a row
+-- | Encode an html table.
+encodeWidgetTable :: (Foldable f, E.Headedness h)
+  => [Attribute] -- ^ Attributes of @\<table\>@ element
+  -> Colonnade h a (WidgetFor site ()) -- ^ How to encode data as columns
   -> f a -- ^ Rows of data
-  -> WidgetT site IO ()
-tableHeadless attrs enc xs = tableEl attrs $ tableBody enc xs
+  -> WidgetFor site ()
+encodeWidgetTable = encodeTable
+  (E.headednessPure mempty) mempty (const mempty) ($ mempty) 
 
-tableBody :: Foldable f
-  => Encoding h (Cell site) a -- ^ How to encode data as a row
-  -> f a -- ^ Rows of data
-  -> WidgetT site IO ()
-tableBody enc xs = tbody [] $ do
-  forM_ xs $ \x -> do
-    tr [] $ Encoding.runRowMonadic enc (widgetFromCell td) x
+-- | 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, E.Headedness h)
+  => h [Attribute] -- ^ Attributes of @\<thead\>@
+  -> [Attribute] -- ^ Attributes of @\<tbody\>@ element
+  -> (a -> [Attribute]) -- ^ Attributes of each @\<tr\>@ element
+  -> (([Attribute] -> WidgetFor site () -> WidgetFor site ()) -> c -> WidgetFor site ()) -- ^ 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
+  -> WidgetFor site ()
+encodeTable theadAttrs tbodyAttrs trAttrs wrapContent tableAttrs colonnade xs =
+  table_ tableAttrs $ do
+    for_ E.headednessExtract $ \unhead ->
+      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 ::
-  ([(Text,Text)] -> 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,tableEl,td,th,ul,li,aTag ::
-  [(Text,Text)] -> WidgetT site IO () -> WidgetT site IO ()
-tableEl str b = [whamlet|
-  <table *{str}>^{b}
-|]
-thead str b = [whamlet|
-  <thead *{str}>^{b}
-|]
-tbody str b = [whamlet|
-  <tbody *{str}>^{b}
-|]
-tr str b = [whamlet|
-  <tr *{str}>^{b}
-|]
-th str b = [whamlet|
-  <th *{str}>^{b}
-|]
-td str b = [whamlet|
-  <td *{str}>^{b}
-|]
-ul str b = [whamlet|
-  <ul *{str}>^{b}
-|]
-li str b = [whamlet|
-  <li *{str}>^{b}
-|]
-aTag str b = [whamlet|
-  <a *{str}>^{b}
-|]
-

yesod-colonnade/yesod-colonnade.cabal

@@ -1,28 +1,33 @@
-name:                yesod-colonnade
-version:             0.1
-synopsis:            Helper functions for using yesod with colonnade
-description:         Yesod and colonnade
-homepage:            https://github.com/andrewthad/colonnade#readme
-license:             BSD3
-license-file:        LICENSE
-author:              Andrew Martin
-maintainer:          andrew.thaddeus@gmail.com
-copyright:           2016 Andrew Martin
-category:            web
-build-type:          Simple
-cabal-version:       >=1.10
+cabal-version: 2.0
+name: yesod-colonnade
+version: 1.3.0.2
+synopsis: Helper functions for using yesod with colonnade
+description: Yesod and colonnade
+homepage: https://github.com/andrewthad/colonnade#readme
+license: BSD3
+license-file: LICENSE
+author: Andrew Martin
+maintainer: andrew.thaddeus@gmail.com
+copyright: 2018 Andrew Martin
+category: web
+build-type: Simple
 
 library
-  hs-source-dirs:      src
+  hs-source-dirs: src
   exposed-modules:
     Yesod.Colonnade
   build-depends:
-      base >= 4.7 && < 5
-    , colonnade >= 0.4.6 && < 0.5
-    , yesod-core >= 1.4.0 && < 1.5
+      base >= 4.9.1 && < 4.14
+    , colonnade >= 1.2 && < 1.3
+    , yesod-core >= 1.6 && < 1.7
+    , conduit >= 1.3 && < 1.4
+    , conduit-extra >= 1.3 && < 1.4
     , text >= 1.0 && < 1.3
-  default-language:    Haskell2010
+    , 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