haskell/colonnade-old
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Compare commits

base: haskell:master
Branches Tags
haskell:master
haskell:uni2work
haskell:redo_siphon
haskell:profunctor_colonnade
haskell:add_feature
haskell:add_thing
haskell:cell_monoid_instance
..
compare: haskell:redo_siphon
Branches Tags
haskell:uni2work
haskell:master
haskell:redo_siphon
haskell:profunctor_colonnade
haskell:add_feature
haskell:add_thing
haskell:cell_monoid_instance

No commits in common. "master" and "redo_siphon" have entirely different histories.
master ... redo_sipho

33 changed files with 540 additions and 2108 deletions
Show Stats Expand all files Collapse all files

9
.gitignore vendored
View File

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

42
blaze-colonnade/blaze-colonnade.cabal
View File

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

126
blaze-colonnade/src/Text/Blaze/Colonnade.hs
View File

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

16
build
View File

@ -1,16 +0,0 @@
#!/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

4
cabal.project
View File

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

45
colonnade/colonnade.cabal
View File

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

8
colonnade/default.nix
View File

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

1
colonnade/shell.nix
View File

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

66
colonnade/src/Colonnade.hs
View File

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

194
colonnade/src/Colonnade/Encode.hs
View File

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

30
lucid-colonnade/LICENSE
View File

@ -1,30 +0,0 @@
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.

2
lucid-colonnade/Setup.hs
View File

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

29
lucid-colonnade/lucid-colonnade.cabal
View File

@ -1,29 +0,0 @@
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

292
lucid-colonnade/src/Lucid/Colonnade.hs
View File

@ -1,292 +0,0 @@
{-# 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

106
nix/default.nix
View File

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

20
nix/gtk2hs-buildtools.nix
View File

@ -1,20 +0,0 @@
{ 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;
}

6
nix/jsaddle.json
View File

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

4
nix/reflex-platform.json
View File

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

4
projects/cabal-8.0.2.project
View File

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

4
projects/cabal-8.2.2.project
View File

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

3
projects/cabal-8.4.3.project
View File

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

11
reflex-dom-colonnade/default.nix
View File

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

34
reflex-dom-colonnade/reflex-dom-colonnade.cabal
View File

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

1
reflex-dom-colonnade/shell.nix
View File

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

919
reflex-dom-colonnade/src/Reflex/Dom/Colonnade.hs
View File

File diff suppressed because it is too large Load Diff

29
siphon/siphon.cabal
View File

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

305
siphon/src/Siphon.hs
View File

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

8
siphon/test/Doctest.hs
View File

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

79
siphon/test/Test.hs
View File

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

26
stack-haddock-upload
View File

@ -1,26 +0,0 @@
#!/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

50
stack.yaml
View File

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

138
yesod-colonnade/src/Yesod/Colonnade.hs
View File

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

37
yesod-colonnade/yesod-colonnade.cabal
View File

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