`, ``, and ` | `.
-homepage: https://github.com/andrewthad/colonnade#readme
-license: BSD3
-license-file: LICENSE
-author: Andrew Martin
-maintainer: andrew.thaddeus@gmail.com
-copyright: 2017 Andrew Martin
-category: web
-build-type: Simple
-cabal-version: >=1.10
-
--- Note: There is a dependency on profunctors whose only
--- purpose is to make doctest work correctly. Since this
--- library transitively depends on profunctors anyway,
--- this is not a big deal.
-
-library
- hs-source-dirs: src
- exposed-modules:
- Text.Blaze.Colonnade
- build-depends:
- base >= 4.8 && < 5
- , colonnade >= 1.1 && < 1.3
- , blaze-markup >= 0.7 && < 0.9
- , blaze-html >= 0.8 && < 0.10
- , profunctors >= 5.0 && < 5.7
- , text >= 1.2 && < 2.1
- default-language: Haskell2010
-
-source-repository head
- type: git
- location: https://github.com/andrewthad/colonnade
diff --git a/blaze-colonnade/hackage-docs.sh b/blaze-colonnade/hackage-docs.sh
deleted file mode 100755
index 0ddbc20..0000000
--- a/blaze-colonnade/hackage-docs.sh
+++ /dev/null
@@ -1,48 +0,0 @@
-#!/bin/bash
-set -e
-
-if [ "$#" -ne 1 ]; then
- echo "Usage: scripts/hackage-docs.sh HACKAGE_USER"
- exit 1
-fi
-
-user=$1
-
-cabal_file=$(find . -maxdepth 1 -name "*.cabal" -print -quit)
-if [ ! -f "$cabal_file" ]; then
- echo "Run this script in the top-level package directory"
- exit 1
-fi
-
-pkg=$(awk -F ":[[:space:]]*" 'tolower($1)=="name" { print $2 }' < "$cabal_file")
-ver=$(awk -F ":[[:space:]]*" 'tolower($1)=="version" { print $2 }' < "$cabal_file")
-
-if [ -z "$pkg" ]; then
- echo "Unable to determine package name"
- exit 1
-fi
-
-if [ -z "$ver" ]; then
- echo "Unable to determine package version"
- exit 1
-fi
-
-echo "Detected package: $pkg-$ver"
-
-dir=$(mktemp -d build-docs.XXXXXX)
-trap 'rm -r "$dir"' EXIT
-
-# cabal haddock --hoogle --hyperlink-source --html-location='/package/$pkg-$version/docs' --contents-location='/package/$pkg-$version'
-stack haddock
-
-cp -R .stack-work/dist/x86_64-linux/Cabal-1.22.5.0/doc/html/$pkg/ $dir/$pkg-$ver-docs
-# /home/andrew/.stack/snapshots/x86_64-linux/lts-5.17/7.10.3/doc/index.html
-
-tar cvz -C $dir --format=ustar -f $dir/$pkg-$ver-docs.tar.gz $pkg-$ver-docs
-
-curl -X PUT \
- -H 'Content-Type: application/x-tar' \
- -H 'Content-Encoding: gzip' \
- -u "$user" \
- --data-binary "@$dir/$pkg-$ver-docs.tar.gz" \
- "https://hackage.haskell.org/package/$pkg-$ver/docs"
diff --git a/blaze-colonnade/src/Text/Blaze/Colonnade.hs b/blaze-colonnade/src/Text/Blaze/Colonnade.hs
deleted file mode 100644
index eec311b..0000000
--- a/blaze-colonnade/src/Text/Blaze/Colonnade.hs
+++ /dev/null
@@ -1,549 +0,0 @@
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-
--- | Build HTML tables using @blaze-html@ and @colonnade@. The bottom
--- of this page has a tutorial that walks through a full example,
--- illustrating how to meet typical needs with this library. It is
--- recommended that users read the documentation for @colonnade@ first,
--- since this library builds on the abstractions introduced there.
--- A concise example of this library\'s use:
---
--- >>> :set -XOverloadedStrings
--- >>> :module + Colonnade Text.Blaze.Html Text.Blaze.Colonnade
--- >>> let col = headed "Grade" (toHtml . fst) <> headed "Letter" (toHtml . snd)
--- >>> let rows = [("90-100",'A'),("80-89",'B'),("70-79",'C')]
--- >>> printVeryCompactHtml (encodeHtmlTable mempty col rows)
---
---
--- Grade | Letter |
---
---
--- 90-100 | A |
--- 80-89 | B |
--- 70-79 | C |
---
---
-module Text.Blaze.Colonnade
- ( -- * Apply
- encodeHtmlTable
- , encodeCellTable
- , encodeTable
- , encodeCappedTable
- -- * Cell
- -- $build
- , Cell(..)
- , htmlCell
- , stringCell
- , textCell
- , lazyTextCell
- , builderCell
- , htmlFromCell
- -- * Interactive
- , printCompactHtml
- , printVeryCompactHtml
- -- * Tutorial
- -- $setup
-
- -- * Discussion
- -- $discussion
- ) where
-
-import Text.Blaze (Attribute,(!))
-import Text.Blaze.Html (Html, toHtml)
-import Colonnade (Colonnade,Headed,Headless,Fascia,Cornice)
-import Data.Text (Text)
-import Control.Monad
-import Data.Semigroup
-import Data.Monoid hiding ((<>))
-import Data.Foldable
-import Data.String (IsString(..))
-import Data.Maybe (listToMaybe)
-import Data.Char (isSpace)
-import qualified Data.List as List
-import qualified Text.Blaze.Html.Renderer.Pretty as Pretty
-import qualified Text.Blaze as Blaze
-import qualified Text.Blaze.Html5 as H
-import qualified Text.Blaze.Html5.Attributes as HA
-import qualified Colonnade.Encode as E
-import qualified Data.Text as Text
-import qualified Data.Text.Lazy as LText
-import qualified Data.Text.Lazy.Builder as TBuilder
-
--- $setup
--- We start with a few necessary imports and some example data
--- types:
---
--- >>> :set -XOverloadedStrings
--- >>> import Data.Monoid (mconcat,(<>))
--- >>> import Data.Char (toLower)
--- >>> import Data.Profunctor (Profunctor(lmap))
--- >>> import Colonnade (Colonnade,Headed,Headless,headed,cap,Fascia(..))
--- >>> import Text.Blaze.Html (Html, toHtml, toValue)
--- >>> import qualified Text.Blaze.Html5 as H
--- >>> data Department = Management | Sales | Engineering deriving (Show,Eq)
--- >>> data Employee = Employee { name :: String, department :: Department, age :: Int }
---
--- We define some employees that we will display in a table:
---
--- >>> :{
--- let employees =
--- [ Employee "Thaddeus" Sales 34
--- , Employee "Lucia" Engineering 33
--- , Employee "Pranav" Management 57
--- ]
--- :}
---
--- Let's build a table that displays the name and the age
--- of an employee. Additionally, we will emphasize the names of
--- engineers using a @\@ tag.
---
--- >>> :{
--- let tableEmpA :: Colonnade Headed Employee Html
--- tableEmpA = mconcat
--- [ headed "Name" $ \emp -> case department emp of
--- Engineering -> H.strong (toHtml (name emp))
--- _ -> toHtml (name emp)
--- , headed "Age" (toHtml . show . age)
--- ]
--- :}
---
--- The type signature of @tableEmpA@ is inferrable but is written
--- out for clarity in this example. Additionally, note that the first
--- argument to 'headed' is of type 'Html', so @OverloadedStrings@ is
--- necessary for the above example to compile. To avoid using this extension,
--- it is possible to instead use 'toHtml' to convert a 'String' to 'Html'.
--- Let\'s continue:
---
--- >>> let customAttrs = HA.class_ "stylish-table" <> HA.id "main-table"
--- >>> printCompactHtml (encodeHtmlTable customAttrs tableEmpA employees)
---
---
---
--- Name |
--- Age |
---
---
---
---
--- Thaddeus |
--- 34 |
---
---
--- Lucia |
--- 33 |
---
---
--- Pranav |
--- 57 |
---
---
---
---
--- Excellent. As expected, Lucia\'s name is wrapped in a @\@ tag
--- since she is an engineer.
---
--- One limitation of using 'Html' as the content
--- type of a 'Colonnade' is that we are unable to add attributes to
--- the @\@ and @\ | @ elements. This library provides the 'Cell' type
--- to work around this problem. A 'Cell' is just 'Html' content and a set
--- of attributes to be applied to its parent @ | @ or @ | @. To illustrate
--- how its use, another employee table will be built. This table will
--- contain a single column indicating the department of each employ. Each
--- cell will be assigned a class name based on the department. To start off,
--- let\'s build a table that encodes departments:
---
--- >>> :{
--- let tableDept :: Colonnade Headed Department Cell
--- tableDept = mconcat
--- [ headed "Dept." $ \d -> Cell
--- (HA.class_ (toValue (map toLower (show d))))
--- (toHtml (show d))
--- ]
--- :}
---
--- Again, @OverloadedStrings@ plays a role, this time allowing the
--- literal @"Dept."@ to be accepted as a value of type 'Cell'. To avoid
--- this extension, 'stringCell' could be used to upcast the 'String'.
--- To try out our 'Colonnade' on a list of departments, we need to use
--- 'encodeCellTable' instead of 'encodeHtmlTable':
---
--- >>> let twoDepts = [Sales,Management]
--- >>> printVeryCompactHtml (encodeCellTable customAttrs tableDept twoDepts)
---
---
--- Dept. |
---
---
--- Sales |
--- Management |
---
---
---
--- The attributes on the @\ | @ elements show up as they are expected to.
--- Now, we take advantage of the @Profunctor@ instance of 'Colonnade' to allow
--- this to work on @Employee@\'s instead:
---
--- >>> :t lmap
--- lmap :: Profunctor p => (a -> b) -> p b c -> p a c
--- >>> let tableEmpB = lmap department tableDept
--- >>> :t tableEmpB
--- tableEmpB :: Colonnade Headed Employee Cell
--- >>> printVeryCompactHtml (encodeCellTable customAttrs tableEmpB employees)
---
---
--- Dept. |
---
---
--- Sales |
--- Engineering |
--- Management |
---
---
---
--- This table shows the department of each of our three employees, additionally
--- making a lowercased version of the department into a class name for the @\ | @.
--- This table is nice for illustrative purposes, but it does not provide all the
--- information that we have about the employees. If we combine it with the
--- earlier table we wrote, we can present everything in the table. One small
--- roadblock is that the types of @tableEmpA@ and @tableEmpB@ do not match, which
--- prevents a straightforward monoidal append:
---
--- >>> :t tableEmpA
--- tableEmpA :: Colonnade Headed Employee Html
--- >>> :t tableEmpB
--- tableEmpB :: Colonnade Headed Employee Cell
---
--- We can upcast the content type with 'fmap'.
--- Monoidal append is then well-typed, and the resulting 'Colonnade'
--- can be applied to the employees:
---
--- >>> let tableEmpC = fmap htmlCell tableEmpA <> tableEmpB
--- >>> :t tableEmpC
--- tableEmpC :: Colonnade Headed Employee Cell
--- >>> printCompactHtml (encodeCellTable customAttrs tableEmpC employees)
---
---
---
--- Name |
--- Age |
--- Dept. |
---
---
---
---
--- Thaddeus |
--- 34 |
--- Sales |
---
---
--- Lucia |
--- 33 |
--- Engineering |
---
---
--- Pranav |
--- 57 |
--- Management |
---
---
---
-
--- $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 @\ | @ or @\ | @ elements
--- that wrap this HTML content.
-
--- | The attributes that will be applied to a @\ | @ and
--- the HTML content that will go inside it. When using
--- this type, remember that 'Attribute', defined in @blaze-markup@,
--- is actually a collection of attributes, not a single attribute.
-data Cell = Cell
- { cellAttribute :: !Attribute
- , cellHtml :: !Html
- }
-
-instance IsString Cell where
- fromString = stringCell
-
-instance Semigroup Cell where
- (Cell a1 c1) <> (Cell a2 c2) = Cell (a1 <> a2) (c1 <> c2)
-
-instance Monoid Cell where
- mempty = Cell mempty mempty
- mappend = (<>)
-
--- | Create a 'Cell' from a 'Widget'
-htmlCell :: Html -> Cell
-htmlCell = Cell mempty
-
--- | Create a 'Cell' from a 'String'
-stringCell :: String -> Cell
-stringCell = htmlCell . fromString
-
--- | Create a 'Cell' from a 'Char'
-charCell :: Char -> Cell
-charCell = stringCell . pure
-
--- | Create a 'Cell' from a 'Text'
-textCell :: Text -> Cell
-textCell = htmlCell . toHtml
-
--- | Create a 'Cell' from a lazy text
-lazyTextCell :: LText.Text -> Cell
-lazyTextCell = textCell . LText.toStrict
-
--- | Create a 'Cell' from a text builder
-builderCell :: TBuilder.Builder -> Cell
-builderCell = lazyTextCell . TBuilder.toLazyText
-
--- | Encode a table. This handles a very general case and
--- is seldom needed by users. One of the arguments provided is
--- used to add attributes to the generated @\ | @ elements.
-encodeTable :: forall h f a c. (Foldable f, E.Headedness h)
- => h (Attribute,Attribute) -- ^ Attributes of @\@ and its @\@, pass 'Nothing' to omit @\@
- -> Attribute -- ^ Attributes of @\ @ element
- -> (a -> Attribute) -- ^ Attributes of each @\@ element
- -> ((Html -> Html) -> c -> Html) -- ^ Wrap content and convert to 'Html'
- -> Attribute -- ^ Attributes of @\@ element
- -> Colonnade h a c -- ^ How to encode data as a row
- -> f a -- ^ Collection of data
- -> Html
-encodeTable mtheadAttrs tbodyAttrs trAttrs wrapContent tableAttrs colonnade xs =
- H.table ! tableAttrs $ do
- case E.headednessExtractForall of
- Nothing -> return mempty
- Just extractForall -> do
- let (theadAttrs,theadTrAttrs) = extract mtheadAttrs
- H.thead ! theadAttrs $ H.tr ! theadTrAttrs $ do
- -- E.headerMonoidalGeneral colonnade (wrapContent H.th)
- foldlMapM' (wrapContent H.th . extract . E.oneColonnadeHead) (E.getColonnade colonnade)
- where
- extract :: forall y. h y -> y
- extract = E.runExtractForall extractForall
- encodeBody trAttrs wrapContent tbodyAttrs colonnade xs
-
-foldlMapM' :: forall g b a m. (Foldable g, Monoid b, Monad m) => (a -> m b) -> g a -> m b
-foldlMapM' f xs = foldr f' pure xs mempty
- where
- f' :: a -> (b -> m b) -> b -> m b
- f' x k bl = do
- br <- f x
- let !b = mappend bl br
- k b
-
--- | Encode a table with tiered header rows.
--- >>> let cor = mconcat [cap "Personal" (fmap htmlCell tableEmpA), cap "Work" tableEmpB]
--- >>> let fascia = FasciaCap (HA.class_ "category") (FasciaBase (HA.class_ "subcategory"))
--- >>> printCompactHtml (encodeCappedCellTable mempty fascia cor [head employees])
---
---
---
--- Personal |
--- Work |
---
---
--- Name |
--- Age |
--- Dept. |
---
---
---
---
--- Thaddeus |
--- 34 |
--- Sales |
---
---
---
-
-encodeCappedCellTable :: Foldable f
- => Attribute -- ^ Attributes of @\@ element
- -> Fascia p Attribute -- ^ Attributes for @\@ elements in the @\@
- -> Cornice Headed p a Cell
- -> f a -- ^ Collection of data
- -> Html
-encodeCappedCellTable = encodeCappedTable mempty mempty (const mempty) htmlFromCell
-
--- | Encode a table with tiered header rows. This is the most general function
--- in this library for encoding a 'Cornice'.
---
-encodeCappedTable :: Foldable f
- => Attribute -- ^ Attributes of @\@
- -> Attribute -- ^ Attributes of @\ @ element
- -> (a -> Attribute) -- ^ Attributes of each @\@ element in the @\ @
- -> ((Html -> Html) -> c -> Html) -- ^ Wrap content and convert to 'Html'
- -> Attribute -- ^ Attributes of @\@ element
- -> Fascia p Attribute -- ^ Attributes for @\@ elements in the @\@
- -> Cornice Headed p a c
- -> f a -- ^ Collection of data
- -> Html
-encodeCappedTable theadAttrs tbodyAttrs trAttrs wrapContent tableAttrs fascia cornice xs = do
- let colonnade = E.discard cornice
- annCornice = E.annotate cornice
- H.table ! tableAttrs $ do
- H.thead ! theadAttrs $ do
- E.headersMonoidal
- (Just (fascia, \attrs theHtml -> H.tr ! attrs $ theHtml))
- [ ( \msz c -> case msz of
- Just sz -> wrapContent H.th c ! HA.colspan (H.toValue (show sz))
- Nothing -> mempty
- , id
- )
- ]
- annCornice
- -- H.tr ! trAttrs $ do
- -- E.headerMonoidalGeneral colonnade (wrapContent H.th)
- encodeBody trAttrs wrapContent tbodyAttrs colonnade xs
-
-encodeBody :: Foldable f
- => (a -> Attribute) -- ^ Attributes of each @\@ element
- -> ((Html -> Html) -> c -> Html) -- ^ Wrap content and convert to 'Html'
- -> Attribute -- ^ Attributes of @\ @ element
- -> Colonnade h a c -- ^ How to encode data as a row
- -> f a -- ^ Collection of data
- -> Html
-encodeBody trAttrs wrapContent tbodyAttrs colonnade xs = do
- H.tbody ! tbodyAttrs $ do
- forM_ xs $ \x -> do
- H.tr ! trAttrs x $ E.rowMonoidal colonnade (wrapContent H.td) x
-
-
--- | Encode a table. Table cells may have attributes
--- applied to them.
-encodeCellTable ::
- Foldable f
- => Attribute -- ^ Attributes of @\@ element
- -> Colonnade Headed a Cell -- ^ How to encode data as columns
- -> f a -- ^ Collection of data
- -> Html
-encodeCellTable = encodeTable
- (E.headednessPure (mempty,mempty)) mempty (const mempty) htmlFromCell
-
--- | Encode a table. Table cell element do not have
--- any attributes applied to them.
-encodeHtmlTable ::
- (Foldable f, E.Headedness h)
- => Attribute -- ^ Attributes of @\@ element
- -> Colonnade h a Html -- ^ How to encode data as columns
- -> f a -- ^ Collection of data
- -> Html
-encodeHtmlTable = encodeTable
- (E.headednessPure (mempty,mempty)) mempty (const mempty) ($)
-
--- | Convert a 'Cell' to 'Html' by wrapping the content with a tag
--- and applying the 'Cell' attributes to that tag.
-htmlFromCell :: (Html -> Html) -> Cell -> Html
-htmlFromCell f (Cell attr content) = f ! attr $ content
-
-data St = St
- { stContext :: [String]
- , stTagStatus :: TagStatus
- , stResult :: String -> String -- ^ difference list
- }
-
-data TagStatus
- = TagStatusSomeTag
- | TagStatusOpening (String -> String)
- | TagStatusOpeningAttrs
- | TagStatusNormal
- | TagStatusClosing (String -> String)
- | TagStatusAfterTag
-
-removeWhitespaceAfterTag :: String -> String -> String
-removeWhitespaceAfterTag chosenTag =
- either id (\st -> stResult st "") . foldlM (flip f) (St [] TagStatusNormal id)
- where
- f :: Char -> St -> Either String St
- f c (St ctx status res) = case status of
- TagStatusNormal
- | c == '<' -> Right (St ctx TagStatusSomeTag likelyRes)
- | isSpace c -> if Just chosenTag == listToMaybe ctx
- then Right (St ctx TagStatusNormal res) -- drops the whitespace
- else Right (St ctx TagStatusNormal likelyRes)
- | otherwise -> Right (St ctx TagStatusNormal likelyRes)
- TagStatusSomeTag
- | c == '/' -> Right (St ctx (TagStatusClosing id) likelyRes)
- | c == '>' -> Left "unexpected >"
- | c == '<' -> Left "unexpected <"
- | otherwise -> Right (St ctx (TagStatusOpening (c:)) likelyRes)
- TagStatusOpening tag
- | c == '>' -> Right (St (tag "" : ctx) TagStatusAfterTag likelyRes)
- | isSpace c -> Right (St (tag "" : ctx) TagStatusOpeningAttrs likelyRes)
- | otherwise -> Right (St ctx (TagStatusOpening (tag . (c:))) likelyRes)
- TagStatusOpeningAttrs
- | c == '>' -> Right (St ctx TagStatusAfterTag likelyRes)
- | otherwise -> Right (St ctx TagStatusOpeningAttrs likelyRes)
- TagStatusClosing tag
- | c == '>' -> do
- otherTags <- case ctx of
- [] -> Left "closing tag without any opening tag"
- closestTag : otherTags -> if closestTag == tag ""
- then Right otherTags
- else Left $ "closing tag <" ++ tag "" ++ "> did not match opening tag <" ++ closestTag ++ ">"
- Right (St otherTags TagStatusAfterTag likelyRes)
- | otherwise -> Right (St ctx (TagStatusClosing (tag . (c:))) likelyRes)
- TagStatusAfterTag
- | c == '<' -> Right (St ctx TagStatusSomeTag likelyRes)
- | isSpace c -> if Just chosenTag == listToMaybe ctx
- then Right (St ctx TagStatusAfterTag res) -- drops the whitespace
- else Right (St ctx TagStatusNormal likelyRes)
- | otherwise -> Right (St ctx TagStatusNormal likelyRes)
- where
- likelyRes :: String -> String
- likelyRes = res . (c:)
-
--- | Pretty print an HTML table, stripping whitespace from inside @\@,
--- @\ | @, and common inline tags. The implementation is inefficient and is
--- incorrect in many corner cases. It is only provided to reduce the line
--- count of the HTML printed by GHCi examples in this module\'s documentation.
--- Use of this function is discouraged.
-printCompactHtml :: Html -> IO ()
-printCompactHtml = putStrLn
- . List.dropWhileEnd (== '\n')
- . removeWhitespaceAfterTag "td"
- . removeWhitespaceAfterTag "th"
- . removeWhitespaceAfterTag "strong"
- . removeWhitespaceAfterTag "span"
- . removeWhitespaceAfterTag "em"
- . Pretty.renderHtml
-
--- | Similar to 'printCompactHtml'. Additionally strips all whitespace inside
--- @\ | @ elements and @\@ elements.
-printVeryCompactHtml :: Html -> IO ()
-printVeryCompactHtml = putStrLn
- . List.dropWhileEnd (== '\n')
- . removeWhitespaceAfterTag "td"
- . removeWhitespaceAfterTag "th"
- . removeWhitespaceAfterTag "strong"
- . removeWhitespaceAfterTag "span"
- . removeWhitespaceAfterTag "em"
- . removeWhitespaceAfterTag "tr"
- . Pretty.renderHtml
-
-
--- $discussion
---
--- In this module, some of the functions for applying a 'Colonnade' to
--- some values to build a table have roughly this type signature:
---
--- > Foldable a => Colonnade Headedness Cell a -> f a -> Html
---
--- The 'Colonnade' content type is 'Cell', but the content
--- type of the result is 'Html'. It may not be immidiately clear why
--- this is useful done. Another strategy, which this library also
--- uses, is to write
--- these functions to take a 'Colonnade' whose content is 'Html':
---
--- > Foldable a => Colonnade Headedness Html a -> f a -> Html
---
--- When the 'Colonnade' content type is 'Html', then the header
--- content is rendered as the child of a @\@ and the row
--- content the child of a @\ | @. 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.
-
-
diff --git a/build b/build
deleted file mode 100755
index 4ee0d2e..0000000
--- a/build
+++ /dev/null
@@ -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
-
diff --git a/cabal.project b/cabal.project
deleted file mode 100644
index 14f52c7..0000000
--- a/cabal.project
+++ /dev/null
@@ -1,5 +0,0 @@
-packages: ./colonnade
- ./blaze-colonnade
- ./lucid-colonnade
- ./siphon
- ./yesod-colonnade
diff --git a/colonnade/LICENSE b/colonnade/LICENSE
deleted file mode 100644
index 9beb3f9..0000000
--- a/colonnade/LICENSE
+++ /dev/null
@@ -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.
\ No newline at end of file
diff --git a/colonnade/Setup.hs b/colonnade/Setup.hs
deleted file mode 100644
index 9a994af..0000000
--- a/colonnade/Setup.hs
+++ /dev/null
@@ -1,2 +0,0 @@
-import Distribution.Simple
-main = defaultMain
diff --git a/colonnade/colonnade.cabal b/colonnade/colonnade.cabal
deleted file mode 100644
index 8a39779..0000000
--- a/colonnade/colonnade.cabal
+++ /dev/null
@@ -1,50 +0,0 @@
-name: colonnade
-version: 1.2.0.2
-synopsis: Generic types and functions for columnar encoding and decoding
-description:
- The `colonnade` package provides a way to talk about
- columnar encodings and decodings of data. This package provides
- very general types and does not provide a way for the end-user
- to actually apply the columnar encodings they build to data.
- Most users will also want to one a companion packages
- that provides (1) a content type and (2) functions for feeding
- data into a columnar encoding:
- .
- * for `lucid` html tables
- .
- * for `blaze` html tables
- .
- * for reactive `reflex-dom` tables
- .
- * for `yesod` widgets
- .
- * for encoding and decoding CSVs
-homepage: https://github.com/andrewthad/colonnade#readme
-license: BSD3
-license-file: LICENSE
-author: Andrew Martin
-maintainer: andrew.thaddeus@gmail.com
-copyright: 2016 Andrew Martin
-category: web
-build-type: Simple
-cabal-version: >=1.10
-
-library
- hs-source-dirs: src
- exposed-modules:
- Colonnade
- Colonnade.Encode
- build-depends:
- base >= 4.12 && < 5
- , contravariant >= 1.2 && < 1.6
- , vector >= 0.10 && < 0.14
- , text >= 1.0 && < 2.1
- , bytestring >= 0.10 && < 0.12
- , profunctors >= 5.0 && < 5.7
- , semigroups >= 0.18.2 && < 0.21
- default-language: Haskell2010
- ghc-options: -Wall
-
-source-repository head
- type: git
- location: https://github.com/andrewthad/colonnade
diff --git a/colonnade/hackage-docs.sh b/colonnade/hackage-docs.sh
deleted file mode 100755
index 0ddbc20..0000000
--- a/colonnade/hackage-docs.sh
+++ /dev/null
@@ -1,48 +0,0 @@
-#!/bin/bash
-set -e
-
-if [ "$#" -ne 1 ]; then
- echo "Usage: scripts/hackage-docs.sh HACKAGE_USER"
- exit 1
-fi
-
-user=$1
-
-cabal_file=$(find . -maxdepth 1 -name "*.cabal" -print -quit)
-if [ ! -f "$cabal_file" ]; then
- echo "Run this script in the top-level package directory"
- exit 1
-fi
-
-pkg=$(awk -F ":[[:space:]]*" 'tolower($1)=="name" { print $2 }' < "$cabal_file")
-ver=$(awk -F ":[[:space:]]*" 'tolower($1)=="version" { print $2 }' < "$cabal_file")
-
-if [ -z "$pkg" ]; then
- echo "Unable to determine package name"
- exit 1
-fi
-
-if [ -z "$ver" ]; then
- echo "Unable to determine package version"
- exit 1
-fi
-
-echo "Detected package: $pkg-$ver"
-
-dir=$(mktemp -d build-docs.XXXXXX)
-trap 'rm -r "$dir"' EXIT
-
-# cabal haddock --hoogle --hyperlink-source --html-location='/package/$pkg-$version/docs' --contents-location='/package/$pkg-$version'
-stack haddock
-
-cp -R .stack-work/dist/x86_64-linux/Cabal-1.22.5.0/doc/html/$pkg/ $dir/$pkg-$ver-docs
-# /home/andrew/.stack/snapshots/x86_64-linux/lts-5.17/7.10.3/doc/index.html
-
-tar cvz -C $dir --format=ustar -f $dir/$pkg-$ver-docs.tar.gz $pkg-$ver-docs
-
-curl -X PUT \
- -H 'Content-Type: application/x-tar' \
- -H 'Content-Encoding: gzip' \
- -u "$user" \
- --data-binary "@$dir/$pkg-$ver-docs.tar.gz" \
- "https://hackage.haskell.org/package/$pkg-$ver/docs"
diff --git a/colonnade/src/Colonnade.hs b/colonnade/src/Colonnade.hs
deleted file mode 100644
index bc54acb..0000000
--- a/colonnade/src/Colonnade.hs
+++ /dev/null
@@ -1,438 +0,0 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE RankNTypes #-}
-
-{-# OPTIONS_GHC -Wall -fno-warn-unused-imports -fno-warn-unticked-promoted-constructors #-}
-
--- | Build backend-agnostic columnar encodings that can be
--- used to visualize tabular data.
-module Colonnade
- ( -- * Example
- -- $setup
- -- * Types
- Colonnade
- , Headed(..)
- , Headless(..)
- -- * Typeclasses
- , E.Headedness(..)
- -- * Create
- , headed
- , headless
- , singleton
- -- * Transform
- -- ** Body
- , fromMaybe
- , columns
- , bool
- , replaceWhen
- , modifyWhen
- -- ** Header
- , mapHeaderContent
- , mapHeadedness
- , toHeadless
- -- * Cornice
- -- ** Types
- , Cornice
- , Pillar(..)
- , Fascia(..)
- -- ** Create
- , cap
- , recap
- -- * Ascii Table
- , ascii
- , asciiCapped
- ) where
-
-import Colonnade.Encode (Colonnade,Cornice,
- Pillar(..),Fascia(..),Headed(..),Headless(..))
-import Data.Foldable
-import Control.Monad
-import qualified Data.Bool
-import qualified Data.Maybe
-import qualified Colonnade.Encode as E
-import qualified Data.List as List
-import qualified Data.Vector as Vector
-
--- $setup
---
--- First, let\'s bring in some neccessary imports that will be
--- used for the remainder of the examples in the docs:
---
--- >>> import Data.Monoid (mconcat,(<>))
--- >>> import Data.Profunctor (lmap)
---
--- The data types we wish to encode are:
---
--- >>> data Color = Red | Green | Blue deriving (Show,Eq)
--- >>> data Person = Person { name :: String, age :: Int }
--- >>> data House = House { color :: Color, price :: Int }
---
--- One potential columnar encoding of a @Person@ would be:
---
--- >>> :{
--- let colPerson :: Colonnade Headed Person String
--- colPerson = mconcat
--- [ headed "Name" name
--- , headed "Age" (show . age)
--- ]
--- :}
---
--- The type signature on @colPerson@ is not neccessary
--- but is included for clarity. We can feed data into this encoding
--- to build a table:
---
--- >>> let people = [Person "David" 63, Person "Ava" 34, Person "Sonia" 12]
--- >>> putStr (ascii colPerson people)
--- +-------+-----+
--- | Name | Age |
--- +-------+-----+
--- | David | 63 |
--- | Ava | 34 |
--- | Sonia | 12 |
--- +-------+-----+
---
--- Similarly, we can build a table of houses with:
---
--- >>> let showDollar = (('$':) . show) :: Int -> String
--- >>> colHouse = mconcat [headed "Color" (show . color), headed "Price" (showDollar . price)]
--- >>> :t colHouse
--- colHouse :: Colonnade Headed House String
--- >>> let houses = [House Green 170000, House Blue 115000, House Green 150000]
--- >>> putStr (ascii colHouse houses)
--- +-------+---------+
--- | Color | Price |
--- +-------+---------+
--- | Green | $170000 |
--- | Blue | $115000 |
--- | Green | $150000 |
--- +-------+---------+
-
-
--- | A single column with a header.
-headed :: c -> (a -> c) -> Colonnade Headed a c
-headed h = singleton (Headed h)
-
--- | A single column without a header.
-headless :: (a -> c) -> Colonnade Headless a c
-headless = singleton Headless
-
--- | A single column with any kind of header. This is not typically needed.
-singleton :: h c -> (a -> c) -> Colonnade h a c
-singleton h = E.Colonnade . Vector.singleton . E.OneColonnade h
-
--- | Map over the content in the header. This is similar performing 'fmap'
--- on a 'Colonnade' except that the body content is unaffected.
-mapHeaderContent :: Functor h => (c -> c) -> Colonnade h a c -> Colonnade h a c
-mapHeaderContent f (E.Colonnade v) =
- E.Colonnade (Vector.map (\(E.OneColonnade h e) -> E.OneColonnade (fmap f h) e) v)
-
--- | Map over the header type of a 'Colonnade'.
-mapHeadedness :: (forall x. h x -> h' x) -> Colonnade h a c -> Colonnade h' a c
-mapHeadedness f (E.Colonnade v) =
- E.Colonnade (Vector.map (\(E.OneColonnade h e) -> E.OneColonnade (f h) e) v)
-
--- | Remove the heading from a 'Colonnade'.
-toHeadless :: Colonnade h a c -> Colonnade Headless a c
-toHeadless = mapHeadedness (const Headless)
-
-
--- | Lift a column over a 'Maybe'. For example, if some people
--- have houses and some do not, the data that pairs them together
--- could be represented as:
---
--- >>> :{
--- let owners :: [(Person,Maybe House)]
--- owners =
--- [ (Person "Jordan" 18, Nothing)
--- , (Person "Ruth" 25, Just (House Red 125000))
--- , (Person "Sonia" 12, Just (House Green 145000))
--- ]
--- :}
---
--- The column encodings defined earlier can be reused with
--- the help of 'fromMaybe':
---
--- >>> :{
--- let colOwners :: Colonnade Headed (Person,Maybe House) String
--- colOwners = mconcat
--- [ lmap fst colPerson
--- , lmap snd (fromMaybe "" colHouse)
--- ]
--- :}
---
--- >>> putStr (ascii colOwners owners)
--- +--------+-----+-------+---------+
--- | Name | Age | Color | Price |
--- +--------+-----+-------+---------+
--- | Jordan | 18 | | |
--- | Ruth | 25 | Red | $125000 |
--- | Sonia | 12 | Green | $145000 |
--- +--------+-----+-------+---------+
-fromMaybe :: c -> Colonnade f a c -> Colonnade f (Maybe a) c
-fromMaybe c (E.Colonnade v) = E.Colonnade $ flip Vector.map v $
- \(E.OneColonnade h encode) -> E.OneColonnade h (maybe c encode)
-
--- | Convert a collection of @b@ values into a columnar encoding of
--- the same size. Suppose we decide to show a house\'s color
--- by putting a check mark in the column corresponding to
--- the color instead of by writing out the name of the color:
---
--- >>> let allColors = [Red,Green,Blue]
--- >>> let encColor = columns (\c1 c2 -> if c1 == c2 then "✓" else "") (Headed . show) allColors
--- >>> :t encColor
--- encColor :: Colonnade Headed Color String
--- >>> let encHouse = headed "Price" (showDollar . price) <> lmap color encColor
--- >>> :t encHouse
--- encHouse :: Colonnade Headed House String
--- >>> putStr (ascii encHouse houses)
--- +---------+-----+-------+------+
--- | Price | Red | Green | Blue |
--- +---------+-----+-------+------+
--- | $170000 | | ✓ | |
--- | $115000 | | | ✓ |
--- | $150000 | | ✓ | |
--- +---------+-----+-------+------+
-columns :: Foldable g
- => (b -> a -> c) -- ^ Cell content function
- -> (b -> f c) -- ^ Header content function
- -> g b -- ^ Basis for column encodings
- -> Colonnade f a c
-columns getCell getHeader = id
- . E.Colonnade
- . Vector.map (\b -> E.OneColonnade (getHeader b) (getCell b))
- . Vector.fromList
- . toList
-
-bool ::
- f c -- ^ Heading
- -> (a -> Bool) -- ^ Predicate
- -> (a -> c) -- ^ Contents when predicate is false
- -> (a -> c) -- ^ Contents when predicate is true
- -> Colonnade f a c
-bool h p onTrue onFalse = singleton h (Data.Bool.bool <$> onFalse <*> onTrue <*> p)
-
--- | Modify the contents of cells in rows whose values satisfy the
--- given predicate. Header content is unaffected. With an HTML backend,
--- this can be used to strikethrough the contents of cells with data that is
--- considered invalid.
-modifyWhen ::
- (c -> c) -- ^ Content change
- -> (a -> Bool) -- ^ Row predicate
- -> Colonnade f a c -- ^ Original 'Colonnade'
- -> Colonnade f a c
-modifyWhen changeContent p (E.Colonnade v) = E.Colonnade
- ( Vector.map
- (\(E.OneColonnade h encode) -> E.OneColonnade h $ \a ->
- if p a then changeContent (encode a) else encode a
- ) v
- )
-
--- | Replace the contents of cells in rows whose values satisfy the
--- given predicate. Header content is unaffected.
-replaceWhen ::
- c -- ^ New content
- -> (a -> Bool) -- ^ Row predicate
- -> Colonnade f a c -- ^ Original 'Colonnade'
- -> Colonnade f a c
-replaceWhen = modifyWhen . const
-
--- | Augment a 'Colonnade' with a header spans over all of the
--- existing headers. This is best demonstrated by example.
--- Let\'s consider how we might encode a pairing of the people
--- and houses from the initial example:
---
--- >>> let personHomePairs = zip people houses
--- >>> let colPersonFst = lmap fst colPerson
--- >>> let colHouseSnd = lmap snd colHouse
--- >>> putStr (ascii (colPersonFst <> colHouseSnd) personHomePairs)
--- +-------+-----+-------+---------+
--- | Name | Age | Color | Price |
--- +-------+-----+-------+---------+
--- | David | 63 | Green | $170000 |
--- | Ava | 34 | Blue | $115000 |
--- | Sonia | 12 | Green | $150000 |
--- +-------+-----+-------+---------+
---
--- This tabular encoding leaves something to be desired. The heading
--- not indicate that the name and age refer to a person and that
--- the color and price refer to a house. Without reaching for 'Cornice',
--- we can still improve this situation with 'mapHeaderContent':
---
--- >>> let colPersonFst' = mapHeaderContent ("Person " ++) colPersonFst
--- >>> let colHouseSnd' = mapHeaderContent ("House " ++) colHouseSnd
--- >>> putStr (ascii (colPersonFst' <> colHouseSnd') personHomePairs)
--- +-------------+------------+-------------+-------------+
--- | Person Name | Person Age | House Color | House Price |
--- +-------------+------------+-------------+-------------+
--- | David | 63 | Green | $170000 |
--- | Ava | 34 | Blue | $115000 |
--- | Sonia | 12 | Green | $150000 |
--- +-------------+------------+-------------+-------------+
---
--- This is much better, but for longer tables, the redundancy
--- of prefixing many column headers can become annoying. The solution
--- that a 'Cornice' offers is to nest headers:
---
--- >>> let cor = mconcat [cap "Person" colPersonFst, cap "House" colHouseSnd]
--- >>> :t cor
--- cor :: Cornice Headed ('Cap 'Base) (Person, House) String
--- >>> putStr (asciiCapped cor personHomePairs)
--- +-------------+-----------------+
--- | Person | House |
--- +-------+-----+-------+---------+
--- | Name | Age | Color | Price |
--- +-------+-----+-------+---------+
--- | David | 63 | Green | $170000 |
--- | Ava | 34 | Blue | $115000 |
--- | Sonia | 12 | Green | $150000 |
--- +-------+-----+-------+---------+
---
-cap :: c -> Colonnade h a c -> Cornice h (Cap Base) a c
-cap h = E.CorniceCap . Vector.singleton . E.OneCornice h . E.CorniceBase
-
--- | Add another cap to a cornice. There is no limit to how many times
--- this can be applied:
---
--- >>> data Day = Weekday | Weekend deriving (Show)
--- >>> :{
--- let cost :: Int -> Day -> String
--- cost base w = case w of
--- Weekday -> showDollar base
--- Weekend -> showDollar (base + 1)
--- colStandard = foldMap (\c -> headed c (cost 8)) ["Yt","Ad","Sr"]
--- colSpecial = mconcat [headed "Stud" (cost 6), headed "Mltry" (cost 7)]
--- corStatus = mconcat
--- [ cap "Standard" colStandard
--- , cap "Special" colSpecial
--- ]
--- corShowtime = mconcat
--- [ recap "" (cap "" (headed "Day" show))
--- , foldMap (\c -> recap c corStatus) ["Matinee","Evening"]
--- ]
--- :}
---
--- >>> putStr (asciiCapped corShowtime [Weekday,Weekend])
--- +---------+-----------------------------+-----------------------------+
--- | | Matinee | Evening |
--- +---------+--------------+--------------+--------------+--------------+
--- | | Standard | Special | Standard | Special |
--- +---------+----+----+----+------+-------+----+----+----+------+-------+
--- | Day | Yt | Ad | Sr | Stud | Mltry | Yt | Ad | Sr | Stud | Mltry |
--- +---------+----+----+----+------+-------+----+----+----+------+-------+
--- | Weekday | $8 | $8 | $8 | $6 | $7 | $8 | $8 | $8 | $6 | $7 |
--- | Weekend | $9 | $9 | $9 | $7 | $8 | $9 | $9 | $9 | $7 | $8 |
--- +---------+----+----+----+------+-------+----+----+----+------+-------+
-recap :: c -> Cornice h p a c -> Cornice h (Cap p) a c
-recap h cor = E.CorniceCap (Vector.singleton (E.OneCornice h cor))
-
-asciiCapped :: Foldable f
- => Cornice Headed p a String -- ^ columnar encoding
- -> f a -- ^ rows
- -> String
-asciiCapped cor xs =
- let annCor = E.annotateFinely (\x y -> x + y + 3) id
- List.length xs cor
- sizedCol = E.uncapAnnotated annCor
- in E.headersMonoidal
- Nothing
- [ ( \msz _ -> case msz of
- Just sz -> "+" ++ hyphens (sz + 2)
- Nothing -> ""
- , \s -> s ++ "+\n"
- )
- , ( \msz c -> case msz of
- Just sz -> "| " ++ rightPad sz ' ' c ++ " "
- Nothing -> ""
- , \s -> s ++ "|\n"
- )
- ] annCor ++ asciiBody sizedCol xs
-
-
--- | Render a collection of rows as an ascii table. The table\'s columns are
--- specified by the given 'Colonnade'. This implementation is inefficient and
--- does not provide any wrapping behavior. It is provided so that users can
--- try out @colonnade@ in ghci and so that @doctest@ can verify example
--- code in the haddocks.
-ascii :: Foldable f
- => Colonnade Headed a String -- ^ columnar encoding
- -> f a -- ^ rows
- -> String
-ascii col xs =
- let sizedCol = E.sizeColumns List.length xs col
- divider = concat
- [ E.headerMonoidalFull sizedCol
- (\(E.Sized msz _) -> case msz of
- Just sz -> "+" ++ hyphens (sz + 2)
- Nothing -> ""
- )
- , "+\n"
- ]
- in List.concat
- [ divider
- , concat
- [ E.headerMonoidalFull sizedCol
- (\(E.Sized msz (Headed h)) -> case msz of
- Just sz -> "| " ++ rightPad sz ' ' h ++ " "
- Nothing -> ""
- )
- , "|\n"
- ]
- , asciiBody sizedCol xs
- ]
-
-asciiBody :: Foldable f
- => Colonnade (E.Sized (Maybe Int) Headed) a String
- -> f a
- -> String
-asciiBody sizedCol xs =
- let divider = concat
- [ E.headerMonoidalFull sizedCol
- (\(E.Sized msz _) -> case msz of
- Just sz -> "+" ++ hyphens (sz + 2)
- Nothing -> ""
- )
- , "+\n"
- ]
- rowContents = foldMap
- (\x -> concat
- [ E.rowMonoidalHeader
- sizedCol
- (\(E.Sized msz _) c -> case msz of
- Nothing -> ""
- Just sz -> "| " ++ rightPad sz ' ' c ++ " "
- )
- x
- , "|\n"
- ]
- ) xs
- in List.concat
- [ divider
- , rowContents
- , divider
- ]
-
-hyphens :: Int -> String
-hyphens n = List.replicate n '-'
-
-rightPad :: Int -> a -> [a] -> [a]
-rightPad m a xs = take m $ xs ++ repeat a
-
--- data Company = Company String String Int
---
--- data Company = Company
--- { companyName :: String
--- , companyCountry :: String
--- , companyValue :: Int
--- } deriving (Show)
---
--- myCompanies :: [Company]
--- myCompanies =
--- [ Company "eCommHub" "United States" 50
--- , Company "Layer 3 Communications" "United States" 10000000
--- , Company "Microsoft" "England" 500000000
--- ]
-
-
-
-
-
-
diff --git a/colonnade/src/Colonnade/Encode.hs b/colonnade/src/Colonnade/Encode.hs
deleted file mode 100644
index bd85958..0000000
--- a/colonnade/src/Colonnade/Encode.hs
+++ /dev/null
@@ -1,691 +0,0 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DeriveFoldable #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE KindSignatures #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-
-{-# OPTIONS_HADDOCK not-home #-}
-{-# OPTIONS_GHC -Wall -fno-warn-unused-imports -fno-warn-unticked-promoted-constructors #-}
-
--- | Most users of this library do not need this module. The functions
--- here are used to build functions that apply a 'Colonnade'
--- to a collection of values, building a table from them. Ultimately,
--- a function that applies a @Colonnade Headed MyCell a@
--- to data will have roughly the following type:
---
--- > myTableRenderer :: Foldable g => Colonnade Headed MyCell a -> g a -> MyContent
---
--- In the companion packages @yesod-colonnade@ and
--- @reflex-dom-colonnade@, functions with
--- similar type signatures are readily available.
--- These packages use the functions provided here
--- in the implementations of their rendering functions.
--- It is recommended that users who believe they may need
--- this module look at the source of the companion packages
--- to see an example of how this module\'s functions are used.
--- Other backends are encouraged to use these functions
--- to build monadic or monoidal content from a 'Colonnade'.
---
--- The functions exported here take a 'Colonnade' and
--- convert it to a fragment of content. The functions whose
--- names start with @row@ take at least a @Colonnade f c a@ and an @a@
--- value to generate a row of content. The functions whose names
--- start with @header@ need the @Colonnade f c a@ but not
--- an @a@ value since a value is not needed to build a header.
---
-module Colonnade.Encode
- ( -- * Colonnade
- -- ** Types
- Colonnade(..)
- , OneColonnade(..)
- , Headed(..)
- , Headless(..)
- , Sized(..)
- , ExtractForall(..)
- -- ** Typeclasses
- , Headedness(..)
- -- ** Row
- , row
- , rowMonadic
- , rowMonadic_
- , rowMonadicWith
- , rowMonoidal
- , rowMonoidalHeader
- -- ** Header
- , header
- , headerMonadic
- , headerMonadic_
- , headerMonadicGeneral
- , headerMonadicGeneral_
- , headerMonoidalGeneral
- , headerMonoidalFull
- -- ** Other
- , bothMonadic_
- , sizeColumns
- -- * Cornice
- -- ** Types
- , Cornice(..)
- , AnnotatedCornice(..)
- , OneCornice(..)
- , Pillar(..)
- , ToEmptyCornice(..)
- , Fascia(..)
- -- ** Encoding
- , annotate
- , annotateFinely
- , size
- , endow
- , discard
- , headersMonoidal
- , uncapAnnotated
- ) where
-
-import Data.Vector (Vector)
-import Data.Foldable
-import Control.Monad.ST (ST,runST)
-import Data.Monoid
-import Data.Functor.Contravariant (Contravariant(..))
-import Data.Profunctor (Profunctor(..))
-import Data.Semigroup (Semigroup)
-import Data.List.NonEmpty (NonEmpty((:|)))
-import Data.Foldable (toList)
-import qualified Data.Semigroup as Semigroup
-import qualified Data.Vector as Vector
-import qualified Data.Vector as V
-import qualified Data.Vector.Unboxed.Mutable as MVU
-import qualified Data.Vector.Unboxed as VU
-import qualified Data.Vector as V
-import qualified Data.Vector as Vector
-import qualified Data.Vector.Generic as GV
-
--- | Consider providing a variant the produces a list
--- instead. It may allow more things to get inlined
--- in to a loop.
-row :: (c1 -> c2) -> Colonnade f a c1 -> a -> Vector c2
-row g (Colonnade v) a = flip Vector.map v $
- \(OneColonnade _ encode) -> g (encode a)
-
-bothMonadic_ :: Monad m
- => Colonnade Headed a c
- -> (c -> c -> m b)
- -> a
- -> m ()
-bothMonadic_ (Colonnade v) g a =
- forM_ v $ \(OneColonnade (Headed h) encode) -> g h (encode a)
-
-rowMonadic ::
- (Monad m, Monoid b)
- => Colonnade f a c
- -> (c -> m b)
- -> a
- -> m b
-rowMonadic (Colonnade v) g a =
- flip foldlMapM v
- $ \e -> g (oneColonnadeEncode e a)
-
-rowMonadic_ ::
- Monad m
- => Colonnade f a c
- -> (c -> m b)
- -> a
- -> m ()
-rowMonadic_ (Colonnade v) g a =
- forM_ v $ \e -> g (oneColonnadeEncode e a)
-
-rowMonoidal ::
- Monoid m
- => Colonnade h a c
- -> (c -> m)
- -> a
- -> m
-rowMonoidal (Colonnade v) g a =
- foldMap (\(OneColonnade _ encode) -> g (encode a)) v
-
-rowMonoidalHeader ::
- Monoid m
- => Colonnade h a c
- -> (h c -> c -> m)
- -> a
- -> m
-rowMonoidalHeader (Colonnade v) g a =
- foldMap (\(OneColonnade h encode) -> g h (encode a)) v
-
-rowUpdateSize ::
- (c -> Int) -- ^ Get size from content
- -> MutableSizedColonnade s h a c
- -> a
- -> ST s ()
-rowUpdateSize toSize (MutableSizedColonnade v mv) a = if MVU.length mv /= V.length v
- then error "rowMonoidalSize: vector sizes mismatched"
- else V.imapM_ (\ix (OneColonnade _ encode) ->
- MVU.modify mv (\oldSize -> max oldSize (toSize (encode a))) ix
- ) v
-
-headerUpdateSize :: Foldable h
- => (c -> Int) -- ^ Get size from content
- -> MutableSizedColonnade s h a c
- -> ST s ()
-headerUpdateSize toSize (MutableSizedColonnade v mv) = if MVU.length mv /= V.length v
- then error "rowMonoidalSize: vector sizes mismatched"
- else V.imapM_ (\ix (OneColonnade h _) ->
- MVU.modify mv (\oldSize -> max oldSize (foldl' (\sz c -> max sz (toSize c)) 0 h)) ix
- ) v
-
-sizeColumns :: (Foldable f, Foldable h)
- => (c -> Int) -- ^ Get size from content
- -> f a
- -> Colonnade h a c
- -> Colonnade (Sized (Maybe Int) h) a c
-sizeColumns toSize rows colonnade = runST $ do
- mcol <- newMutableSizedColonnade colonnade
- headerUpdateSize toSize mcol
- mapM_ (rowUpdateSize toSize mcol) rows
- freezeMutableSizedColonnade mcol
-
-newMutableSizedColonnade :: Colonnade h a c -> ST s (MutableSizedColonnade s h a c)
-newMutableSizedColonnade (Colonnade v) = do
- mv <- MVU.replicate (V.length v) 0
- return (MutableSizedColonnade v mv)
-
-freezeMutableSizedColonnade :: MutableSizedColonnade s h a c -> ST s (Colonnade (Sized (Maybe Int) h) a c)
-freezeMutableSizedColonnade (MutableSizedColonnade v mv) =
- if MVU.length mv /= V.length v
- then error "rowMonoidalSize: vector sizes mismatched"
- else do
- sizeVec <- VU.freeze mv
- return $ Colonnade
- $ V.map (\(OneColonnade h enc,sz) -> OneColonnade (Sized (Just sz) h) enc)
- $ V.zip v (GV.convert sizeVec)
-
-rowMonadicWith ::
- (Monad m)
- => b
- -> (b -> b -> b)
- -> Colonnade f a c
- -> (c -> m b)
- -> a
- -> m b
-rowMonadicWith bempty bappend (Colonnade v) g a =
- foldlM (\bl e -> do
- br <- g (oneColonnadeEncode e a)
- return (bappend bl br)
- ) bempty v
-
-header :: (c1 -> c2) -> Colonnade Headed a c1 -> Vector c2
-header g (Colonnade v) =
- Vector.map (g . getHeaded . oneColonnadeHead) v
-
--- | This function is a helper for abusing 'Foldable' to optionally
--- render a header. Its future is uncertain.
-headerMonadicGeneral :: (Monad m, Monoid b, Foldable h)
- => Colonnade h a c
- -> (c -> m b)
- -> m b
-headerMonadicGeneral (Colonnade v) g = id
- $ fmap (mconcat . Vector.toList)
- $ Vector.mapM (foldlMapM g . oneColonnadeHead) v
-
-headerMonadic ::
- (Monad m, Monoid b)
- => Colonnade Headed a c
- -> (c -> m b)
- -> m b
-headerMonadic (Colonnade v) g =
- fmap (mconcat . Vector.toList) $ Vector.mapM (g . getHeaded . oneColonnadeHead) v
-
-headerMonadicGeneral_ ::
- (Monad m, Headedness h)
- => Colonnade h a c
- -> (c -> m b)
- -> m ()
-headerMonadicGeneral_ (Colonnade v) g = case headednessExtract of
- Nothing -> return ()
- Just f -> Vector.mapM_ (g . f . oneColonnadeHead) v
-
-headerMonoidalGeneral ::
- (Monoid m, Foldable h)
- => Colonnade h a c
- -> (c -> m)
- -> m
-headerMonoidalGeneral (Colonnade v) g =
- foldMap (foldMap g . oneColonnadeHead) v
-
-headerMonoidalFull ::
- Monoid m
- => Colonnade h a c
- -> (h c -> m)
- -> m
-headerMonoidalFull (Colonnade v) g = foldMap (g . oneColonnadeHead) v
-
-headerMonadic_ ::
- (Monad m)
- => Colonnade Headed a c
- -> (c -> m b)
- -> m ()
-headerMonadic_ (Colonnade v) g = Vector.mapM_ (g . getHeaded . oneColonnadeHead) v
-
-foldlMapM :: (Foldable t, Monoid b, Monad m) => (a -> m b) -> t a -> m b
-foldlMapM f = foldlM (\b a -> fmap (mappend b) (f a)) mempty
-
-discard :: Cornice h p a c -> Colonnade h a c
-discard = go where
- go :: forall h p a c. Cornice h p a c -> Colonnade h a c
- go (CorniceBase c) = c
- go (CorniceCap children) = Colonnade (getColonnade . go . oneCorniceBody =<< children)
-
-endow :: forall p a c. (c -> c -> c) -> Cornice Headed p a c -> Colonnade Headed a c
-endow f x = case x of
- CorniceBase colonnade -> colonnade
- CorniceCap v -> Colonnade (V.concatMap (\(OneCornice h b) -> go h b) v)
- where
- go :: forall p'. c -> Cornice Headed p' a c -> Vector (OneColonnade Headed a c)
- go c (CorniceBase (Colonnade v)) = V.map (mapOneColonnadeHeader (f c)) v
- go c (CorniceCap v) = V.concatMap (\(OneCornice h b) -> go (f c h) b) v
-
-uncapAnnotated :: forall sz p a c h.
- AnnotatedCornice sz h p a c
- -> Colonnade (Sized sz h) a c
-uncapAnnotated x = case x of
- AnnotatedCorniceBase _ colonnade -> colonnade
- AnnotatedCorniceCap _ v -> Colonnade (V.concatMap (\(OneCornice _ b) -> go b) v)
- where
- go :: forall p'.
- AnnotatedCornice sz h p' a c
- -> Vector (OneColonnade (Sized sz h) a c)
- go (AnnotatedCorniceBase _ (Colonnade v)) = v
- go (AnnotatedCorniceCap _ v) = V.concatMap (\(OneCornice _ b) -> go b) v
-
-annotate :: Cornice Headed p a c -> AnnotatedCornice (Maybe Int) Headed p a c
-annotate = go where
- go :: forall p a c. Cornice Headed p a c -> AnnotatedCornice (Maybe Int) Headed p a c
- go (CorniceBase c) = let len = V.length (getColonnade c) in
- AnnotatedCorniceBase
- (if len > 0 then (Just len) else Nothing)
- (mapHeadedness (Sized (Just 1)) c)
- go (CorniceCap children) =
- let annChildren = fmap (mapOneCorniceBody go) children
- in AnnotatedCorniceCap
- ( ( ( V.foldl' (combineJustInt (+))
- ) Nothing . V.map (size . oneCorniceBody)
- ) annChildren
- )
- annChildren
-
-combineJustInt :: (Int -> Int -> Int) -> Maybe Int -> Maybe Int -> Maybe Int
-combineJustInt f acc el = case acc of
- Nothing -> case el of
- Nothing -> Nothing
- Just i -> Just i
- Just i -> case el of
- Nothing -> Just i
- Just j -> Just (f i j)
-
-mapJustInt :: (Int -> Int) -> Maybe Int -> Maybe Int
-mapJustInt _ Nothing = Nothing
-mapJustInt f (Just i) = Just (f i)
-
-annotateFinely :: Foldable f
- => (Int -> Int -> Int) -- ^ fold function
- -> (Int -> Int) -- ^ finalize
- -> (c -> Int) -- ^ Get size from content
- -> f a
- -> Cornice Headed p a c
- -> AnnotatedCornice (Maybe Int) Headed p a c
-annotateFinely g finish toSize xs cornice = runST $ do
- m <- newMutableSizedCornice cornice
- sizeColonnades toSize xs m
- freezeMutableSizedCornice g finish m
-
-sizeColonnades :: forall f s p a c.
- Foldable f
- => (c -> Int) -- ^ Get size from content
- -> f a
- -> MutableSizedCornice s p a c
- -> ST s ()
-sizeColonnades toSize xs cornice = do
- goHeader cornice
- mapM_ (goRow cornice) xs
- where
- goRow :: forall p'. MutableSizedCornice s p' a c -> a -> ST s ()
- goRow (MutableSizedCorniceBase c) a = rowUpdateSize toSize c a
- goRow (MutableSizedCorniceCap children) a = mapM_ (flip goRow a . oneCorniceBody) children
- goHeader :: forall p'. MutableSizedCornice s p' a c -> ST s ()
- goHeader (MutableSizedCorniceBase c) = headerUpdateSize toSize c
- goHeader (MutableSizedCorniceCap children) = mapM_ (goHeader . oneCorniceBody) children
-
-freezeMutableSizedCornice :: forall s p a c.
- (Int -> Int -> Int) -- ^ fold function
- -> (Int -> Int) -- ^ finalize
- -> MutableSizedCornice s p a c
- -> ST s (AnnotatedCornice (Maybe Int) Headed p a c)
-freezeMutableSizedCornice step finish = go
- where
- go :: forall p' a' c'.
- MutableSizedCornice s p' a' c'
- -> ST s (AnnotatedCornice (Maybe Int) Headed p' a' c')
- go (MutableSizedCorniceBase msc) = do
- szCol <- freezeMutableSizedColonnade msc
- let sz =
- ( mapJustInt finish
- . V.foldl' (combineJustInt step) Nothing
- . V.map (sizedSize . oneColonnadeHead)
- ) (getColonnade szCol)
- return (AnnotatedCorniceBase sz szCol)
- go (MutableSizedCorniceCap v1) = do
- v2 <- V.mapM (traverseOneCorniceBody go) v1
- let sz =
- ( mapJustInt finish
- . V.foldl' (combineJustInt step) Nothing
- . V.map (size . oneCorniceBody)
- ) v2
- return $ AnnotatedCorniceCap sz v2
-
-newMutableSizedCornice :: forall s p a c.
- Cornice Headed p a c
- -> ST s (MutableSizedCornice s p a c)
-newMutableSizedCornice = go where
- go :: forall p'. Cornice Headed p' a c -> ST s (MutableSizedCornice s p' a c)
- go (CorniceBase c) = fmap MutableSizedCorniceBase (newMutableSizedColonnade c)
- go (CorniceCap v) = fmap MutableSizedCorniceCap (V.mapM (traverseOneCorniceBody go) v)
-
-traverseOneCorniceBody :: Monad m => (k p a c -> m (j p a c)) -> OneCornice k p a c -> m (OneCornice j p a c)
-traverseOneCorniceBody f (OneCornice h b) = fmap (OneCornice h) (f b)
-
-mapHeadedness :: (forall x. h x -> h' x) -> Colonnade h a c -> Colonnade h' a c
-mapHeadedness f (Colonnade v) =
- Colonnade (V.map (\(OneColonnade h c) -> OneColonnade (f h) c) v)
-
-
--- | This is an O(1) operation, sort of
-size :: AnnotatedCornice sz h p a c -> sz
-size x = case x of
- AnnotatedCorniceBase m _ -> m
- AnnotatedCorniceCap sz _ -> sz
-
-mapOneCorniceBody :: (forall p' a' c'. k p' a' c' -> j p' a' c') -> OneCornice k p a c -> OneCornice j p a c
-mapOneCorniceBody f (OneCornice h b) = OneCornice h (f b)
-
-mapOneColonnadeHeader :: Functor h => (c -> c) -> OneColonnade h a c -> OneColonnade h a c
-mapOneColonnadeHeader f (OneColonnade h b) = OneColonnade (fmap f h) b
-
-headersMonoidal :: forall sz r m c p a h.
- (Monoid m, Headedness h)
- => Maybe (Fascia p r, r -> m -> m) -- ^ Apply the Fascia header row content
- -> [(sz -> c -> m, m -> m)] -- ^ Build content from cell content and size
- -> AnnotatedCornice sz h p a c
- -> m
-headersMonoidal wrapRow fromContentList = go wrapRow
- where
- go :: forall p'. Maybe (Fascia p' r, r -> m -> m) -> AnnotatedCornice sz h p' a c -> m
- go ef (AnnotatedCorniceBase _ (Colonnade v)) =
- let g :: m -> m
- g m = case ef of
- Nothing -> m
- Just (FasciaBase r, f) -> f r m
- in case headednessExtract of
- Just unhead -> g $ foldMap (\(fromContent,wrap) -> wrap
- (foldMap (\(OneColonnade (Sized sz h) _) ->
- (fromContent sz (unhead h))) v)) fromContentList
- Nothing -> mempty
- go ef (AnnotatedCorniceCap _ v) =
- let g :: m -> m
- g m = case ef of
- Nothing -> m
- Just (FasciaCap r _, f) -> f r m
- in g (foldMap (\(fromContent,wrap) -> wrap (foldMap (\(OneCornice h b) ->
- (fromContent (size b) h)) v)) fromContentList)
- <> case ef of
- Nothing -> case flattenAnnotated v of
- Nothing -> mempty
- Just annCoreNext -> go Nothing annCoreNext
- Just (FasciaCap _ fn, f) -> case flattenAnnotated v of
- Nothing -> mempty
- Just annCoreNext -> go (Just (fn,f)) annCoreNext
-
-flattenAnnotated ::
- Vector (OneCornice (AnnotatedCornice sz h) p a c)
- -> Maybe (AnnotatedCornice sz h p a c)
-flattenAnnotated v = case v V.!? 0 of
- Nothing -> Nothing
- Just (OneCornice _ x) -> Just $ case x of
- AnnotatedCorniceBase m _ -> flattenAnnotatedBase m v
- AnnotatedCorniceCap m _ -> flattenAnnotatedCap m v
-
-flattenAnnotatedBase ::
- sz
- -> Vector (OneCornice (AnnotatedCornice sz h) Base a c)
- -> AnnotatedCornice sz h Base a c
-flattenAnnotatedBase msz = AnnotatedCorniceBase msz
- . Colonnade
- . V.concatMap
- (\(OneCornice _ (AnnotatedCorniceBase _ (Colonnade v))) -> v)
-
-flattenAnnotatedCap ::
- sz
- -> Vector (OneCornice (AnnotatedCornice sz h) (Cap p) a c)
- -> AnnotatedCornice sz h (Cap p) a c
-flattenAnnotatedCap m = AnnotatedCorniceCap m . V.concatMap getTheVector
-
-getTheVector ::
- OneCornice (AnnotatedCornice sz h) (Cap p) a c
- -> Vector (OneCornice (AnnotatedCornice sz h) p a c)
-getTheVector (OneCornice _ (AnnotatedCorniceCap _ v)) = v
-
-data MutableSizedCornice s (p :: Pillar) a c where
- MutableSizedCorniceBase ::
- {-# UNPACK #-} !(MutableSizedColonnade s Headed a c)
- -> MutableSizedCornice s Base a c
- MutableSizedCorniceCap ::
- {-# UNPACK #-} !(Vector (OneCornice (MutableSizedCornice s) p a c))
- -> MutableSizedCornice s (Cap p) a c
-
-data MutableSizedColonnade s h a c = MutableSizedColonnade
- { _mutableSizedColonnadeColumns :: {-# UNPACK #-} !(Vector (OneColonnade h a c))
- , _mutableSizedColonnadeSizes :: {-# UNPACK #-} !(MVU.STVector s Int)
- }
-
--- | As the first argument to the 'Colonnade' type
--- constructor, this indictates that the columnar encoding has
--- a header. This type is isomorphic to 'Identity' but is
--- given a new name to clarify its intent:
---
--- > example :: Colonnade Headed Foo Text
---
--- The term @example@ represents a columnar encoding of @Foo@
--- in which the columns have headings.
-newtype Headed a = Headed { getHeaded :: a }
- deriving (Eq,Ord,Functor,Show,Read,Foldable)
-
-instance Applicative Headed where
- pure = Headed
- Headed f <*> Headed a = Headed (f a)
-
--- | As the first argument to the 'Colonnade' type
--- constructor, this indictates that the columnar encoding does not have
--- a header. This type is isomorphic to 'Proxy' but is
--- given a new name to clarify its intent:
---
--- > example :: Colonnade Headless Foo Text
---
--- The term @example@ represents a columnar encoding of @Foo@
--- in which the columns do not have headings.
-data Headless a = Headless
- deriving (Eq,Ord,Functor,Show,Read,Foldable)
-
-instance Applicative Headless where
- pure _ = Headless
- Headless <*> Headless = Headless
-
-data Sized sz f a = Sized
- { sizedSize :: !sz
- , sizedContent :: !(f a)
- } deriving (Functor, Foldable)
-
-instance Contravariant Headless where
- contramap _ Headless = Headless
-
--- | Encodes a header and a cell.
-data OneColonnade h a c = OneColonnade
- { oneColonnadeHead :: !(h c)
- , oneColonnadeEncode :: !(a -> c)
- } deriving (Functor)
-
-instance Functor h => Profunctor (OneColonnade h) where
- rmap = fmap
- lmap f (OneColonnade h e) = OneColonnade h (e . f)
-
--- | An columnar encoding of @a@. The type variable @h@ determines what
--- is present in each column in the header row. It is typically instantiated
--- to 'Headed' and occasionally to 'Headless'. There is nothing that
--- restricts it to these two types, although they satisfy the majority
--- of use cases. The type variable @c@ is the content type. This can
--- be @Text@, @String@, or @ByteString@. In the companion libraries
--- @reflex-dom-colonnade@ and @yesod-colonnade@, additional types
--- that represent HTML with element attributes are provided that serve
--- as the content type. Presented more visually:
---
--- > +---- Value consumed to build a row
--- > |
--- > v
--- > Colonnade h a c
--- > ^ ^
--- > | |
--- > | +-- Content (Text, ByteString, Html, etc.)
--- > |
--- > +------ Headedness (Headed or Headless)
---
--- Internally, a 'Colonnade' is represented as a 'Vector' of individual
--- column encodings. It is possible to use any collection type with
--- 'Alternative' and 'Foldable' instances. However, 'Vector' was chosen to
--- optimize the data structure for the use case of building the structure
--- once and then folding over it many times. It is recommended that
--- 'Colonnade's are defined at the top-level so that GHC avoids reconstructing
--- them every time they are used.
-newtype Colonnade h a c = Colonnade
- { getColonnade :: Vector (OneColonnade h a c)
- } deriving (Monoid,Functor)
-
-instance Functor h => Profunctor (Colonnade h) where
- rmap = fmap
- lmap f (Colonnade v) = Colonnade (Vector.map (lmap f) v)
-
-instance Semigroup (Colonnade h a c) where
- Colonnade a <> Colonnade b = Colonnade (a Vector.++ b)
- sconcat xs = Colonnade (vectorConcatNE (fmap getColonnade xs))
-
--- | Isomorphic to the natural numbers. Only the promoted version of
--- this type is used.
-data Pillar = Cap !Pillar | Base
-
-class ToEmptyCornice (p :: Pillar) where
- toEmptyCornice :: Cornice h p a c
-
-instance ToEmptyCornice Base where
- toEmptyCornice = CorniceBase mempty
-
-instance ToEmptyCornice (Cap p) where
- toEmptyCornice = CorniceCap Vector.empty
-
-data Fascia (p :: Pillar) r where
- FasciaBase :: !r -> Fascia Base r
- FasciaCap :: !r -> Fascia p r -> Fascia (Cap p) r
-
-data OneCornice k (p :: Pillar) a c = OneCornice
- { oneCorniceHead :: !c
- , oneCorniceBody :: !(k p a c)
- } deriving (Functor)
-
-data Cornice h (p :: Pillar) a c where
- CorniceBase :: !(Colonnade h a c) -> Cornice h Base a c
- CorniceCap :: {-# UNPACK #-} !(Vector (OneCornice (Cornice h) p a c)) -> Cornice h (Cap p) a c
-
-instance Functor h => Functor (Cornice h p a) where
- fmap f x = case x of
- CorniceBase c -> CorniceBase (fmap f c)
- CorniceCap c -> CorniceCap (mapVectorCornice f c)
-
-instance Functor h => Profunctor (Cornice h p) where
- rmap = fmap
- lmap f x = case x of
- CorniceBase c -> CorniceBase (lmap f c)
- CorniceCap c -> CorniceCap (contramapVectorCornice f c)
-
-instance Semigroup (Cornice h p a c) where
- CorniceBase a <> CorniceBase b = CorniceBase (mappend a b)
- CorniceCap a <> CorniceCap b = CorniceCap (a Vector.++ b)
- sconcat xs@(x :| _) = case x of
- CorniceBase _ -> CorniceBase (Colonnade (vectorConcatNE (fmap (getColonnade . getCorniceBase) xs)))
- CorniceCap _ -> CorniceCap (vectorConcatNE (fmap getCorniceCap xs))
-
-instance ToEmptyCornice p => Monoid (Cornice h p a c) where
- mempty = toEmptyCornice
- mappend = (Semigroup.<>)
- mconcat xs1 = case xs1 of
- [] -> toEmptyCornice
- x : xs2 -> Semigroup.sconcat (x :| xs2)
-
-mapVectorCornice :: Functor h => (c -> d) -> Vector (OneCornice (Cornice h) p a c) -> Vector (OneCornice (Cornice h) p a d)
-mapVectorCornice f = V.map (fmap f)
-
-contramapVectorCornice :: Functor h => (b -> a) -> Vector (OneCornice (Cornice h) p a c) -> Vector (OneCornice (Cornice h) p b c)
-contramapVectorCornice f = V.map (lmapOneCornice f)
-
-lmapOneCornice :: Functor h => (b -> a) -> OneCornice (Cornice h) p a c -> OneCornice (Cornice h) p b c
-lmapOneCornice f (OneCornice theHead theBody) = OneCornice theHead (lmap f theBody)
-
-getCorniceBase :: Cornice h Base a c -> Colonnade h a c
-getCorniceBase (CorniceBase c) = c
-
-getCorniceCap :: Cornice h (Cap p) a c -> Vector (OneCornice (Cornice h) p a c)
-getCorniceCap (CorniceCap c) = c
-
-data AnnotatedCornice sz h (p :: Pillar) a c where
- AnnotatedCorniceBase ::
- !sz
- -> !(Colonnade (Sized sz h) a c)
- -> AnnotatedCornice sz h Base a c
- AnnotatedCorniceCap ::
- !sz
- -> {-# UNPACK #-} !(Vector (OneCornice (AnnotatedCornice sz h) p a c))
- -> AnnotatedCornice sz h (Cap p) a c
-
--- data MaybeInt = JustInt {-# UNPACK #-} !Int | NothingInt
-
--- | This is provided with @vector-0.12@, but we include a copy here
--- for compatibility.
-vectorConcatNE :: NonEmpty (Vector a) -> Vector a
-vectorConcatNE = Vector.concat . toList
-
--- | This class communicates that a container holds either zero
--- elements or one element. Furthermore, all inhabitants of
--- the type must hold the same number of elements. Both
--- 'Headed' and 'Headless' have instances. The following
--- law accompanies any instances:
---
--- > maybe x (\f -> f (headednessPure x)) headednessContents == x
--- > todo: come up with another law that relates to Traversable
---
--- Consequently, there is no instance for 'Maybe', which cannot
--- satisfy the laws since it has inhabitants which hold different
--- numbers of elements. 'Nothing' holds 0 elements and 'Just' holds
--- 1 element.
-class Headedness h where
- headednessPure :: a -> h a
- headednessExtract :: Maybe (h a -> a)
- headednessExtractForall :: Maybe (ExtractForall h)
-
-instance Headedness Headed where
- headednessPure = Headed
- headednessExtract = Just getHeaded
- headednessExtractForall = Just (ExtractForall getHeaded)
-
-instance Headedness Headless where
- headednessPure _ = Headless
- headednessExtract = Nothing
- headednessExtractForall = Nothing
-
-newtype ExtractForall h = ExtractForall { runExtractForall :: forall a. h a -> a }
-
diff --git a/fourmolu.yaml b/fourmolu.yaml
new file mode 100644
index 0000000..40cd005
--- /dev/null
+++ b/fourmolu.yaml
@@ -0,0 +1,51 @@
+# Number of spaces per indentation step
+indentation: 2
+
+# Max line length for automatic line breaking
+column-limit: 200
+
+# Styling of arrows in type signatures (choices: trailing, leading, or leading-args)
+function-arrows: trailing
+
+# How to place commas in multi-line lists, records, etc. (choices: leading or trailing)
+comma-style: leading
+
+# Styling of import/export lists (choices: leading, trailing, or diff-friendly)
+import-export-style: leading
+
+# Whether to full-indent or half-indent 'where' bindings past the preceding body
+indent-wheres: false
+
+# Whether to leave a space before an opening record brace
+record-brace-space: true
+
+# Number of spaces between top-level declarations
+newlines-between-decls: 1
+
+# How to print Haddock comments (choices: single-line, multi-line, or multi-line-compact)
+haddock-style: multi-line
+
+# How to print module docstring
+haddock-style-module: null
+
+# Styling of let blocks (choices: auto, inline, newline, or mixed)
+let-style: auto
+
+# How to align the 'in' keyword with respect to the 'let' keyword (choices: left-align, right-align, or no-space)
+in-style: right-align
+
+# Whether to put parentheses around a single constraint (choices: auto, always, or never)
+single-constraint-parens: always
+
+# Output Unicode syntax (choices: detect, always, or never)
+unicode: never
+
+# Give the programmer more choice on where to insert blank lines
+respectful: true
+
+# Fixity information for operators
+fixities: []
+
+# Module reexports Fourmolu should know about
+reexports: []
+
diff --git a/geolite-csv/LICENSE b/geolite-csv/LICENSE
deleted file mode 100644
index 9beb3f9..0000000
--- a/geolite-csv/LICENSE
+++ /dev/null
@@ -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.
\ No newline at end of file
diff --git a/geolite-csv/Setup.hs b/geolite-csv/Setup.hs
deleted file mode 100644
index 9a994af..0000000
--- a/geolite-csv/Setup.hs
+++ /dev/null
@@ -1,2 +0,0 @@
-import Distribution.Simple
-main = defaultMain
diff --git a/geolite-csv/data/small/GeoLite2-City-Blocks-IPv4.csv b/geolite-csv/data/small/GeoLite2-City-Blocks-IPv4.csv
deleted file mode 100644
index c5c1f84..0000000
--- a/geolite-csv/data/small/GeoLite2-City-Blocks-IPv4.csv
+++ /dev/null
@@ -1,11 +0,0 @@
-network,geoname_id,registered_country_geoname_id,represented_country_geoname_id,is_anonymous_proxy,is_satellite_provider,postal_code,latitude,longitude,accuracy_radius
-24.165.56.0/22,5848280,6252001,,0,0,96746,22.0837,-159.3553,10
-78.146.173.128/25,2655583,2635167,,0,0,DL14,54.6500,-1.6667,20
-121.211.108.0/23,2160386,2077456,,0,0,2040,-33.8833,151.1500,5
-69.74.43.16/30,6252001,6252001,,0,0,,37.7510,-97.8220,1000
-77.128.35.136/30,3034803,3017382,,0,0,57450,49.0667,6.8333,20
-90.54.234.0/24,2977062,3017382,,0,0,49320,47.3944,-0.4357,50
-77.193.41.175/32,3018587,3017382,,0,0,78810,48.8700,1.9740,1
-58.188.32.0/24,1861060,1861060,,0,0,,35.6900,139.6900,500
-87.81.232.0/24,2635167,2635167,,0,0,,51.4964,-0.1224,200
-88.191.56.0/22,2988507,3017382,,0,0,75001,48.8667,2.3333,500
diff --git a/geolite-csv/data/small/GeoLite2-City-Locations-en.csv b/geolite-csv/data/small/GeoLite2-City-Locations-en.csv
deleted file mode 100644
index 0fbf70a..0000000
--- a/geolite-csv/data/small/GeoLite2-City-Locations-en.csv
+++ /dev/null
@@ -1,21 +0,0 @@
-geoname_id,locale_code,continent_code,continent_name,country_iso_code,country_name,subdivision_1_iso_code,subdivision_1_name,subdivision_2_iso_code,subdivision_2_name,city_name,metro_code,time_zone
-2653810,en,EU,Europe,GB,"United Kingdom",SCT,Scotland,GLG,"Glasgow City",Cardonald,,Europe/London
-2832529,en,EU,Europe,DE,Germany,RP,Rheinland-Pfalz,,,Siefersheim,,Europe/Berlin
-2885499,en,EU,Europe,DE,Germany,MV,Mecklenburg-Vorpommern,,,Koerchow,,Europe/Berlin
-550870,en,EU,Europe,RU,Russia,NIZ,"Nizhegorodskaya Oblast'",,,Khabarskoye,,Europe/Moscow
-766583,en,EU,Europe,PL,Poland,LU,"Lublin Voivodeship",,,Leczna,,Europe/Warsaw
-2608246,en,EU,Europe,AT,Austria,1,Burgenland,,,"Neuhaus am Klausenbach",,Europe/Vienna
-5121765,en,NA,"North America",US,"United States",NY,"New York",,,Ilion,526,America/New_York
-2935825,en,EU,Europe,DE,Germany,NW,"North Rhine-Westphalia",,,Dormagen,,Europe/Berlin
-3165189,en,EU,Europe,IT,Italy,36,"Friuli Venezia Giulia",UD,"Provincia di Udine",Tricesimo,,Europe/Rome
-4564070,en,NA,"North America",PR,"Puerto Rico",,,,,Culebra,,America/Puerto_Rico
-2993759,en,EU,Europe,FR,France,U,"Provence-Alpes-Côte d'Azur",13,Bouches-du-Rhône,Miramas-le-Vieux,,Europe/Paris
-5861117,en,NA,"North America",US,"United States",AK,Alaska,,,"Dutch Harbor",743,America/Adak
-4375229,en,NA,"North America",US,"United States",MO,Missouri,,,Ashland,604,America/Chicago
-2946980,en,EU,Europe,DE,Germany,SN,Saxony,,,Boehlen,,Europe/Berlin
-3156470,en,EU,Europe,NO,Norway,02,Akershus,,,Frogner,,Europe/Oslo
-3166193,en,EU,Europe,IT,Italy,36,"Friuli Venezia Giulia",GO,"Provincia di Gorizia",Staranzano,,Europe/Rome
-4913742,en,NA,"North America",US,"United States",IL,Illinois,,,Tiskilwa,675,America/Chicago
-4853511,en,NA,"North America",US,"United States",IA,Iowa,,,Dayton,679,America/Chicago
-480876,en,EU,Europe,RU,Russia,ROS,Rostov,,,Tsimlyansk,,Europe/Moscow
-3000119,en,EU,Europe,FR,France,89,Yonne,,,"Les Ormes",,Europe/Paris
diff --git a/geolite-csv/data/small/GeoLite2-City-Locations-ja.csv b/geolite-csv/data/small/GeoLite2-City-Locations-ja.csv
deleted file mode 100644
index 33d5a64..0000000
--- a/geolite-csv/data/small/GeoLite2-City-Locations-ja.csv
+++ /dev/null
@@ -1,21 +0,0 @@
-geoname_id,locale_code,continent_code,continent_name,country_iso_code,country_name,subdivision_1_iso_code,subdivision_1_name,subdivision_2_iso_code,subdivision_2_name,city_name,metro_code,time_zone
-1260633,ja,AS,"アジア",IN,"インド",AP,"アーンドラ・プラデーシュ州",,,,,Asia/Kolkata
-4765167,ja,NA,"北アメリカ",US,"アメリカ合衆国",VA,"バージニア州",,,,573,America/New_York
-2703330,ja,EU,"ヨーロッパ",SE,"スウェーデン王国",Z,,,,,,Europe/Stockholm
-535886,ja,EU,"ヨーロッパ",RU,"ロシア",STA,,,,,,Europe/Moscow
-2989001,ja,EU,"ヨーロッパ",FR,"フランス共和国",F,,28,,,,Europe/Paris
-3183178,ja,EU,"ヨーロッパ",IT,"イタリア共和国",75,"プッリャ州",BA,,"アルタムーラ",,Europe/Rome
-3012956,ja,EU,"ヨーロッパ",FR,"フランス共和国",67,,,,,,Europe/Paris
-4189157,ja,NA,"北アメリカ",US,"アメリカ合衆国",GA,"ジョージア州",,,,524,America/New_York
-2758965,ja,EU,"ヨーロッパ",NL,"オランダ王国",ZE,,,,,,Europe/Amsterdam
-3570412,ja,NA,"北アメリカ",MQ,"マルティニーク島",,,,,,,America/Martinique
-3095604,ja,EU,"ヨーロッパ",PL,"ポーランド共和国",MZ,"マゾフシェ県",,,,,Europe/Warsaw
-3070865,ja,EU,"ヨーロッパ",CZ,"チェコ共和国",ST,"中央ボヘミア州",,,,,Europe/Prague
-2636062,ja,EU,"ヨーロッパ",GB,"イギリス",ENG,"イングランド",SRY,,,,Europe/London
-3019338,ja,EU,"ヨーロッパ",FR,"フランス共和国",57,,,,,,Europe/Paris
-2865603,ja,EU,"ヨーロッパ",DE,"ドイツ連邦共和国",BY,"バイエルン州",,,"ノイエンマルクト",,Europe/Berlin
-2930628,ja,EU,"ヨーロッパ",DE,"ドイツ連邦共和国",HE,,,,,,Europe/Berlin
-2976283,ja,EU,"ヨーロッパ",FR,"フランス共和国",01,,,,,,Europe/Paris
-4062424,ja,NA,"北アメリカ",US,"アメリカ合衆国",AL,"アラバマ州",,,,575,America/Chicago
-4461574,ja,NA,"北アメリカ",US,"アメリカ合衆国",NC,"ノースカロライナ州",,,"コンコード",517,America/New_York
-1279945,ja,AS,"アジア",CN,"中国",62,,,,"酒泉市",,Asia/Shanghai
diff --git a/geolite-csv/geolite-csv.cabal b/geolite-csv/geolite-csv.cabal
deleted file mode 100644
index 1cf6d41..0000000
--- a/geolite-csv/geolite-csv.cabal
+++ /dev/null
@@ -1,52 +0,0 @@
-name: geolite-csv
-version: 0.2
-synopsis: Geolite CSV Parser
-description: Please see README.md
-homepage: https://github.com/andrewthad/colonnade
-license: BSD3
-license-file: LICENSE
-author: Andrew Martin
-maintainer: andrew.thaddeus@gmail.com
-copyright: 2016 Andrew Martin
-category: web
-build-type: Simple
--- extra-source-files:
-cabal-version: >=1.10
-
-library
- hs-source-dirs: src
- exposed-modules:
- Geolite.Types
- Geolite.Csv
- build-depends:
- base >= 4.7 && < 5
- , colonnade
- , siphon
- , ip >= 0.8.4
- , text
- , pipes
- default-language: Haskell2010
-
-test-suite geolite-csv-test
- type: exitcode-stdio-1.0
- hs-source-dirs: test
- main-is: Spec.hs
- build-depends:
- base
- , geolite-csv
- , siphon
- , colonnade
- , test-framework
- , text
- , pipes
- , HUnit
- , test-framework-hunit
- , pipes-bytestring
- , pipes-text
- , directory
- ghc-options: -threaded -rtsopts -with-rtsopts=-N
- default-language: Haskell2010
-
-source-repository head
- type: git
- location: https://github.com/andrewthad/colonnade
diff --git a/geolite-csv/hackage-docs.sh b/geolite-csv/hackage-docs.sh
deleted file mode 100755
index 0ddbc20..0000000
--- a/geolite-csv/hackage-docs.sh
+++ /dev/null
@@ -1,48 +0,0 @@
-#!/bin/bash
-set -e
-
-if [ "$#" -ne 1 ]; then
- echo "Usage: scripts/hackage-docs.sh HACKAGE_USER"
- exit 1
-fi
-
-user=$1
-
-cabal_file=$(find . -maxdepth 1 -name "*.cabal" -print -quit)
-if [ ! -f "$cabal_file" ]; then
- echo "Run this script in the top-level package directory"
- exit 1
-fi
-
-pkg=$(awk -F ":[[:space:]]*" 'tolower($1)=="name" { print $2 }' < "$cabal_file")
-ver=$(awk -F ":[[:space:]]*" 'tolower($1)=="version" { print $2 }' < "$cabal_file")
-
-if [ -z "$pkg" ]; then
- echo "Unable to determine package name"
- exit 1
-fi
-
-if [ -z "$ver" ]; then
- echo "Unable to determine package version"
- exit 1
-fi
-
-echo "Detected package: $pkg-$ver"
-
-dir=$(mktemp -d build-docs.XXXXXX)
-trap 'rm -r "$dir"' EXIT
-
-# cabal haddock --hoogle --hyperlink-source --html-location='/package/$pkg-$version/docs' --contents-location='/package/$pkg-$version'
-stack haddock
-
-cp -R .stack-work/dist/x86_64-linux/Cabal-1.22.5.0/doc/html/$pkg/ $dir/$pkg-$ver-docs
-# /home/andrew/.stack/snapshots/x86_64-linux/lts-5.17/7.10.3/doc/index.html
-
-tar cvz -C $dir --format=ustar -f $dir/$pkg-$ver-docs.tar.gz $pkg-$ver-docs
-
-curl -X PUT \
- -H 'Content-Type: application/x-tar' \
- -H 'Content-Encoding: gzip' \
- -u "$user" \
- --data-binary "@$dir/$pkg-$ver-docs.tar.gz" \
- "https://hackage.haskell.org/package/$pkg-$ver/docs"
diff --git a/geolite-csv/scripts/load-full-databases b/geolite-csv/scripts/load-full-databases
deleted file mode 100755
index f78ea92..0000000
--- a/geolite-csv/scripts/load-full-databases
+++ /dev/null
@@ -1,35 +0,0 @@
-#!/bin/bash
-
-set -e
-
-current_dir="${PWD##*/}"
-
-echo "Current directory is: $current_dir"
-
-if [ "$current_dir" = "colonnade" ]
-then
- cd ./geolite-csv
-fi
-
-new_current_dir="${PWD##*/}"
-if [ "$new_current_dir" != "geolite-csv" ]
-then
- echo "Not currently in the geolite project directory. Exiting."
- exit 1
-fi
-
-mkdir -p ./data/large
-cd ./data/large
-
-rm -f *.zip
-rm -rf GeoLite2-*
-
-curl 'http://geolite.maxmind.com/download/geoip/database/GeoLite2-City-CSV.zip' > archive.zip
-unzip archive.zip -d ./
-
-cd GeoLite2-City-CSV*
-mv *.csv ../
-cd ../
-rm -rf GeoLite2-City-CSV*
-rm archive.zip
-
diff --git a/geolite-csv/src/Geolite/Csv.hs b/geolite-csv/src/Geolite/Csv.hs
deleted file mode 100644
index 07a684b..0000000
--- a/geolite-csv/src/Geolite/Csv.hs
+++ /dev/null
@@ -1,59 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module Geolite.Csv where
-
-import Data.Text (Text)
-import Pipes (Pipe)
-import Colonnade.Types
-import Geolite.Types
-
-import qualified Data.Text as Text
-import qualified Net.IPv4.Range.Text as IPv4RangeText
-import qualified Data.Text.Read as TextRead
-import qualified Siphon.Decoding as SD
-import qualified Siphon.Content as SC
-import qualified Colonnade.Decoding.Text as CDT
-import qualified Colonnade.Decoding as CD
-
-cities :: Monad m => Pipe Text City m (DecodingRowError Headed Text)
-cities = SD.headedPipe SC.text decodingCity
-
-blocks :: Monad m => Pipe Text Block m (DecodingRowError Headed Text)
-blocks = SD.headedPipe SC.text decodingBlock
-
-decodingCity :: Decoding Headed Text City
-decodingCity = City
- <$> fmap GeonameId (CD.headed "geoname_id" CDT.int)
- <*> CD.headed "locale_code" CDT.text
- <*> CD.headed "continent_code" CDT.text
- <*> CD.headed "continent_name" CDT.text
- <*> CD.headed "country_iso_code" CDT.text
- <*> CD.headed "country_name" CDT.text
- <*> CD.headed "subdivision_1_iso_code" CDT.text
- <*> CD.headed "subdivision_1_name" CDT.text
- <*> CD.headed "subdivision_2_iso_code" CDT.text
- <*> CD.headed "subdivision_2_name" CDT.text
- <*> CD.headed "city_name" CDT.text
- <*> CD.headed "metro_code" (CDT.optional CDT.int)
- <*> CD.headed "time_zone" CDT.text
-
-decodingBlock :: Decoding Headed Text Block
-decodingBlock = Block
- <$> CD.headed "network" IPv4RangeText.decodeEither
- <*> CD.headed "geoname_id"
- (CDT.optional $ CDT.map GeonameId CDT.int)
- <*> CD.headed "registered_country_geoname_id"
- (CDT.optional $ CDT.map GeonameId CDT.int)
- <*> CD.headed "represented_country_geoname_id"
- (CDT.optional $ CDT.map GeonameId CDT.int)
- <*> CD.headed "is_anonymous_proxy" (CDT.trueFalse "1" "0")
- <*> CD.headed "is_satellite_provider" (CDT.trueFalse "1" "0")
- <*> CD.headed "postal_code" CDT.text
- <*> CD.headed "latitude"
- (CDT.optional $ CDT.fromReader TextRead.rational)
- <*> CD.headed "longitude"
- (CDT.optional $ CDT.fromReader TextRead.rational)
- <*> CD.headed "accuracy_radius"
- (CDT.optional CDT.int)
-
-
diff --git a/geolite-csv/src/Geolite/Types.hs b/geolite-csv/src/Geolite/Types.hs
deleted file mode 100644
index 47eb867..0000000
--- a/geolite-csv/src/Geolite/Types.hs
+++ /dev/null
@@ -1,43 +0,0 @@
-module Geolite.Types where
-
-import Net.Types (IPv4Range)
-import Data.Text (Text)
-import Data.Fixed
-
-data E4
-
-instance HasResolution E4 where
- resolution _ = 4
-
-newtype GeonameId = GeonameId { getGeonameId :: Int }
- deriving (Show,Read,Eq,Ord)
-
-data City = City
- { cityGeonameId :: GeonameId
- , cityLocaleCode :: Text
- , cityContinentCode :: Text
- , cityContinentName :: Text
- , cityCountryIsoCode :: Text
- , cityCountryName :: Text
- , citySubdivision1IsoCode :: Text
- , citySubdivision1Name :: Text
- , citySubdivision2IsoCode :: Text
- , citySubdivision2Name :: Text
- , cityName :: Text
- , cityMetroCode :: Maybe Int
- , cityTimeZone :: Text
- } deriving (Show,Read,Eq,Ord)
-
-data Block = Block
- { blockNetwork :: IPv4Range
- , blockGeonameId :: Maybe GeonameId
- , blockRegisteredCountryGeonameId :: Maybe GeonameId
- , blockRepresentedCountryGeonameId :: Maybe GeonameId
- , blockIsAnonymousProxy :: Bool
- , blockIsSatelliteProvider :: Bool
- , blockPostalCode :: Text
- , blockLatitude :: Maybe (Fixed E4)
- , blockLongitude :: Maybe (Fixed E4)
- , blockAccuracyRadius :: Maybe Int
- } deriving (Show,Read,Eq,Ord)
-
diff --git a/geolite-csv/test/Spec.hs b/geolite-csv/test/Spec.hs
deleted file mode 100644
index 69436d0..0000000
--- a/geolite-csv/test/Spec.hs
+++ /dev/null
@@ -1,91 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module Main (main) where
-
-import Test.HUnit (Assertion,(@?=),assertBool,assertFailure)
-import Test.Framework (defaultMainWithOpts, interpretArgsOrExit,
- testGroup, Test)
-import Test.Framework.Providers.HUnit (testCase)
-import Test.Framework.Runners.TestPattern (parseTestPattern)
-import Test.Framework.Runners.Options (RunnerOptions'(..))
-import Geolite.Csv (cities,blocks)
-import Data.Text (Text)
-import Colonnade.Types
-import Siphon.Types
-import Data.Functor.Identity
-import Control.Monad (unless)
-import System.Environment (getArgs)
-import System.Directory (doesDirectoryExist)
-import System.IO (withFile,IOMode(ReadMode))
-import qualified Data.Text as Text
-import qualified Pipes.Prelude as Pipes
-import qualified Pipes.ByteString as PB
-import qualified Pipes.Text.Encoding as PT
-import qualified Siphon.Decoding as SD
-import qualified Colonnade.Decoding as Decoding
-import Pipes
-
-------------------------------------------------
--- The default behavior of this test suite is to
--- test the CSV decoders against small samples of
--- the GeoLite2 databases. These small samples are
--- included as part of this repository. If you give
--- this test suite an argument named "large", it
--- will run against the full CSVs, which are around
--- 350MB. These are not included
--- as part of the repository, so they need to be
--- downloaded. The script found in
--- scripts/load-full-databases will download the full
--- archive, decompress it, and move the files to
--- the appropriate directory for this test suite
--- to run on them.
------------------------------------------------
-
-main :: IO ()
-main = do
- xs <- getArgs
- ropts' <- interpretArgsOrExit xs
- let ropts = ropts'
- { ropt_test_patterns = case ropt_test_patterns ropts' of
- Nothing -> Just [parseTestPattern "small"]
- Just xs -> Just xs
- }
- defaultMainWithOpts tests ropts
-
-tests :: [Test]
-tests = flip concatMap ["small","large"] $ \size ->
- [ testGroup size
- [ testCase "Network Blocks" $ streamFileWith
- ("data/" ++ size ++ "/GeoLite2-City-Blocks-IPv4.csv")
- blocks
- , testCase "English City Locations" $ streamFileWith
- ("data/" ++ size ++ "/GeoLite2-City-Locations-en.csv")
- cities
- , testCase "Japanese City Locations" $ streamFileWith
- ("data/" ++ size ++ "/GeoLite2-City-Locations-ja.csv")
- cities
- ]
- ]
-
-streamFileWith ::
- String
- -> Pipe Text a IO (DecodingRowError Headed Text)
- -> Assertion
-streamFileWith filename decodingPipe = do
- r <- withFile filename ReadMode $ \h -> runEffect $
- fmap (SD.convertDecodeError "utf-8") (PT.decode (PT.utf8 . PT.eof) $ PB.fromHandle h)
- >-> fmap Just decodingPipe
- >-> Pipes.drain
- case r of
- Nothing -> assertBool "impossible" True
- Just err -> assertFailure (Decoding.prettyError Text.unpack err)
-
--- let dirPiece = case xs of
--- ["full"] -> "large/"
--- _ -> "small/"
--- fullDirName = "data/" ++ dirPiece
--- errMsg = concat
--- [ "The "
--- , fullDirName
--- , " directory does not exist in the geolite project"
--- ]
diff --git a/lucid-colonnade.cabal b/lucid-colonnade.cabal
new file mode 100644
index 0000000..2392280
--- /dev/null
+++ b/lucid-colonnade.cabal
@@ -0,0 +1,36 @@
+cabal-version: 3.0
+name: lucid-colonnade
+version: 1.0.2
+synopsis: Helper functions for using lucid with colonnade
+description: Helper functions for using lucid with colonnade.
+homepage: https://github.com/byteverse/lucid-colonnade
+bug-reports: https://github.com/byteverse/lucid-colonnade/issues
+license: BSD-3-Clause
+license-file: LICENSE
+author: Andrew Martin
+maintainer: amartin@layer3com.com
+copyright: 2017 Andrew Martin
+category: web
+build-type: Simple
+extra-doc-files: CHANGELOG.md
+tested-with: GHC ==9.4.8 || ==9.6.3 || ==9.8.1
+
+common build-settings
+ default-language: Haskell2010
+ ghc-options: -Wall -Wunused-packages
+ build-depends: base >=4.8 && <5
+
+library
+ import: build-settings
+ ghc-options: -O2
+ hs-source-dirs: src
+ exposed-modules: Lucid.Colonnade
+ build-depends:
+ , colonnade >=1.1.1
+ , lucid >=2.9
+ , text >=1.2
+ , vector >=0.10
+
+source-repository head
+ type: git
+ location: git://github.com/byteverse/lucid-colonnade.git
diff --git a/lucid-colonnade/LICENSE b/lucid-colonnade/LICENSE
deleted file mode 100644
index 9beb3f9..0000000
--- a/lucid-colonnade/LICENSE
+++ /dev/null
@@ -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.
\ No newline at end of file
diff --git a/lucid-colonnade/Setup.hs b/lucid-colonnade/Setup.hs
deleted file mode 100644
index 9a994af..0000000
--- a/lucid-colonnade/Setup.hs
+++ /dev/null
@@ -1,2 +0,0 @@
-import Distribution.Simple
-main = defaultMain
diff --git a/lucid-colonnade/lucid-colonnade.cabal b/lucid-colonnade/lucid-colonnade.cabal
deleted file mode 100644
index 9edfd8f..0000000
--- a/lucid-colonnade/lucid-colonnade.cabal
+++ /dev/null
@@ -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 && < 2.1
- , vector >= 0.10 && < 0.14
- default-language: Haskell2010
-
-source-repository head
- type: git
- location: https://github.com/andrewthad/colonnade
diff --git a/lucid-colonnade/src/Lucid/Colonnade.hs b/lucid-colonnade/src/Lucid/Colonnade.hs
deleted file mode 100644
index e33eef1..0000000
--- a/lucid-colonnade/src/Lucid/Colonnade.hs
+++ /dev/null
@@ -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 @\@ or @\ | @ elements
--- that wrap this HTML content.
-
--- | The attributes that will be applied to a @\ | @ 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 = (<>)
-
--- | 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 @\@ 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 @\@ 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 @\@ 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 @\@ 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 @\@ and its @\@
- -> [Attribute] -- ^ Attributes of @\ @ element
- -> (a -> [Attribute]) -- ^ Attributes of each @\@ element
- -> (([Attribute] -> Html d -> Html d) -> c -> Html d) -- ^ Wrap content and convert to 'Html'
- -> [Attribute] -- ^ Attributes of @\@ 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 @\@ element
- -> (([Attribute] -> Html d -> Html d) -> c -> Html d) -- ^ Wrap content and convert to 'Html'
- -> [Attribute] -- ^ Attributes of @\ @ 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 @\@ and its @\@
- -> [Attribute] -- ^ Attributes of @\ @ element
- -> (a -> [Attribute]) -- ^ Attributes of each @\@ element
- -> (([Attribute] -> Html d -> Html d) -> (Cell d) -> Html d) -- ^ Wrap content and convert to 'Html'
- -> [Attribute] -- ^ Attributes of @\@ 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 @\@ and the row
--- content the child of a @\ | @. 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] -- ^ @\@ tag attributes
- -> Maybe ([Attribute], [Attribute])
- -- ^ Attributes of @\@ and its @\@, pass 'Nothing' to omit @\@
- -> [Attribute] -- ^ @\ @ tag attributes
- -> (a -> [Attribute]) -- ^ @\@ 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
-
diff --git a/projects/cabal-8.0.2.project b/projects/cabal-8.0.2.project
deleted file mode 100644
index 2829611..0000000
--- a/projects/cabal-8.0.2.project
+++ /dev/null
@@ -1,4 +0,0 @@
-packages: ./colonnade
- ./blaze-colonnade
- ./lucid-colonnade
- ./yesod-colonnade
diff --git a/projects/cabal-8.2.2.project b/projects/cabal-8.2.2.project
deleted file mode 100644
index 2829611..0000000
--- a/projects/cabal-8.2.2.project
+++ /dev/null
@@ -1,4 +0,0 @@
-packages: ./colonnade
- ./blaze-colonnade
- ./lucid-colonnade
- ./yesod-colonnade
diff --git a/projects/cabal-8.4.3.project b/projects/cabal-8.4.3.project
deleted file mode 100644
index 54165d1..0000000
--- a/projects/cabal-8.4.3.project
+++ /dev/null
@@ -1,3 +0,0 @@
-packages: ./colonnade
- ./blaze-colonnade
- ./lucid-colonnade
diff --git a/siphon/CHANGELOG.md b/siphon/CHANGELOG.md
deleted file mode 100644
index 0ac9ef3..0000000
--- a/siphon/CHANGELOG.md
+++ /dev/null
@@ -1,9 +0,0 @@
-# Revision history for siphon
-
-## 0.8.2.0 -- 2022-??-??
-
-* Add
-
-## 0.8.1.2 -- 2021-10-25
-
-* Correct handling of CRLF.
diff --git a/siphon/LICENSE b/siphon/LICENSE
deleted file mode 100644
index 9beb3f9..0000000
--- a/siphon/LICENSE
+++ /dev/null
@@ -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.
\ No newline at end of file
diff --git a/siphon/Setup.hs b/siphon/Setup.hs
deleted file mode 100644
index 9a994af..0000000
--- a/siphon/Setup.hs
+++ /dev/null
@@ -1,2 +0,0 @@
-import Distribution.Simple
-main = defaultMain
diff --git a/siphon/hackage-docs.sh b/siphon/hackage-docs.sh
deleted file mode 100755
index 0ddbc20..0000000
--- a/siphon/hackage-docs.sh
+++ /dev/null
@@ -1,48 +0,0 @@
-#!/bin/bash
-set -e
-
-if [ "$#" -ne 1 ]; then
- echo "Usage: scripts/hackage-docs.sh HACKAGE_USER"
- exit 1
-fi
-
-user=$1
-
-cabal_file=$(find . -maxdepth 1 -name "*.cabal" -print -quit)
-if [ ! -f "$cabal_file" ]; then
- echo "Run this script in the top-level package directory"
- exit 1
-fi
-
-pkg=$(awk -F ":[[:space:]]*" 'tolower($1)=="name" { print $2 }' < "$cabal_file")
-ver=$(awk -F ":[[:space:]]*" 'tolower($1)=="version" { print $2 }' < "$cabal_file")
-
-if [ -z "$pkg" ]; then
- echo "Unable to determine package name"
- exit 1
-fi
-
-if [ -z "$ver" ]; then
- echo "Unable to determine package version"
- exit 1
-fi
-
-echo "Detected package: $pkg-$ver"
-
-dir=$(mktemp -d build-docs.XXXXXX)
-trap 'rm -r "$dir"' EXIT
-
-# cabal haddock --hoogle --hyperlink-source --html-location='/package/$pkg-$version/docs' --contents-location='/package/$pkg-$version'
-stack haddock
-
-cp -R .stack-work/dist/x86_64-linux/Cabal-1.22.5.0/doc/html/$pkg/ $dir/$pkg-$ver-docs
-# /home/andrew/.stack/snapshots/x86_64-linux/lts-5.17/7.10.3/doc/index.html
-
-tar cvz -C $dir --format=ustar -f $dir/$pkg-$ver-docs.tar.gz $pkg-$ver-docs
-
-curl -X PUT \
- -H 'Content-Type: application/x-tar' \
- -H 'Content-Encoding: gzip' \
- -u "$user" \
- --data-binary "@$dir/$pkg-$ver-docs.tar.gz" \
- "https://hackage.haskell.org/package/$pkg-$ver/docs"
diff --git a/siphon/siphon.cabal b/siphon/siphon.cabal
deleted file mode 100644
index 051205d..0000000
--- a/siphon/siphon.cabal
+++ /dev/null
@@ -1,58 +0,0 @@
-cabal-version: 3.0
-name: siphon
-version: 0.8.2.0
-synopsis: Encode and decode CSV files
-description: Please see README.md
-homepage: https://github.com/andrewthad/colonnade#readme
-license: BSD-3-Clause
-license-file: LICENSE
-author: Andrew Martin
-maintainer: andrew.thaddeus@gmail.com
-copyright: 2016 Andrew Martin
-category: web
-build-type: Simple
-extra-source-files: CHANGELOG.md
-
-library
- hs-source-dirs: src
- exposed-modules:
- Siphon
- Siphon.Types
- build-depends:
- base >= 4.8 && < 5
- , colonnade >= 1.2 && < 1.3
- , text >= 1.0 && < 2.1
- , bytestring
- , vector
- , streaming >= 0.1.4 && < 0.3
- , attoparsec
- , transformers >= 0.4.2 && < 0.8
- , semigroups >= 0.18.2 && < 0.21
- default-language: Haskell2010
-
-test-suite test
- type: exitcode-stdio-1.0
- hs-source-dirs: test
- main-is: Test.hs
- build-depends:
- base
- , HUnit
- , QuickCheck
- , bytestring
- , colonnade
- , contravariant
- , either
- , pipes
- , profunctors
- , siphon
- , streaming
- , test-framework
- , test-framework-hunit
- , test-framework-quickcheck2
- , text
- , vector
- default-language: Haskell2010
-
-source-repository head
- type: git
- location: https://github.com/andrewthad/colonnade
diff --git a/siphon/src/Siphon.hs b/siphon/src/Siphon.hs
deleted file mode 100644
index 7ffe8db..0000000
--- a/siphon/src/Siphon.hs
+++ /dev/null
@@ -1,791 +0,0 @@
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE RankNTypes #-}
-
-{-# OPTIONS_GHC -Wall -fno-warn-unused-imports #-}
-
--- | Build CSVs using the abstractions provided in the @colonnade@ library, and
--- parse CSVs using 'Siphon', which is the dual of 'Colonnade'.
--- Read the documentation for @colonnade@ before reading the documentation
--- for @siphon@. All of the examples on this page assume a common set of
--- imports that are provided at the bottom of this page.
-module Siphon
- ( -- * Encode CSV
- encodeCsv
- , encodeCsvStream
- , encodeCsvUtf8
- , encodeCsvStreamUtf8
- -- * Decode CSV
- , decodeCsvUtf8
- , decodeHeadedCsvUtf8
- , decodeIndexedCsvUtf8
- -- * Build Siphon
- , headed
- , headless
- , indexed
- -- * Types
- , Siphon
- , SiphonError(..)
- , Indexed(..)
- -- * For Testing
- , headedToIndexed
- -- * Utility
- , humanizeSiphonError
- , eqSiphonHeaders
- , showSiphonHeaders
- -- * Imports
- -- $setup
- ) where
-
-import Siphon.Types
-import Data.Monoid
-import Control.Applicative
-import Control.Monad
-import Data.Functor.Classes (Eq1,Show1,liftEq,showsPrec1)
-
-import qualified Data.ByteString.Char8 as BC8
-import qualified Data.Attoparsec.ByteString as A
-import qualified Data.Attoparsec.Lazy as AL
-import qualified Data.Attoparsec.Zepto as Z
-import qualified Data.ByteString as S
-import qualified Data.ByteString.Unsafe as S
-import qualified Data.Vector as V
-import qualified Data.ByteString as B
-import qualified Data.ByteString.Lazy as LByteString
-import qualified Data.ByteString.Builder as Builder
-import qualified Data.Text.Lazy as LT
-import qualified Data.Text.Lazy.Builder as TB
-import qualified Data.Text as T
-import qualified Data.List as L
-import qualified Streaming as SM
-import qualified Streaming.Prelude as SMP
-import qualified Data.Attoparsec.Types as ATYP
-import qualified Colonnade.Encode as CE
-import qualified Data.Vector.Mutable as MV
-import qualified Data.ByteString.Builder as BB
-import qualified Data.Semigroup as SG
-
-import Control.Monad.Trans.Class
-import Data.Functor.Identity (Identity(..))
-import Data.ByteString.Builder (toLazyByteString,byteString)
-import Data.Attoparsec.ByteString.Char8 (char, endOfInput, string)
-import Data.Word (Word8)
-import Data.Vector (Vector)
-import Data.ByteString (ByteString)
-import Data.Coerce (coerce)
-import Data.Char (chr)
-import Data.Text.Encoding (decodeUtf8')
-import Streaming (Stream,Of(..))
-import Data.Vector.Mutable (MVector)
-import Control.Monad.ST
-import Data.Text (Text)
-import Data.Semigroup (Semigroup)
-
-newtype Escaped c = Escaped { getEscaped :: c }
-data Ended = EndedYes | EndedNo
- deriving (Show)
-data CellResult c = CellResultData !c | CellResultNewline !c !Ended
- deriving (Show)
-
--- | Backwards-compatibility alias for 'decodeHeadedCsvUtf8'.
-decodeCsvUtf8 :: Monad m
- => Siphon CE.Headed ByteString a
- -> Stream (Of ByteString) m () -- ^ encoded csv
- -> Stream (Of a) m (Maybe SiphonError)
-decodeCsvUtf8 = decodeHeadedCsvUtf8
-
--- | Decode a CSV whose first row is contains headers identify each column.
-decodeHeadedCsvUtf8 :: Monad m
- => Siphon CE.Headed ByteString a
- -> Stream (Of ByteString) m () -- ^ encoded csv
- -> Stream (Of a) m (Maybe SiphonError)
-decodeHeadedCsvUtf8 headedSiphon s1 = do
- e <- lift (consumeHeaderRowUtf8 s1)
- case e of
- Left err -> return (Just err)
- Right (v :> s2) -> case headedToIndexed utf8ToStr v headedSiphon of
- Left err -> return (Just err)
- Right ixedSiphon -> do
- let requiredLength = V.length v
- consumeBodyUtf8 1 requiredLength ixedSiphon s2
-
--- | Decode a CSV without a header.
-decodeIndexedCsvUtf8 :: Monad m
- => Int -- ^ How many columns are there? This number should be greater than any indices referenced by the scheme.
- -> Siphon Indexed ByteString a
- -> Stream (Of ByteString) m () -- ^ encoded csv
- -> Stream (Of a) m (Maybe SiphonError)
-decodeIndexedCsvUtf8 !requiredLength ixedSiphon s1 = do
- consumeBodyUtf8 0 requiredLength ixedSiphon s1
-
-encodeCsvStreamUtf8 :: (Monad m, CE.Headedness h)
- => CE.Colonnade h a ByteString
- -> Stream (Of a) m r
- -> Stream (Of ByteString) m r
-encodeCsvStreamUtf8 =
- encodeCsvInternal escapeChar8 (B.singleton comma) (B.singleton newline)
-
--- | Streaming variant of 'encodeCsv'. This is particularly useful
--- when you need to produce millions of rows without having them
--- all loaded into memory at the same time.
-encodeCsvStream :: (Monad m, CE.Headedness h)
- => CE.Colonnade h a Text
- -> Stream (Of a) m r
- -> Stream (Of Text) m r
-encodeCsvStream =
- encodeCsvInternal textEscapeChar8 (T.singleton ',') (T.singleton '\n')
-
--- | Encode a collection to a CSV as a text 'TB.Builder'. For example,
--- we can take the following columnar encoding of a person:
---
--- >>> :{
--- let colPerson :: Colonnade Headed Person Text
--- colPerson = mconcat
--- [ C.headed "Name" name
--- , C.headed "Age" (T.pack . show . age)
--- , C.headed "Company" (fromMaybe "N/A" . company)
--- ]
--- :}
---
--- And we have the following people whom we wish to encode
--- in this way:
---
--- >>> :{
--- let people :: [Person]
--- people =
--- [ Person "Chao" 26 (Just "Tectonic, Inc.")
--- , Person "Elsie" 41 (Just "Globex Corporation")
--- , Person "Arabella" 19 Nothing
--- ]
--- :}
---
--- We pair the encoding with the rows to get a CSV:
---
--- >>> LTIO.putStr (TB.toLazyText (encodeCsv colPerson people))
--- Name,Age,Company
--- Chao,26,"Tectonic, Inc."
--- Elsie,41,Globex Corporation
--- Arabella,19,N/A
-encodeCsv :: (Foldable f, CE.Headedness h)
- => CE.Colonnade h a Text -- ^ Tablular encoding
- -> f a -- ^ Value of each row
- -> TB.Builder
-encodeCsv enc =
- textStreamToBuilder . encodeCsvStream enc . SMP.each
-
--- | Encode a collection to a CSV as a bytestring 'BB.Builder'.
-encodeCsvUtf8 :: (Foldable f, CE.Headedness h)
- => CE.Colonnade h a ByteString -- ^ Tablular encoding
- -> f a -- ^ Value of each row
- -> BB.Builder
-encodeCsvUtf8 enc =
- streamToBuilder . encodeCsvStreamUtf8 enc . SMP.each
-
-streamToBuilder :: Stream (Of ByteString) Identity () -> BB.Builder
-streamToBuilder s = SM.destroy s
- (\(bs :> bb) -> BB.byteString bs <> bb) runIdentity (\() -> mempty)
-
-textStreamToBuilder :: Stream (Of Text) Identity () -> TB.Builder
-textStreamToBuilder s = SM.destroy s
- (\(bs :> bb) -> TB.fromText bs <> bb) runIdentity (\() -> mempty)
-
-encodeCsvInternal :: (Monad m, CE.Headedness h)
- => (c -> Escaped c)
- -> c -- ^ separator
- -> c -- ^ newline
- -> CE.Colonnade h a c
- -> Stream (Of a) m r
- -> Stream (Of c) m r
-encodeCsvInternal escapeFunc separatorStr newlineStr colonnade s = do
- case CE.headednessExtract of
- Just toContent -> encodeHeader toContent escapeFunc separatorStr newlineStr colonnade
- Nothing -> return ()
- encodeRows escapeFunc separatorStr newlineStr colonnade s
-
-encodeHeader :: Monad m
- => (h c -> c)
- -> (c -> Escaped c)
- -> c -- ^ separator
- -> c -- ^ newline
- -> CE.Colonnade h a c
- -> Stream (Of c) m ()
-encodeHeader toContent escapeFunc separatorStr newlineStr colonnade = do
- let (vs,ws) = V.splitAt 1 (CE.getColonnade colonnade)
- -- we only need to do this split because the first cell
- -- gets treated differently than the others. It does not
- -- get a separator added before it.
- V.forM_ vs $ \(CE.OneColonnade h _) -> do
- SMP.yield (getEscaped (escapeFunc (toContent h)))
- V.forM_ ws $ \(CE.OneColonnade h _) -> do
- SMP.yield separatorStr
- SMP.yield (getEscaped (escapeFunc (toContent h)))
- SMP.yield newlineStr
-
-mapStreamM :: Monad m
- => (a -> Stream (Of b) m x)
- -> Stream (Of a) m r
- -> Stream (Of b) m r
-mapStreamM f = SM.concats . SM.mapsM (\(a :> s) -> return (f a >> return s))
-
-encodeRows :: Monad m
- => (c -> Escaped c)
- -> c -- ^ separator
- -> c -- ^ newline
- -> CE.Colonnade f a c
- -> Stream (Of a) m r
- -> Stream (Of c) m r
-encodeRows escapeFunc separatorStr newlineStr colonnade = mapStreamM $ \a -> do
- let (vs,ws) = V.splitAt 1 (CE.getColonnade colonnade)
- -- we only need to do this split because the first cell
- -- gets treated differently than the others. It does not
- -- get a separator added before it.
- V.forM_ vs $ \(CE.OneColonnade _ encode) -> SMP.yield (getEscaped (escapeFunc (encode a)))
- V.forM_ ws $ \(CE.OneColonnade _ encode) -> do
- SMP.yield separatorStr
- SMP.yield (getEscaped (escapeFunc (encode a)))
- SMP.yield newlineStr
-
--- | Maps over a 'Decolonnade' that expects headers, converting these
--- expected headers into the indices of the columns that they
--- correspond to.
-headedToIndexed :: forall c a. Eq c
- => (c -> T.Text)
- -> Vector c -- ^ Headers in the source document
- -> Siphon CE.Headed c a -- ^ Decolonnade that contains expected headers
- -> Either SiphonError (Siphon Indexed c a)
-headedToIndexed toStr v =
- mapLeft (\(HeaderErrors a b c) -> SiphonError 0 (RowErrorHeaders a b c))
- . getEitherWrap
- . go
- where
- go :: forall b.
- Siphon CE.Headed c b
- -> EitherWrap HeaderErrors (Siphon Indexed c b)
- go (SiphonPure b) = EitherWrap (Right (SiphonPure b))
- go (SiphonAp (CE.Headed h) decode apNext) =
- let rnext = go apNext
- ixs = V.elemIndices h v
- ixsLen = V.length ixs
- rcurrent
- | ixsLen == 1 = Right (ixs V.! 0)
- | ixsLen == 0 = Left (HeaderErrors V.empty (V.singleton (toStr h)) V.empty)
- | otherwise =
- let dups = V.singleton (V.map (\ix -> CellError ix (toStr (v V.! ix) {- (V.unsafeIndex v ix) -} )) ixs)
- in Left (HeaderErrors dups V.empty V.empty)
- in (\ix nextSiphon -> SiphonAp (Indexed ix) decode nextSiphon)
- <$> EitherWrap rcurrent
- <*> rnext
-
-data HeaderErrors = HeaderErrors !(Vector (Vector CellError)) !(Vector T.Text) !(Vector Int)
-
-instance Semigroup HeaderErrors where
- HeaderErrors a1 b1 c1 <> HeaderErrors a2 b2 c2 = HeaderErrors
- (mappend a1 a2) (mappend b1 b2) (mappend c1 c2)
-
-instance Monoid HeaderErrors where
- mempty = HeaderErrors mempty mempty mempty
- mappend = (SG.<>)
-
--- byteStringChar8 :: Siphon ByteString
--- byteStringChar8 = Siphon
--- escape
--- encodeRow
--- (A.parse (row comma))
--- B.null
-
-escapeChar8 :: ByteString -> Escaped ByteString
-escapeChar8 t = case B.find (\c -> c == newline || c == cr || c == comma || c == doubleQuote) t of
- Nothing -> Escaped t
- Just _ -> escapeAlways t
-
-textEscapeChar8 :: Text -> Escaped Text
-textEscapeChar8 t = case T.find (\c -> c == '\n' || c == '\r' || c == ',' || c == '"') t of
- Nothing -> Escaped t
- Just _ -> textEscapeAlways t
-
--- This implementation is definitely suboptimal.
--- A better option (which would waste a little space
--- but would be much faster) would be to build the
--- new bytestring by writing to a buffer directly.
-escapeAlways :: ByteString -> Escaped ByteString
-escapeAlways t = Escaped $ LByteString.toStrict $ Builder.toLazyByteString $
- Builder.word8 doubleQuote
- <> B.foldl
- (\ acc b -> acc <> if b == doubleQuote
- then Builder.byteString
- (B.pack [doubleQuote,doubleQuote])
- else Builder.word8 b)
- mempty
- t
- <> Builder.word8 doubleQuote
-
--- Suboptimal for similar reason as escapeAlways.
-textEscapeAlways :: Text -> Escaped Text
-textEscapeAlways t = Escaped $ LT.toStrict $ TB.toLazyText $
- TB.singleton '"'
- <> T.foldl
- (\ acc b -> acc <> if b == '"'
- then TB.fromString "\"\""
- else TB.singleton b
- )
- mempty
- t
- <> TB.singleton '"'
-
--- Parse a record, not including the terminating line separator. The
--- terminating line separate is not included as the last record in a
--- CSV file is allowed to not have a terminating line separator. You
--- most likely want to use the 'endOfLine' parser in combination with
--- this parser.
---
--- row :: Word8 -- ^ Field delimiter
--- -> AL.Parser (Vector ByteString)
--- row !delim = rowNoNewline delim <* endOfLine
--- {-# INLINE row #-}
---
--- rowNoNewline :: Word8 -- ^ Field delimiter
--- -> AL.Parser (Vector ByteString)
--- rowNoNewline !delim = V.fromList <$!> field delim `sepByDelim1'` delim
--- {-# INLINE rowNoNewline #-}
---
--- removeBlankLines :: [Vector ByteString] -> [Vector ByteString]
--- removeBlankLines = filter (not . blankLine)
-
-
--- | Parse a field. The field may be in either the escaped or
--- non-escaped format. The return value is unescaped. This
--- parser will consume the comma that comes after a field
--- but not a newline that follows a field. If we are positioned
--- at a newline when it starts, that newline will be consumed
--- and we return CellResultNewline.
-field :: Word8 -> AL.Parser (CellResult ByteString)
-field !delim = do
- mb <- A.peekWord8
- -- We purposely don't use <|> as we want to commit to the first
- -- choice if we see a double quote.
- case mb of
- Just b
- | b == doubleQuote -> do
- (bs,tc) <- escapedField
- case tc of
- TrailCharComma -> return (CellResultData bs)
- TrailCharNewline -> return (CellResultNewline bs EndedNo)
- TrailCharEnd -> return (CellResultNewline bs EndedYes)
- | b == 10 || b == 13 -> do
- _ <- eatNewlines
- isEnd <- A.atEnd
- if isEnd
- then return (CellResultNewline B.empty EndedYes)
- else return (CellResultNewline B.empty EndedNo)
- | otherwise -> do
- (bs,tc) <- unescapedField delim
- case tc of
- TrailCharComma -> return (CellResultData bs)
- TrailCharNewline -> return (CellResultNewline bs EndedNo)
- TrailCharEnd -> return (CellResultNewline bs EndedYes)
- Nothing -> return (CellResultNewline B.empty EndedYes)
-{-# INLINE field #-}
-
-eatNewlines :: AL.Parser S.ByteString
-eatNewlines = A.takeWhile (\x -> x == 10 || x == 13)
-
-escapedField :: AL.Parser (S.ByteString,TrailChar)
-escapedField = do
- _ <- dquote
- -- The scan state is 'True' if the previous character was a double
- -- quote. We need to drop a trailing double quote left by scan.
- s <- S.init <$>
- ( A.scan False $ \s c ->
- if c == doubleQuote
- then Just (not s)
- else if s
- then Nothing
- else Just False
- )
- mb <- A.peekWord8
- trailChar <- case mb of
- Just b
- | b == comma -> A.anyWord8 >> return TrailCharComma
- | b == newline -> A.anyWord8 >> return TrailCharNewline
- | b == cr -> do
- _ <- A.anyWord8
- _ <- A.word8 newline
- return TrailCharNewline
- | otherwise -> fail "encountered double quote after escaped field"
- Nothing -> return TrailCharEnd
- if doubleQuote `S.elem` s
- then case Z.parse unescape s of
- Right r -> return (r,trailChar)
- Left err -> fail err
- else return (s,trailChar)
-
-data TrailChar = TrailCharNewline | TrailCharComma | TrailCharEnd
-
--- | Consume an unescaped field. If it ends with a newline,
--- leave that in tact. If it ends with a comma, consume the comma.
-unescapedField :: Word8 -> AL.Parser (S.ByteString,TrailChar)
-unescapedField !delim = do
- bs <- A.takeWhile $ \c ->
- c /= doubleQuote &&
- c /= newline &&
- c /= delim &&
- c /= cr
- mb <- A.peekWord8
- case mb of
- Just b
- | b == comma -> A.anyWord8 >> return (bs,TrailCharComma)
- | b == newline -> A.anyWord8 >> return (bs,TrailCharNewline)
- | b == cr -> do
- _ <- A.anyWord8
- _ <- A.word8 newline
- return (bs,TrailCharNewline)
- | otherwise -> fail "encountered double quote in unescaped field"
- Nothing -> return (bs,TrailCharEnd)
-
-dquote :: AL.Parser Char
-dquote = char '"'
-
--- | This could be improved. We could avoid the builder and just
--- write to a buffer directly.
-unescape :: Z.Parser S.ByteString
-unescape = (LByteString.toStrict . toLazyByteString) <$!> go mempty where
- go acc = do
- h <- Z.takeWhile (/= doubleQuote)
- let rest = do
- start <- Z.take 2
- if (S.unsafeHead start == doubleQuote &&
- S.unsafeIndex start 1 == doubleQuote)
- then go (acc `mappend` byteString h `mappend` byteString (BC8.singleton '"'))
- else fail "invalid CSV escape sequence"
- done <- Z.atEnd
- if done
- then return (acc `mappend` byteString h)
- else rest
-
-doubleQuote, newline, cr, comma :: Word8
-doubleQuote = 34
-newline = 10
-cr = 13
-comma = 44
-
--- | This adds one to the index because text editors consider
--- line number to be one-based, not zero-based.
-humanizeSiphonError :: SiphonError -> String
-humanizeSiphonError (SiphonError ix e) = unlines
- $ ("Decolonnade error on line " ++ show (ix + 1) ++ " of file.")
- : ("Error Category: " ++ descr)
- : map (" " ++) errDescrs
- where (descr,errDescrs) = prettyRowError e
-
-prettyRowError :: RowError -> (String, [String])
-prettyRowError x = case x of
- RowErrorParse -> (,) "CSV Parsing"
- [ "The cells were malformed."
- ]
- RowErrorSize reqLen actualLen -> (,) "Row Length"
- [ "Expected the row to have exactly " ++ show reqLen ++ " cells."
- , "The row only has " ++ show actualLen ++ " cells."
- ]
- RowErrorHeaderSize reqLen actualLen -> (,) "Minimum Header Length"
- [ "Expected the row to have at least " ++ show reqLen ++ " cells."
- , "The row only has " ++ show actualLen ++ " cells."
- ]
- RowErrorMalformed column -> (,) "Text Decolonnade"
- [ "Tried to decode input input in column " ++ columnNumToLetters column ++ " text"
- , "There is a mistake in the encoding of the text."
- ]
- RowErrorHeaders dupErrs namedErrs unnamedErrs -> (,) "Missing Headers" $ concat
- [ if V.length namedErrs > 0 then prettyNamedMissingHeaders namedErrs else []
- , if V.length unnamedErrs > 0 then ["Missing unnamed headers"] else []
- , if V.length dupErrs > 0 then prettyHeadingErrors dupErrs else []
- ]
- RowErrorDecode errs -> (,) "Cell Decolonnade" (prettyCellErrors errs)
-
-prettyCellErrors :: Vector CellError -> [String]
-prettyCellErrors errs = drop 1 $
- flip concatMap errs $ \(CellError ix content) ->
- let str = T.unpack content in
- [ "-----------"
- , "Column " ++ columnNumToLetters ix
- , "Cell Content Length: " ++ show (Prelude.length str)
- , "Cell Content: " ++ if null str
- then "[empty cell]"
- else str
- ]
-
-prettyNamedMissingHeaders :: Vector T.Text -> [String]
-prettyNamedMissingHeaders missing = concat
- [ concatMap (\h -> ["The header " ++ T.unpack h ++ " was missing."]) missing
- ]
-
-prettyHeadingErrors :: Vector (Vector CellError) -> [String]
-prettyHeadingErrors missing = join (V.toList (fmap f missing))
- where
- f :: Vector CellError -> [String]
- f v
- | not (V.null w) && V.all (== V.head w) (V.tail w) =
- [ "The header ["
- , T.unpack (V.head w)
- , "] appears in columns "
- , L.intercalate ", " (V.toList (V.map (\(CellError ix _) -> columnNumToLetters ix) v))
- ]
- | otherwise = multiMsg : V.toList
- (V.map (\(CellError ix content) -> " Column " ++ columnNumToLetters ix ++ ": " ++ T.unpack content) v)
- where
- w :: Vector T.Text
- w = V.map cellErrorContent v
- multiMsg :: String
- multiMsg = "Multiple headers matched the same predicate:"
-
-columnNumToLetters :: Int -> String
-columnNumToLetters i
- | i >= 0 && i < 25 = [chr (i + 65)]
- | otherwise = "Beyond Z. Fix this."
-
-newtype EitherWrap a b = EitherWrap
- { getEitherWrap :: Either a b
- } deriving (Functor)
-
-instance Monoid a => Applicative (EitherWrap a) where
- pure = EitherWrap . Right
- EitherWrap (Left a1) <*> EitherWrap (Left a2) = EitherWrap (Left (mappend a1 a2))
- EitherWrap (Left a1) <*> EitherWrap (Right _) = EitherWrap (Left a1)
- EitherWrap (Right _) <*> EitherWrap (Left a2) = EitherWrap (Left a2)
- EitherWrap (Right f) <*> EitherWrap (Right b) = EitherWrap (Right (f b))
-
-mapLeft :: (a -> b) -> Either a c -> Either b c
-mapLeft _ (Right a) = Right a
-mapLeft f (Left a) = Left (f a)
-
-consumeHeaderRowUtf8 :: Monad m
- => Stream (Of ByteString) m ()
- -> m (Either SiphonError (Of (Vector ByteString) (Stream (Of ByteString) m ())))
-consumeHeaderRowUtf8 = consumeHeaderRow (A.parse (field comma)) B.null B.empty (\() -> True)
-
-consumeBodyUtf8 :: forall m a. Monad m
- => Int -- ^ index of first row, usually zero or one
- -> Int -- ^ Required row length
- -> Siphon Indexed ByteString a
- -> Stream (Of ByteString) m ()
- -> Stream (Of a) m (Maybe SiphonError)
-consumeBodyUtf8 = consumeBody utf8ToStr
- (A.parse (field comma)) B.null B.empty (\() -> True)
-
-utf8ToStr :: ByteString -> T.Text
-utf8ToStr = either (\_ -> T.empty) id . decodeUtf8'
-
-consumeHeaderRow :: forall m r c. Monad m
- => (c -> ATYP.IResult c (CellResult c))
- -> (c -> Bool) -- ^ true if null string
- -> c
- -> (r -> Bool) -- ^ true if termination is acceptable
- -> Stream (Of c) m r
- -> m (Either SiphonError (Of (Vector c) (Stream (Of c) m r)))
-consumeHeaderRow parseCell isNull emptyStr isGood s0 = go 0 StrictListNil s0
- where
- go :: Int
- -> StrictList c
- -> Stream (Of c) m r
- -> m (Either SiphonError (Of (Vector c) (Stream (Of c) m r)))
- go !cellsLen !cells !s1 = do
- e <- skipWhile isNull s1
- case e of
- Left r -> return $ if isGood r
- then Right (reverseVectorStrictList cellsLen cells :> return r)
- else Left (SiphonError 0 RowErrorParse)
- Right (c :> s2) -> handleResult cellsLen cells (parseCell c) s2
- handleResult :: Int -> StrictList c
- -> ATYP.IResult c (CellResult c)
- -> Stream (Of c) m r
- -> m (Either SiphonError (Of (Vector c) (Stream (Of c) m r)))
- handleResult !cellsLen !cells !result s1 = case result of
- ATYP.Fail _ _ _ -> return $ Left $ SiphonError 0 RowErrorParse
- ATYP.Done !c1 !res -> case res of
- -- it might be wrong to ignore whether or not the stream has ended
- CellResultNewline cd _ -> do
- let v = reverseVectorStrictList (cellsLen + 1) (StrictListCons cd cells)
- return (Right (v :> (SMP.yield c1 >> s1)))
- CellResultData !cd -> if isNull c1
- then go (cellsLen + 1) (StrictListCons cd cells) s1
- else handleResult (cellsLen + 1) (StrictListCons cd cells) (parseCell c1) s1
- ATYP.Partial k -> do
- e <- skipWhile isNull s1
- case e of
- Left r -> handleResult cellsLen cells (k emptyStr) (return r)
- Right (c1 :> s2) -> handleResult cellsLen cells (k c1) s2
-
-consumeBody :: forall m r c a. Monad m
- => (c -> T.Text)
- -> (c -> ATYP.IResult c (CellResult c))
- -> (c -> Bool)
- -> c
- -> (r -> Bool) -- ^ True if termination is acceptable. False if it is because of a decoding error.
- -> Int -- ^ index of first row, usually zero or one
- -> Int -- ^ Required row length
- -> Siphon Indexed c a
- -> Stream (Of c) m r
- -> Stream (Of a) m (Maybe SiphonError)
-consumeBody toStr parseCell isNull emptyStr isGood row0 reqLen siphon s0 =
- go row0 0 StrictListNil s0
- where
- go :: Int -> Int -> StrictList c -> Stream (Of c) m r -> Stream (Of a) m (Maybe SiphonError)
- go !row !cellsLen !cells !s1 = do
- e <- lift (skipWhile isNull s1)
- case e of
- Left r -> return $ if isGood r
- then Nothing
- else Just (SiphonError row RowErrorParse)
- Right (c :> s2) -> handleResult row cellsLen cells (parseCell c) s2
- handleResult :: Int -> Int -> StrictList c
- -> ATYP.IResult c (CellResult c)
- -> Stream (Of c) m r
- -> Stream (Of a) m (Maybe SiphonError)
- handleResult !row !cellsLen !cells !result s1 = case result of
- ATYP.Fail _ _ _ -> return $ Just $ SiphonError row RowErrorParse
- ATYP.Done !c1 !res -> case res of
- CellResultNewline !cd !ended -> do
- case decodeRow row (reverseVectorStrictList (cellsLen + 1) (StrictListCons cd cells)) of
- Left err -> return (Just err)
- Right a -> do
- SMP.yield a
- case ended of
- EndedYes -> do
- e <- lift (SM.inspect s1)
- case e of
- Left r -> return $ if isGood r
- then Nothing
- else Just (SiphonError row RowErrorParse)
- Right _ -> error "siphon: logical error, stream should be exhausted"
- EndedNo -> if isNull c1
- then go (row + 1) 0 StrictListNil s1
- else handleResult (row + 1) 0 StrictListNil (parseCell c1) s1
- CellResultData !cd -> if isNull c1
- then go row (cellsLen + 1) (StrictListCons cd cells) s1
- else handleResult row (cellsLen + 1) (StrictListCons cd cells) (parseCell c1) s1
- ATYP.Partial k -> do
- e <- lift (skipWhile isNull s1)
- case e of
- Left r -> handleResult row cellsLen cells (k emptyStr) (return r)
- Right (c1 :> s2) -> handleResult row cellsLen cells (k c1) s2
- decodeRow :: Int -> Vector c -> Either SiphonError a
- decodeRow rowIx v =
- let vlen = V.length v in
- if vlen /= reqLen
- then Left $ SiphonError rowIx $ RowErrorSize reqLen vlen
- else uncheckedRunWithRow toStr rowIx siphon v
-
--- | You must pass the length of the list and as the first argument.
--- Passing the wrong length will lead to an error.
-reverseVectorStrictList :: forall c. Int -> StrictList c -> Vector c
-reverseVectorStrictList len sl0 = V.create $ do
- mv <- MV.new len
- go1 mv
- return mv
- where
- go1 :: forall s. MVector s c -> ST s ()
- go1 !mv = go2 (len - 1) sl0
- where
- go2 :: Int -> StrictList c -> ST s ()
- go2 _ StrictListNil = return ()
- go2 !ix (StrictListCons c slNext) = do
- MV.write mv ix c
- go2 (ix - 1) slNext
-
-
-skipWhile :: forall m a r. Monad m
- => (a -> Bool)
- -> Stream (Of a) m r
- -> m (Either r (Of a (Stream (Of a) m r)))
-skipWhile f = go where
- go :: Stream (Of a) m r
- -> m (Either r (Of a (Stream (Of a) m r)))
- go s1 = do
- e <- SM.inspect s1
- case e of
- Left _ -> return e
- Right (a :> s2) -> if f a
- then go s2
- else return e
-
--- | Strict in the spine and in the values
--- This is built in reverse and then reversed by reverseVectorStrictList
--- when converting to a vector.
-data StrictList a = StrictListNil | StrictListCons !a !(StrictList a)
-
--- | This function uses 'unsafeIndex' to access
--- elements of the 'Vector'.
-uncheckedRunWithRow ::
- (c -> T.Text)
- -> Int
- -> Siphon Indexed c a
- -> Vector c
- -> Either SiphonError a
-uncheckedRunWithRow toStr i d v =
- mapLeft (SiphonError i . RowErrorDecode) (uncheckedRun toStr d v)
-
--- | This function does not check to make sure that the indicies in
--- the 'Decolonnade' are in the 'Vector'. Only use this if you have
--- already verified that none of the indices in the siphon are
--- out of the bounds.
-uncheckedRun :: forall c a.
- (c -> T.Text)
- -> Siphon Indexed c a
- -> Vector c
- -> Either (Vector CellError) a
-uncheckedRun toStr dc v = getEitherWrap (go dc)
- where
- go :: forall b.
- Siphon Indexed c b
- -> EitherWrap (Vector CellError) b
- go (SiphonPure b) = EitherWrap (Right b)
- go (SiphonAp (Indexed ix) decode apNext) =
- let rnext = go apNext
- content = v V.! ix -- V.unsafeIndex v ix
- rcurrent = maybe
- (Left (V.singleton (CellError ix (toStr content))))
- Right
- (decode content)
- in rnext <*> (EitherWrap rcurrent)
-
--- | Uses the argument to parse a CSV column.
-headless :: (c -> Maybe a) -> Siphon CE.Headless c a
-headless f = SiphonAp CE.Headless f (SiphonPure id)
-
--- | Uses the second argument to parse a CSV column whose
--- header content matches the first column exactly.
-headed :: c -> (c -> Maybe a) -> Siphon CE.Headed c a
-headed h f = SiphonAp (CE.Headed h) f (SiphonPure id)
-
--- | Uses the second argument to parse a CSV column that
--- is positioned at the index given by the first argument.
-indexed :: Int -> (c -> Maybe a) -> Siphon Indexed c a
-indexed ix f = SiphonAp (Indexed ix) f (SiphonPure id)
-
-eqSiphonHeaders :: (Eq1 f, Eq c) => Siphon f c a -> Siphon f c b -> Bool
-eqSiphonHeaders (SiphonPure _) (SiphonPure _) = True
-eqSiphonHeaders (SiphonAp h0 _ s0) (SiphonAp h1 _ s1) =
- liftEq (==) h0 h1 && eqSiphonHeaders s0 s1
-eqSiphonHeaders _ _ = False
-
-showSiphonHeaders :: (Show1 f, Show c) => Siphon f c a -> String
-showSiphonHeaders (SiphonPure _) = ""
-showSiphonHeaders (SiphonAp h0 _ s0) = showsPrec1 10 h0 (" :> " ++ showSiphonHeaders s0)
-
--- $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}
-
diff --git a/siphon/src/Siphon/ByteString/Char8.hs b/siphon/src/Siphon/ByteString/Char8.hs
deleted file mode 100644
index a4a0418..0000000
--- a/siphon/src/Siphon/ByteString/Char8.hs
+++ /dev/null
@@ -1 +0,0 @@
-module Siphon.ByteString.Char8 where
diff --git a/siphon/src/Siphon/Content.hs b/siphon/src/Siphon/Content.hs
deleted file mode 100644
index 899f38a..0000000
--- a/siphon/src/Siphon/Content.hs
+++ /dev/null
@@ -1,8 +0,0 @@
-module Siphon.Content
- ( byteStringChar8
- , text
- ) where
-
-import Siphon.Internal (byteStringChar8)
-import Siphon.Internal.Text (text)
-
diff --git a/siphon/src/Siphon/Decoding.hs b/siphon/src/Siphon/Decoding.hs
deleted file mode 100644
index 8a9f753..0000000
--- a/siphon/src/Siphon/Decoding.hs
+++ /dev/null
@@ -1,336 +0,0 @@
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE DeriveFunctor #-}
-
-module Siphon.Decoding
- ( mkParseError
- , headlessPipe
- , indexedPipe
- , headedPipe
- , consumeGeneral
- , pipeGeneral
- , convertDecodeError
- ) where
-
-import Siphon.Types
-import Colonnade (Headed(..),Headless(..))
-import Siphon.Internal (row,comma)
-import Data.Text (Text)
-import Data.ByteString (ByteString)
-import Pipes (yield,Pipe,Consumer',Producer,await)
-import Data.Vector (Vector)
-import Data.Functor.Contravariant (Contravariant(..))
-import Data.Char (chr)
-import qualified Data.Vector as Vector
-import qualified Data.Attoparsec.ByteString as AttoByteString
-import qualified Data.ByteString.Char8 as ByteString
-import qualified Data.Attoparsec.Types as Atto
-
-mkParseError :: Int -> [String] -> String -> DecolonnadeRowError f content
-mkParseError i ctxs msg = id
- $ DecolonnadeRowError i
- $ RowErrorParse $ concat
- [ "Contexts: ["
- , concat ctxs
- , "], Error Message: ["
- , msg
- , "]"
- ]
-
--- | This is a convenience function for working with @pipes-text@.
--- It will convert a UTF-8 decoding error into a `DecolonnadeRowError`,
--- so the pipes can be properly chained together.
-convertDecodeError :: String -> Either (Producer ByteString m ()) () -> Maybe (DecolonnadeRowError f c)
-convertDecodeError encodingName (Left _) = Just (DecolonnadeRowError 0 (RowErrorMalformed encodingName))
-convertDecodeError _ (Right ()) = Nothing
-
--- | This is seldom useful but is included for completeness.
-headlessPipe :: Monad m
- => Siphon c
- -> Decolonnade Headless c a
- -> Pipe c a m (DecolonnadeRowError Headless c)
-headlessPipe sd decoding = uncheckedPipe requiredLength 0 sd indexedDecoding Nothing
- where
- indexedDecoding = headlessToIndexed decoding
- requiredLength = decLength indexedDecoding
-
-indexedPipe :: Monad m
- => Siphon c
- -> Decolonnade (Indexed Headless) c a
- -> Pipe c a m (DecolonnadeRowError Headless c)
-indexedPipe sd decoding = do
- e <- consumeGeneral 0 sd mkParseError
- case e of
- Left err -> return err
- Right (firstRow, mleftovers) ->
- let req = maxIndex decoding
- vlen = Vector.length firstRow
- in if vlen < req
- then return (DecolonnadeRowError 0 (RowErrorMinSize req vlen))
- else case uncheckedRun decoding firstRow of
- Left cellErr -> return $ DecolonnadeRowError 0 $ RowErrorDecode cellErr
- Right a -> do
- yield a
- uncheckedPipe vlen 1 sd decoding mleftovers
-
-
-headedPipe :: (Monad m, Eq c)
- => Siphon c
- -> Decolonnade Headed c a
- -> Pipe c a m (DecolonnadeRowError Headed c)
-headedPipe sd decoding = do
- e <- consumeGeneral 0 sd mkParseError
- case e of
- Left err -> return err
- Right (headers, mleftovers) ->
- case headedToIndexed headers decoding of
- Left headingErrs -> return (DecolonnadeRowError 0 (RowErrorHeading headingErrs))
- Right indexedDecoding ->
- let requiredLength = Vector.length headers
- in uncheckedPipe requiredLength 1 sd indexedDecoding mleftovers
-
-
-uncheckedPipe :: Monad m
- => Int -- ^ expected length of each row
- -> Int -- ^ index of first row, usually zero or one
- -> Siphon c
- -> Decolonnade (Indexed f) c a
- -> Maybe c
- -> Pipe c a m (DecolonnadeRowError f c)
-uncheckedPipe requiredLength ix sd d mleftovers =
- pipeGeneral ix sd mkParseError checkedRunWithRow mleftovers
- where
- checkedRunWithRow rowIx v =
- let vlen = Vector.length v in
- if vlen /= requiredLength
- then Left $ DecolonnadeRowError rowIx
- $ RowErrorSize requiredLength vlen
- else uncheckedRunWithRow rowIx d v
-
-consumeGeneral :: Monad m
- => Int
- -> Siphon c
- -> (Int -> [String] -> String -> e)
- -> Consumer' c m (Either e (Vector c, Maybe c))
-consumeGeneral ix (Siphon _ _ parse isNull) wrapParseError = do
- c <- awaitSkip isNull
- handleResult (parse c)
- where
- go k = do
- c <- awaitSkip isNull
- handleResult (k c)
- handleResult r = case r of
- Atto.Fail _ ctxs msg -> return $ Left
- $ wrapParseError ix ctxs msg
- Atto.Done c v ->
- let mcontent = if isNull c
- then Nothing
- else Just c
- in return (Right (v,mcontent))
- Atto.Partial k -> go k
-
-pipeGeneral :: Monad m
- => Int -- ^ index of first row, usually zero or one
- -> Siphon c
- -> (Int -> [String] -> String -> e)
- -> (Int -> Vector c -> Either e a)
- -> Maybe c -- ^ leftovers that should be handled first
- -> Pipe c a m e
-pipeGeneral initIx (Siphon _ _ parse isNull) wrapParseError decodeRow mleftovers =
- case mleftovers of
- Nothing -> go1 initIx
- Just leftovers -> handleResult initIx (parse leftovers)
- where
- go1 !ix = do
- c1 <- awaitSkip isNull
- handleResult ix (parse c1)
- go2 !ix c1 = handleResult ix (parse c1)
- go3 !ix k = do
- c1 <- awaitSkip isNull
- handleResult ix (k c1)
- handleResult !ix r = case r of
- Atto.Fail _ ctxs msg -> return $ wrapParseError ix ctxs msg
- Atto.Done c1 v -> do
- case decodeRow ix v of
- Left err -> return err
- Right r -> do
- yield r
- let ixNext = ix + 1
- if isNull c1 then go1 ixNext else go2 ixNext c1
- Atto.Partial k -> go3 ix k
-
-awaitSkip :: Monad m
- => (a -> Bool)
- -> Consumer' a m a
-awaitSkip f = go where
- go = do
- a <- await
- if f a then go else return a
-
--- | Converts the content type of a 'Decolonnade'. The @'Contravariant' f@
--- constraint means that @f@ can be 'Headless' but not 'Headed'.
-contramapContent :: forall c1 c2 f a. Contravariant f => (c2 -> c1) -> Decolonnade f c1 a -> Decolonnade f c2 a
-contramapContent f = go
- where
- go :: forall b. Decolonnade f c1 b -> Decolonnade f c2 b
- go (DecolonnadePure x) = DecolonnadePure x
- go (DecolonnadeAp h decode apNext) =
- DecolonnadeAp (contramap f h) (decode . f) (go apNext)
-
-headless :: (content -> Either String a) -> Decolonnade Headless content a
-headless f = DecolonnadeAp Headless f (DecolonnadePure id)
-
-headed :: content -> (content -> Either String a) -> Decolonnade Headed content a
-headed h f = DecolonnadeAp (Headed h) f (DecolonnadePure id)
-
-indexed :: Int -> (content -> Either String a) -> Decolonnade (Indexed Headless) content a
-indexed ix f = DecolonnadeAp (Indexed ix Headless) f (DecolonnadePure id)
-
-maxIndex :: forall f c a. Decolonnade (Indexed f) c a -> Int
-maxIndex = go 0 where
- go :: forall b. Int -> Decolonnade (Indexed f) c b -> Int
- go !ix (DecolonnadePure _) = ix
- go !ix1 (DecolonnadeAp (Indexed ix2 _) decode apNext) =
- go (max ix1 ix2) apNext
-
--- | This function uses 'unsafeIndex' to access
--- elements of the 'Vector'.
-uncheckedRunWithRow ::
- Int
- -> Decolonnade (Indexed f) content a
- -> Vector content
- -> Either (DecolonnadeRowError f content) a
-uncheckedRunWithRow i d v = mapLeft (DecolonnadeRowError i . RowErrorDecode) (uncheckedRun d v)
-
--- | This function does not check to make sure that the indicies in
--- the 'Decolonnade' are in the 'Vector'.
-uncheckedRun :: forall content a f.
- Decolonnade (Indexed f) content a
- -> Vector content
- -> Either (DecolonnadeCellErrors f content) a
-uncheckedRun dc v = getEitherWrap (go dc)
- where
- go :: forall b.
- Decolonnade (Indexed f) content b
- -> EitherWrap (DecolonnadeCellErrors f content) b
- go (DecolonnadePure b) = EitherWrap (Right b)
- go (DecolonnadeAp ixed@(Indexed ix h) decode apNext) =
- let rnext = go apNext
- content = Vector.unsafeIndex v ix
- rcurrent = mapLeft (DecolonnadeCellErrors . Vector.singleton . DecolonnadeCellError content ixed) (decode content)
- in rnext <*> (EitherWrap rcurrent)
-
-headlessToIndexed :: forall c a.
- Decolonnade Headless c a -> Decolonnade (Indexed Headless) c a
-headlessToIndexed = go 0 where
- go :: forall b. Int -> Decolonnade Headless c b -> Decolonnade (Indexed Headless) c b
- go !ix (DecolonnadePure a) = DecolonnadePure a
- go !ix (DecolonnadeAp Headless decode apNext) =
- DecolonnadeAp (Indexed ix Headless) decode (go (ix + 1) apNext)
-
-decLength :: forall f c a. Decolonnade f c a -> Int
-decLength = go 0 where
- go :: forall b. Int -> Decolonnade f c b -> Int
- go !a (DecolonnadePure _) = a
- go !a (DecolonnadeAp _ _ apNext) = go (a + 1) apNext
-
--- | Maps over a 'Decolonnade' that expects headers, converting these
--- expected headers into the indices of the columns that they
--- correspond to.
-headedToIndexed :: forall content a. Eq content
- => Vector content -- ^ Headers in the source document
- -> Decolonnade Headed content a -- ^ Decolonnade that contains expected headers
- -> Either (HeadingErrors content) (Decolonnade (Indexed Headed) content a)
-headedToIndexed v = getEitherWrap . go
- where
- go :: forall b. Eq content
- => Decolonnade Headed content b
- -> EitherWrap (HeadingErrors content) (Decolonnade (Indexed Headed) content b)
- go (DecolonnadePure b) = EitherWrap (Right (DecolonnadePure b))
- go (DecolonnadeAp hd@(Headed h) decode apNext) =
- let rnext = go apNext
- ixs = Vector.elemIndices h v
- ixsLen = Vector.length ixs
- rcurrent
- | ixsLen == 1 = Right (Vector.unsafeIndex ixs 0)
- | ixsLen == 0 = Left (HeadingErrors (Vector.singleton h) Vector.empty)
- | otherwise = Left (HeadingErrors Vector.empty (Vector.singleton (h,ixsLen)))
- in (\ix ap -> DecolonnadeAp (Indexed ix hd) decode ap)
- <$> EitherWrap rcurrent
- <*> rnext
-
--- | This adds one to the index because text editors consider
--- line number to be one-based, not zero-based.
-prettyError :: (c -> String) -> DecolonnadeRowError f c -> String
-prettyError toStr (DecolonnadeRowError ix e) = unlines
- $ ("Decolonnade error on line " ++ show (ix + 1) ++ " of file.")
- : ("Error Category: " ++ descr)
- : map (" " ++) errDescrs
- where (descr,errDescrs) = prettyRowError toStr e
-
-prettyRowError :: (content -> String) -> RowError f content -> (String, [String])
-prettyRowError toStr x = case x of
- RowErrorParse err -> (,) "CSV Parsing"
- [ "The line could not be parsed into cells correctly."
- , "Original parser error: " ++ err
- ]
- RowErrorSize reqLen actualLen -> (,) "Row Length"
- [ "Expected the row to have exactly " ++ show reqLen ++ " cells."
- , "The row only has " ++ show actualLen ++ " cells."
- ]
- RowErrorMinSize reqLen actualLen -> (,) "Row Min Length"
- [ "Expected the row to have at least " ++ show reqLen ++ " cells."
- , "The row only has " ++ show actualLen ++ " cells."
- ]
- RowErrorMalformed enc -> (,) "Text Decolonnade"
- [ "Tried to decode the input as " ++ enc ++ " text"
- , "There is a mistake in the encoding of the text."
- ]
- RowErrorHeading errs -> (,) "Header" (prettyHeadingErrors toStr errs)
- RowErrorDecode errs -> (,) "Cell Decolonnade" (prettyCellErrors toStr errs)
-
-prettyCellErrors :: (c -> String) -> DecolonnadeCellErrors f c -> [String]
-prettyCellErrors toStr (DecolonnadeCellErrors errs) = drop 1 $
- flip concatMap errs $ \(DecolonnadeCellError content (Indexed ix _) msg) ->
- let str = toStr content in
- [ "-----------"
- , "Column " ++ columnNumToLetters ix
- , "Original parse error: " ++ msg
- , "Cell Content Length: " ++ show (Prelude.length str)
- , "Cell Content: " ++ if null str
- then "[empty cell]"
- else str
- ]
-
-prettyHeadingErrors :: (c -> String) -> HeadingErrors c -> [String]
-prettyHeadingErrors conv (HeadingErrors missing duplicates) = concat
- [ concatMap (\h -> ["The header " ++ conv h ++ " was missing."]) missing
- , concatMap (\(h,n) -> ["The header " ++ conv h ++ " occurred " ++ show n ++ " times."]) duplicates
- ]
-
-columnNumToLetters :: Int -> String
-columnNumToLetters i
- | i >= 0 && i < 25 = [chr (i + 65)]
- | otherwise = "Beyond Z. Fix this."
-
-
-newtype EitherWrap a b = EitherWrap
- { getEitherWrap :: Either a b
- } deriving (Functor)
-
-instance Monoid a => Applicative (EitherWrap a) where
- pure = EitherWrap . Right
- EitherWrap (Left a1) <*> EitherWrap (Left a2) = EitherWrap (Left (mappend a1 a2))
- EitherWrap (Left a1) <*> EitherWrap (Right _) = EitherWrap (Left a1)
- EitherWrap (Right _) <*> EitherWrap (Left a2) = EitherWrap (Left a2)
- EitherWrap (Right f) <*> EitherWrap (Right b) = EitherWrap (Right (f b))
-
-mapLeft :: (a -> b) -> Either a c -> Either b c
-mapLeft _ (Right a) = Right a
-mapLeft f (Left a) = Left (f a)
-
-
-
-
-
diff --git a/siphon/src/Siphon/Encoding.hs b/siphon/src/Siphon/Encoding.hs
deleted file mode 100644
index dba3d2a..0000000
--- a/siphon/src/Siphon/Encoding.hs
+++ /dev/null
@@ -1,30 +0,0 @@
-module Siphon.Encoding where
-
-import Siphon.Types
-import Colonnade (Colonnade,Headed)
-import Pipes (Pipe,yield)
-import qualified Pipes.Prelude as Pipes
-import qualified Colonnade.Encode as E
-
-row :: Siphon c -> Colonnade f a c -> a -> c
-row (Siphon escape intercalate _ _) e =
- intercalate . E.row escape e
-
-header :: Siphon c -> Colonnade Headed a c -> c
-header (Siphon escape intercalate _ _) e =
- intercalate (E.header escape e)
-
-pipe :: Monad m
- => Siphon c
- -> Colonnade f a c
- -> Pipe a c m x
-pipe siphon encoding = Pipes.map (row siphon encoding)
-
-headedPipe :: Monad m
- => Siphon c
- -> Colonnade Headed a c
- -> Pipe a c m x
-headedPipe siphon encoding = do
- yield (header siphon encoding)
- pipe siphon encoding
-
diff --git a/siphon/src/Siphon/Internal.hs b/siphon/src/Siphon/Internal.hs
deleted file mode 100644
index 3be524d..0000000
--- a/siphon/src/Siphon/Internal.hs
+++ /dev/null
@@ -1,214 +0,0 @@
-{-# LANGUAGE BangPatterns #-}
-
--- | A CSV parser. The parser defined here is RFC 4180 compliant, with
--- the following extensions:
---
--- * Empty lines are ignored.
---
--- * Non-escaped fields may contain any characters except
--- double-quotes, commas, carriage returns, and newlines.
---
--- * Escaped fields may contain any characters (but double-quotes
--- need to be escaped).
---
--- The functions in this module can be used to implement e.g. a
--- resumable parser that is fed input incrementally.
-module Siphon.Internal where
-
-import Siphon.Types
-
-import Data.ByteString.Builder (toLazyByteString,byteString)
-import qualified Data.ByteString.Char8 as BC8
-import Control.Applicative (optional)
-import Data.Attoparsec.ByteString.Char8 (char, endOfInput, string)
-import qualified Data.Attoparsec.ByteString as A
-import qualified Data.Attoparsec.Lazy as AL
-import qualified Data.Attoparsec.Zepto as Z
-import qualified Data.ByteString as S
-import qualified Data.ByteString.Unsafe as S
-import qualified Data.Vector as V
-import qualified Data.ByteString as B
-import qualified Data.ByteString.Lazy as LByteString
-import qualified Data.ByteString.Builder as Builder
-import qualified Data.Text as T
-import Data.Word (Word8)
-import Data.Vector (Vector)
-import Data.ByteString (ByteString)
-import Data.Coerce (coerce)
-import Siphon.Types
-
-import Control.Applicative
-import Data.Monoid
-
-byteStringChar8 :: Siphon ByteString
-byteStringChar8 = Siphon
- escape
- encodeRow
- (A.parse (row comma))
- B.null
-
-encodeRow :: Vector (Escaped ByteString) -> ByteString
-encodeRow = id
- . flip B.append (B.singleton newline)
- . B.intercalate (B.singleton comma)
- . V.toList
- . coerce
-
-escape :: ByteString -> Escaped ByteString
-escape t = case B.find (\c -> c == newline || c == cr || c == comma || c == doubleQuote) t of
- Nothing -> Escaped t
- Just _ -> escapeAlways t
-
--- | This implementation is definitely suboptimal.
--- A better option (which would waste a little space
--- but would be much faster) would be to build the
--- new bytestring by writing to a buffer directly.
-escapeAlways :: ByteString -> Escaped ByteString
-escapeAlways t = Escaped $ LByteString.toStrict $ Builder.toLazyByteString $
- Builder.word8 doubleQuote
- <> B.foldl
- (\ acc b -> acc <> if b == doubleQuote
- then Builder.byteString
- (B.pack [doubleQuote,doubleQuote])
- else Builder.word8 b)
- mempty
- t
- <> Builder.word8 doubleQuote
-
--- | Specialized version of 'sepBy1'' which is faster due to not
--- accepting an arbitrary separator.
-sepByDelim1' :: AL.Parser a
- -> Word8 -- ^ Field delimiter
- -> AL.Parser [a]
-sepByDelim1' p !delim = liftM2' (:) p loop
- where
- loop = do
- mb <- A.peekWord8
- case mb of
- Just b | b == delim -> liftM2' (:) (A.anyWord8 *> p) loop
- _ -> pure []
-{-# INLINE sepByDelim1' #-}
-
--- | Specialized version of 'sepBy1'' which is faster due to not
--- accepting an arbitrary separator.
-sepByEndOfLine1' :: AL.Parser a
- -> AL.Parser [a]
-sepByEndOfLine1' p = liftM2' (:) p loop
- where
- loop = do
- mb <- A.peekWord8
- case mb of
- Just b | b == cr ->
- liftM2' (:) (A.anyWord8 *> A.word8 newline *> p) loop
- | b == newline ->
- liftM2' (:) (A.anyWord8 *> p) loop
- _ -> pure []
-{-# INLINE sepByEndOfLine1' #-}
-
--- | Parse a record, not including the terminating line separator. The
--- terminating line separate is not included as the last record in a
--- CSV file is allowed to not have a terminating line separator. You
--- most likely want to use the 'endOfLine' parser in combination with
--- this parser.
-row :: Word8 -- ^ Field delimiter
- -> AL.Parser (Vector ByteString)
-row !delim = rowNoNewline delim <* endOfLine
-{-# INLINE row #-}
-
-rowNoNewline :: Word8 -- ^ Field delimiter
- -> AL.Parser (Vector ByteString)
-rowNoNewline !delim = V.fromList <$!> field delim `sepByDelim1'` delim
-{-# INLINE rowNoNewline #-}
-
-removeBlankLines :: [Vector ByteString] -> [Vector ByteString]
-removeBlankLines = filter (not . blankLine)
-
--- | Parse a field. The field may be in either the escaped or
--- non-escaped format. The return value is unescaped.
-field :: Word8 -> AL.Parser ByteString
-field !delim = do
- mb <- A.peekWord8
- -- We purposely don't use <|> as we want to commit to the first
- -- choice if we see a double quote.
- case mb of
- Just b | b == doubleQuote -> escapedField
- _ -> unescapedField delim
-{-# INLINE field #-}
-
-escapedField :: AL.Parser S.ByteString
-escapedField = do
- _ <- dquote
- -- The scan state is 'True' if the previous character was a double
- -- quote. We need to drop a trailing double quote left by scan.
- s <- S.init <$> (A.scan False $ \s c -> if c == doubleQuote
- then Just (not s)
- else if s then Nothing
- else Just False)
- if doubleQuote `S.elem` s
- then case Z.parse unescape s of
- Right r -> return r
- Left err -> fail err
- else return s
-
-unescapedField :: Word8 -> AL.Parser S.ByteString
-unescapedField !delim = A.takeWhile (\ c -> c /= doubleQuote &&
- c /= newline &&
- c /= delim &&
- c /= cr)
-
-dquote :: AL.Parser Char
-dquote = char '"'
-
--- | This could be improved. We could avoid the builder and just
--- write to a buffer directly.
-unescape :: Z.Parser S.ByteString
-unescape = (LByteString.toStrict . toLazyByteString) <$!> go mempty where
- go acc = do
- h <- Z.takeWhile (/= doubleQuote)
- let rest = do
- start <- Z.take 2
- if (S.unsafeHead start == doubleQuote &&
- S.unsafeIndex start 1 == doubleQuote)
- then go (acc `mappend` byteString h `mappend` byteString (BC8.singleton '"'))
- else fail "invalid CSV escape sequence"
- done <- Z.atEnd
- if done
- then return (acc `mappend` byteString h)
- else rest
-
--- | A strict version of 'Data.Functor.<$>' for monads.
-(<$!>) :: Monad m => (a -> b) -> m a -> m b
-f <$!> m = do
- a <- m
- return $! f a
-{-# INLINE (<$!>) #-}
-
-infixl 4 <$!>
-
--- | Is this an empty record (i.e. a blank line)?
-blankLine :: V.Vector B.ByteString -> Bool
-blankLine v = V.length v == 1 && (B.null (V.head v))
-
--- | A version of 'liftM2' that is strict in the result of its first
--- action.
-liftM2' :: (Monad m) => (a -> b -> c) -> m a -> m b -> m c
-liftM2' f a b = do
- !x <- a
- y <- b
- return (f x y)
-{-# INLINE liftM2' #-}
-
-
--- | Match either a single newline character @\'\\n\'@, or a carriage
--- return followed by a newline character @\"\\r\\n\"@, or a single
--- carriage return @\'\\r\'@.
-endOfLine :: A.Parser ()
-endOfLine = (A.word8 newline *> return ()) <|> (string (BC8.pack "\r\n") *> return ()) <|> (A.word8 cr *> return ())
-{-# INLINE endOfLine #-}
-
-doubleQuote, newline, cr, comma :: Word8
-doubleQuote = 34
-newline = 10
-cr = 13
-comma = 44
-
diff --git a/siphon/src/Siphon/Internal/Text.hs b/siphon/src/Siphon/Internal/Text.hs
deleted file mode 100644
index 4d63431..0000000
--- a/siphon/src/Siphon/Internal/Text.hs
+++ /dev/null
@@ -1,189 +0,0 @@
-{-# LANGUAGE BangPatterns #-}
-
-module Siphon.Internal.Text where
-
-import Siphon.Types
-
-import Control.Applicative (optional)
-import Data.Attoparsec.Text (char, endOfInput, string)
-import qualified Data.Attoparsec.Text as A
-import qualified Data.Attoparsec.Text.Lazy as AL
-import qualified Data.Attoparsec.Zepto as Z
-import qualified Data.Text as T
-import qualified Data.Text as Text
-import qualified Data.Vector as V
-import qualified Data.Text.Lazy as LText
-import qualified Data.Text.Lazy.Builder as Builder
-import Data.Text.Lazy.Builder (Builder)
-import Data.Word (Word8)
-import Data.Vector (Vector)
-import Data.Text (Text)
-import Data.Coerce (coerce)
-import Siphon.Types
-
-import Control.Applicative
-import Data.Monoid
-
-text :: Siphon Text
-text = Siphon
- escape
- encodeRow
- (A.parse (row comma))
- Text.null
-
-encodeRow :: Vector (Escaped Text) -> Text
-encodeRow = id
- . flip Text.append (Text.singleton newline)
- . Text.intercalate (Text.singleton comma)
- . V.toList
- . coerce
-
-escape :: Text -> Escaped Text
-escape t = case Text.find (\c -> c == newline || c == cr || c == comma || c == doubleQuote) t of
- Nothing -> Escaped t
- Just _ -> escapeAlways t
-
--- | This implementation is definitely suboptimal.
--- A better option (which would waste a little space
--- but would be much faster) would be to build the
--- new text by writing to a buffer directly.
-escapeAlways :: Text -> Escaped Text
-escapeAlways t = Escaped $ Text.concat
- [ textDoubleQuote
- , Text.replace textDoubleQuote (Text.pack [doubleQuote,doubleQuote]) t
- , textDoubleQuote
- ]
-
--- | Specialized version of 'sepBy1'' which is faster due to not
--- accepting an arbitrary separator.
-sepByDelim1' :: A.Parser a
- -> Char -- ^ Field delimiter
- -> A.Parser [a]
-sepByDelim1' p !delim = liftM2' (:) p loop
- where
- loop = do
- mb <- A.peekChar
- case mb of
- Just b | b == delim -> liftM2' (:) (A.anyChar *> p) loop
- _ -> pure []
-{-# INLINE sepByDelim1' #-}
-
--- | Specialized version of 'sepBy1'' which is faster due to not
--- accepting an arbitrary separator.
-sepByEndOfLine1' :: A.Parser a
- -> A.Parser [a]
-sepByEndOfLine1' p = liftM2' (:) p loop
- where
- loop = do
- mb <- A.peekChar
- case mb of
- Just b | b == cr ->
- liftM2' (:) (A.anyChar *> A.char newline *> p) loop
- | b == newline ->
- liftM2' (:) (A.anyChar *> p) loop
- _ -> pure []
-{-# INLINE sepByEndOfLine1' #-}
-
--- | Parse a record, not including the terminating line separator. The
--- terminating line separate is not included as the last record in a
--- CSV file is allowed to not have a terminating line separator. You
--- most likely want to use the 'endOfLine' parser in combination with
--- this parser.
-row :: Char -- ^ Field delimiter
- -> A.Parser (Vector Text)
-row !delim = rowNoNewline delim <* endOfLine
-{-# INLINE row #-}
-
-rowNoNewline :: Char -- ^ Field delimiter
- -> A.Parser (Vector Text)
-rowNoNewline !delim = V.fromList <$!> field delim `sepByDelim1'` delim
-{-# INLINE rowNoNewline #-}
-
--- | Parse a field. The field may be in either the escaped or
--- non-escaped format. The return value is unescaped.
-field :: Char -> A.Parser Text
-field !delim = do
- mb <- A.peekChar
- -- We purposely don't use <|> as we want to commit to the first
- -- choice if we see a double quote.
- case mb of
- Just b | b == doubleQuote -> escapedField
- _ -> unescapedField delim
-{-# INLINE field #-}
-
-escapedField :: A.Parser Text
-escapedField = do
- _ <- dquote -- This can probably be replaced with anyChar
- b <- escapedFieldInner mempty
- return (LText.toStrict (Builder.toLazyText b))
-
-escapedFieldInner :: Builder -> A.Parser Builder
-escapedFieldInner b = do
- t <- A.takeTill (== doubleQuote)
- _ <- A.anyChar -- this will always be a double quote
- c <- A.peekChar'
- if c == doubleQuote
- then do
- _ <- A.anyChar -- this will always be a double quote
- escapedFieldInner (b `mappend` Builder.fromText t `mappend` Builder.fromText textDoubleQuote)
- else return (b `mappend` Builder.fromText t)
-
-unescapedField :: Char -> A.Parser Text
-unescapedField !delim = A.takeWhile (\ c -> c /= doubleQuote &&
- c /= newline &&
- c /= delim &&
- c /= cr)
-
-dquote :: A.Parser Char
-dquote = char doubleQuote
-
-unescape :: A.Parser Text
-unescape = (LText.toStrict . Builder.toLazyText) <$!> go mempty where
- go acc = do
- h <- A.takeWhile (/= doubleQuote)
- let rest = do
- c0 <- A.anyChar
- c1 <- A.anyChar
- if (c0 == doubleQuote && c1 == doubleQuote)
- then go (acc `mappend` Builder.fromText h `mappend` Builder.fromText textDoubleQuote)
- else fail "invalid CSV escape sequence"
- done <- A.atEnd
- if done
- then return (acc `mappend` Builder.fromText h)
- else rest
-
--- | A strict version of 'Data.Functor.<$>' for monads.
-(<$!>) :: Monad m => (a -> b) -> m a -> m b
-f <$!> m = do
- a <- m
- return $! f a
-{-# INLINE (<$!>) #-}
-
-infixl 4 <$!>
-
--- | 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.char newline *> return ()) <|> (string (Text.pack "\r\n") *> return ()) <|> (A.char cr *> return ())
-{-# INLINE endOfLine #-}
-
-textDoubleQuote :: Text
-textDoubleQuote = Text.singleton doubleQuote
-
-doubleQuote, newline, cr, comma :: Char
-doubleQuote = '\"'
-newline = '\n'
-cr = '\r'
-comma = ','
-
diff --git a/siphon/src/Siphon/Text.hs b/siphon/src/Siphon/Text.hs
deleted file mode 100644
index 21bcb3e..0000000
--- a/siphon/src/Siphon/Text.hs
+++ /dev/null
@@ -1,33 +0,0 @@
-module Siphon.Text where
-
-import Siphon.Types
-import Data.Text (Text)
-import Data.Vector (Vector)
-import Data.Coerce (coerce)
-import qualified Data.Text as Text
-import qualified Data.Vector as Vector
-
-siphon :: Siphon Text
-siphon = Siphon escape encodeRow
- (error "siphon: uhoent") (error "siphon: uheokj")
-
-encodeRow :: Vector (Escaped Text) -> Text
-encodeRow = id
- . Text.intercalate (Text.singleton ',')
- . Vector.toList
- . coerce
-
-escape :: Text -> Escaped Text
-escape t = case Text.find (\c -> c == '\n' || c == ',' || c == '"') t of
- Nothing -> Escaped t
- Just _ -> escapeAlways t
-
-escapeAlways :: Text -> Escaped Text
-escapeAlways t = Escaped $ Text.concat
- [ Text.singleton '"'
- , Text.replace (Text.pack "\"") (Text.pack "\"\"") t
- , Text.singleton '"'
- ]
-
-
-
diff --git a/siphon/src/Siphon/Types.hs b/siphon/src/Siphon/Types.hs
deleted file mode 100644
index 2f04376..0000000
--- a/siphon/src/Siphon/Types.hs
+++ /dev/null
@@ -1,84 +0,0 @@
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-
-{-# OPTIONS_GHC -Wall -Werror #-}
-
-module Siphon.Types
- ( Siphon(..)
- , Indexed(..)
- , SiphonError(..)
- , RowError(..)
- , CellError(..)
- ) where
-
-import Data.Vector (Vector)
-import Control.Exception (Exception)
-import Data.Text (Text)
-import Data.Functor.Classes (Eq1,Show1,liftEq,liftShowsPrec)
-
-data CellError = CellError
- { cellErrorColumn :: !Int
- , cellErrorContent :: !Text
- } deriving (Show,Read,Eq)
-
-newtype Indexed a = Indexed
- { indexedIndex :: Int
- } deriving (Eq,Ord,Functor,Show,Read)
-
-instance Show1 Indexed where
- liftShowsPrec _ _ p (Indexed i) s = showsPrec p i s
-
-instance Eq1 Indexed where
- liftEq _ (Indexed i) (Indexed j) = i == j
-
-data SiphonError = SiphonError
- { siphonErrorRow :: !Int
- , siphonErrorCause :: !RowError
- } deriving (Show,Read,Eq)
-
-instance Exception SiphonError
-
-data RowError
- = RowErrorParse
- -- ^ Error occurred parsing the document into cells
- | RowErrorDecode !(Vector CellError)
- -- ^ Error decoding the content
- | RowErrorSize !Int !Int
- -- ^ Wrong number of cells in the row
- | RowErrorHeaders !(Vector (Vector CellError)) !(Vector Text) !(Vector Int)
- -- ^ Three parts:
- -- (a) Multiple header cells matched the same expected cell,
- -- (b) Headers that were missing,
- -- (c) Missing headers that were lambdas. They cannot be
- -- shown so instead their positions in the 'Siphon' are given.
- | RowErrorHeaderSize !Int !Int
- -- ^ Not enough cells in header, expected, actual
- | RowErrorMalformed !Int
- -- ^ Error decoding unicode content, column number
- deriving (Show,Read,Eq)
-
--- | This just actually a specialization of the free applicative.
--- Check out @Control.Applicative.Free@ in the @free@ library to
--- learn more about this. The meanings of the fields are documented
--- slightly more in the source code. Unfortunately, haddock does not
--- play nicely with GADTs.
-data Siphon f c a where
- SiphonPure ::
- !a -- function
- -> Siphon f c a
- SiphonAp ::
- !(f c) -- header
- -> !(c -> Maybe a) -- decoding function
- -> !(Siphon f c (a -> b)) -- next decoding
- -> Siphon f c b
-
-instance Functor (Siphon f c) where
- fmap f (SiphonPure a) = SiphonPure (f a)
- fmap f (SiphonAp h c apNext) = SiphonAp h c ((f .) <$> apNext)
-
-instance Applicative (Siphon f c) where
- pure = SiphonPure
- SiphonPure f <*> y = fmap f y
- SiphonAp h c y <*> z = SiphonAp h c (flip <$> y <*> z)
-
diff --git a/siphon/test/Test.hs b/siphon/test/Test.hs
deleted file mode 100644
index 5886d7b..0000000
--- a/siphon/test/Test.hs
+++ /dev/null
@@ -1,388 +0,0 @@
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE DeriveGeneric #-}
-
-module Main (main) where
-
-import Colonnade (headed,headless,Colonnade,Headed,Headless)
-import Control.Exception
-import Data.ByteString (ByteString)
-import Data.Char (ord)
-import Data.Either.Combinators
-import Data.Functor.Contravariant (contramap)
-import Data.Functor.Contravariant.Divisible (divided,conquered)
-import Data.Functor.Identity
-import Data.Profunctor (lmap)
-import Data.Text (Text)
-import Data.Word (Word8)
-import Debug.Trace
-import GHC.Generics (Generic)
-import Siphon.Types
-import Streaming (Stream,Of(..))
-import Test.Framework (defaultMain, testGroup, Test)
-import Test.Framework.Providers.HUnit (testCase)
-import Test.Framework.Providers.QuickCheck2 (testProperty)
-import Test.HUnit (Assertion,(@?=))
-import Test.QuickCheck (Gen, Arbitrary(..), choose, elements, Property)
-import Test.QuickCheck.Property (Result, succeeded, exception)
-
-import qualified Data.Text as Text
-import qualified Data.ByteString.Builder as Builder
-import qualified Data.ByteString.Lazy as LByteString
-import qualified Data.ByteString as ByteString
-import qualified Data.ByteString.Char8 as BC8
-import qualified Data.ByteString as B
-import qualified Data.Vector as Vector
-import qualified Colonnade as Colonnade
-import qualified Siphon as S
-import qualified Streaming.Prelude as SMP
-import qualified Data.Text.Lazy as LText
-import qualified Data.Text.Lazy.Builder as TBuilder
-import qualified Data.Text.Lazy.Builder.Int as TBuilder
-
-main :: IO ()
-main = defaultMain tests
-
-tests :: [Test]
-tests =
- [ testGroup "ByteString encode/decode"
- [ testCase "Headed Encoding (int,char,bool)"
- $ runTestScenario [(4,intToWord8 (ord 'c'),False)]
- S.encodeCsvStreamUtf8
- encodingB
- $ ByteString.concat
- [ "number,letter,boolean\n"
- , "4,c,false\n"
- ]
- , testCase "Headed Encoding (int,char,bool) monoidal building"
- $ runTestScenario [(4,'c',False)]
- S.encodeCsvStreamUtf8
- encodingC
- $ ByteString.concat
- [ "boolean,letter\n"
- , "false,c\n"
- ]
- , testCase "Headed Encoding (escaped characters)"
- $ runTestScenario ["bob","there,be,commas","the \" quote"]
- S.encodeCsvStreamUtf8
- encodingF
- $ ByteString.concat
- [ "name\n"
- , "bob\n"
- , "\"there,be,commas\"\n"
- , "\"the \"\" quote\"\n"
- ]
- , testCase "Headed Decoding (int,char,bool)"
- $ ( runIdentity . SMP.toList )
- ( S.decodeCsvUtf8 decodingB
- ( mapM_ (SMP.yield . BC8.singleton) $ concat
- [ "number,letter,boolean\n"
- , "244,z,true\n"
- ]
- )
- ) @?= ([(244,intToWord8 (ord 'z'),True)] :> Nothing)
- , testCase "Headed Decoding (geolite)"
- $ ( runIdentity . SMP.toList )
- ( S.decodeCsvUtf8 decodingGeolite
- ( SMP.yield $ BC8.pack $ concat
- [ "network,autonomous_system_number,autonomous_system_organization\n"
- , "1,z,y\n"
- ]
- )
- ) @?= ([(1,intToWord8 (ord 'z'),intToWord8 (ord 'y'))] :> Nothing)
- , testCase "Headed Decoding (escaped characters, one big chunk)"
- $ ( runIdentity . SMP.toList )
- ( S.decodeCsvUtf8 decodingF
- ( SMP.yield $ BC8.pack $ concat
- [ "name\n"
- , "drew\n"
- , "\"martin, drew\"\n"
- ]
- )
- ) @?= (["drew","martin, drew"] :> Nothing)
- , testCase "Headed Decoding (escaped characters, character per chunk)"
- $ ( runIdentity . SMP.toList )
- ( S.decodeCsvUtf8 decodingF
- ( mapM_ (SMP.yield . BC8.singleton) $ concat
- [ "name\n"
- , "drew\n"
- , "\"martin, drew\"\n"
- ]
- )
- ) @?= (["drew","martin, drew"] :> Nothing)
- , testCase "Headed Decoding (escaped characters, character per chunk, CRLF)"
- $ ( runIdentity . SMP.toList )
- ( S.decodeCsvUtf8 decodingF
- ( mapM_ (SMP.yield . BC8.singleton) $ concat
- [ "name\r\n"
- , "drew\r\n"
- , "\"martin, drew\"\r\n"
- ]
- )
- ) @?= (["drew","martin, drew"] :> Nothing)
- , testCase "headedToIndexed" $
- let actual = S.headedToIndexed id (Vector.fromList ["letter","boolean","number"]) decodingG
- in case actual of
- Left e -> fail "headedToIndexed failed"
- Right actualInner ->
- let expected = SiphonAp (Indexed 2 :: Indexed Text) (\_ -> Nothing)
- $ SiphonAp (Indexed 0 :: Indexed Text) (\_ -> Nothing)
- $ SiphonAp (Indexed 1 :: Indexed Text) (\_ -> Nothing)
- $ SiphonPure (\_ _ _ -> ())
- in case S.eqSiphonHeaders actualInner expected of
- True -> pure ()
- False -> fail $
- "Expected " ++
- S.showSiphonHeaders expected ++
- " but got " ++
- S.showSiphonHeaders actualInner
- , testCase "Indexed Decoding (int,char,bool)"
- $ ( runIdentity . SMP.toList )
- ( S.decodeIndexedCsvUtf8 3 indexedDecodingB
- ( mapM_ (SMP.yield . BC8.singleton) $ concat
- [ "244,z,true\n"
- ]
- )
- ) @?= ([(244,intToWord8 (ord 'z'),True)] :> Nothing)
- , testProperty "Headed Isomorphism (int,char,bool)"
- $ propIsoStream BC8.unpack
- (S.decodeCsvUtf8 decodingB)
- (S.encodeCsvStreamUtf8 encodingB)
- ]
- ]
-
-intToWord8 :: Int -> Word8
-intToWord8 = fromIntegral
-
-data Foo = FooA | FooB | FooC
- deriving (Generic,Eq,Ord,Show,Read,Bounded,Enum)
-
-instance Arbitrary Foo where
- arbitrary = elements [minBound..maxBound]
-
-fooToString :: Foo -> String
-fooToString x = case x of
- FooA -> "Simple"
- FooB -> "With,Escaped\nChars"
- FooC -> "More\"Escaped,\"\"Chars"
-
-encodeFoo :: (String -> c) -> Foo -> c
-encodeFoo f = f . fooToString
-
-fooFromString :: String -> Maybe Foo
-fooFromString x = case x of
- "Simple" -> Just FooA
- "With,Escaped\nChars" -> Just FooB
- "More\"Escaped,\"\"Chars" -> Just FooC
- _ -> Nothing
-
-decodeFoo :: (c -> String) -> c -> Maybe Foo
-decodeFoo f = fooFromString . f
-
-decodingA :: Siphon Headless ByteString (Int,Char,Bool)
-decodingA = (,,)
- <$> S.headless dbInt
- <*> S.headless dbChar
- <*> S.headless dbBool
-
-decodingB :: Siphon Headed ByteString (Int,Word8,Bool)
-decodingB = (,,)
- <$> S.headed "number" dbInt
- <*> S.headed "letter" dbWord8
- <*> S.headed "boolean" dbBool
-
-indexedDecodingB :: Siphon Indexed ByteString (Int,Word8,Bool)
-indexedDecodingB = (,,)
- <$> S.indexed 0 dbInt
- <*> S.indexed 1 dbWord8
- <*> S.indexed 2 dbBool
-
-decodingG :: Siphon Headed Text ()
-decodingG =
- S.headed "number" (\_ -> Nothing)
- <* S.headed "letter" (\_ -> Nothing)
- <* S.headed "boolean" (\_ -> Nothing)
-
-decodingF :: Siphon Headed ByteString ByteString
-decodingF = S.headed "name" Just
-
-decodingGeolite :: Siphon Headed ByteString (Int,Word8,Word8)
-decodingGeolite = (,,)
- <$> S.headed "network" dbInt
- <*> S.headed "autonomous_system_number" dbWord8
- <*> S.headed "autonomous_system_organization" dbWord8
-
-
-encodingA :: Colonnade Headless (Int,Char,Bool) ByteString
-encodingA = mconcat
- [ lmap fst3 (headless ebInt)
- , lmap snd3 (headless ebChar)
- , lmap thd3 (headless ebBool)
- ]
-
-encodingW :: Colonnade Headless (Int,Char,Bool) Text
-encodingW = mconcat
- [ lmap fst3 (headless etInt)
- , lmap snd3 (headless etChar)
- , lmap thd3 (headless etBool)
- ]
-
-encodingY :: Colonnade Headless (Foo,Foo,Foo) Text
-encodingY = mconcat
- [ lmap fst3 (headless $ encodeFoo Text.pack)
- , lmap snd3 (headless $ encodeFoo Text.pack)
- , lmap thd3 (headless $ encodeFoo Text.pack)
- ]
-
-decodingY :: Siphon Headless Text (Foo,Foo,Foo)
-decodingY = (,,)
- <$> S.headless (decodeFoo Text.unpack)
- <*> S.headless (decodeFoo Text.unpack)
- <*> S.headless (decodeFoo Text.unpack)
-
-encodingF :: Colonnade Headed ByteString ByteString
-encodingF = headed "name" id
-
-encodingB :: Colonnade Headed (Int,Word8,Bool) ByteString
-encodingB = mconcat
- [ lmap fst3 (headed "number" ebInt)
- , lmap snd3 (headed "letter" ebWord8)
- , lmap thd3 (headed "boolean" ebBool)
- ]
-
-encodingC :: Colonnade Headed (Int,Char,Bool) ByteString
-encodingC = mconcat
- [ lmap thd3 $ headed "boolean" ebBool
- , lmap snd3 $ headed "letter" ebChar
- ]
-
-tripleToPairs :: (a,b,c) -> (a,(b,(c,())))
-tripleToPairs (a,b,c) = (a,(b,(c,())))
-
-propIsoStream :: (Eq a, Show a, Monoid c)
- => (c -> String)
- -> (Stream (Of c) Identity () -> Stream (Of a) Identity (Maybe SiphonError))
- -> (Stream (Of a) Identity () -> Stream (Of c) Identity ())
- -> [a]
- -> Result
-propIsoStream toStr decode encode as =
- let asNew :> m = runIdentity $ SMP.toList $ decode $ encode $ SMP.each as
- in case m of
- Nothing -> if as == asNew
- then succeeded
- else exception ("expected " ++ show as ++ " but got " ++ show asNew) myException
- Just err ->
- let csv = toStr $ mconcat $ runIdentity $ SMP.toList_ $ encode $ SMP.each as
- in exception (S.humanizeSiphonError err ++ "\nGenerated CSV\n" ++ csv) myException
-
-data MyException = MyException
- deriving (Show,Read,Eq)
-instance Exception MyException
-
-myException :: SomeException
-myException = SomeException MyException
-
-runTestScenario :: (Monoid c, Eq c, Show c, Eq a, Show a)
- => [a]
- -> (Colonnade f a c -> Stream (Of a) Identity () -> Stream (Of c) Identity ())
- -> Colonnade f a c
- -> c
- -> Assertion
-runTestScenario as p e c =
- ( mconcat (runIdentity (SMP.toList_ (p e (mapM_ SMP.yield as))))
- ) @?= c
-
--- runCustomTestScenario :: (Monoid c, Eq c, Show c)
--- => Siphon c
--- -> (Siphon c -> Colonnade f a c -> Pipe a c Identity ())
--- -> Colonnade f a c
--- -> a
--- -> c
--- -> Assertion
--- runCustomTestScenario s p e a c =
--- ( mconcat $ Pipes.toList $
--- Pipes.yield a >-> p s e
--- ) @?= c
-
--- testEncodingA :: Assertion
--- testEncodingA = runTestScenario encodingA "4,c,false\n"
-
-propEncodeDecodeIso :: Eq a => (a -> b) -> (b -> Maybe a) -> a -> Bool
-propEncodeDecodeIso f g a = g (f a) == Just a
-
-propMatching :: Eq b => (a -> b) -> (a -> b) -> a -> Bool
-propMatching f g a = f a == g a
-
-
--- | Take the first item out of a 3 element tuple
-fst3 :: (a,b,c) -> a
-fst3 (a,b,c) = a
-
--- | Take the second item out of a 3 element tuple
-snd3 :: (a,b,c) -> b
-snd3 (a,b,c) = b
-
--- | Take the third item out of a 3 element tuple
-thd3 :: (a,b,c) -> c
-thd3 (a,b,c) = c
-
-
-dbChar :: ByteString -> Maybe Char
-dbChar b = case BC8.length b of
- 1 -> Just (BC8.head b)
- _ -> Nothing
-
-dbWord8 :: ByteString -> Maybe Word8
-dbWord8 b = case B.length b of
- 1 -> Just (B.head b)
- _ -> Nothing
-
-dbInt :: ByteString -> Maybe Int
-dbInt b = do
- (a,bsRem) <- BC8.readInt b
- if ByteString.null bsRem
- then Just a
- else Nothing
-
-dbBool :: ByteString -> Maybe Bool
-dbBool b
- | b == BC8.pack "true" = Just True
- | b == BC8.pack "false" = Just False
- | otherwise = Nothing
-
-ebChar :: Char -> ByteString
-ebChar = BC8.singleton
-
-ebWord8 :: Word8 -> ByteString
-ebWord8 = B.singleton
-
-ebInt :: Int -> ByteString
-ebInt = LByteString.toStrict
- . Builder.toLazyByteString
- . Builder.intDec
-
-ebBool :: Bool -> ByteString
-ebBool x = case x of
- True -> BC8.pack "true"
- False -> BC8.pack "false"
-
-ebByteString :: ByteString -> ByteString
-ebByteString = id
-
-
-etChar :: Char -> Text
-etChar = Text.singleton
-
-etInt :: Int -> Text
-etInt = LText.toStrict
- . TBuilder.toLazyText
- . TBuilder.decimal
-
-etText :: Text -> Text
-etText = id
-
-etBool :: Bool -> Text
-etBool x = case x of
- True -> Text.pack "true"
- False -> Text.pack "false"
-
diff --git a/src/Lucid/Colonnade.hs b/src/Lucid/Colonnade.hs
new file mode 100644
index 0000000..e2c6ba3
--- /dev/null
+++ b/src/Lucid/Colonnade.hs
@@ -0,0 +1,352 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+
+{- | 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 (..)
+ , charCell
+ , htmlCell
+ , stringCell
+ , textCell
+ , lazyTextCell
+ , builderCell
+ , htmlFromCell
+ , encodeBodySized
+ , sectioned
+
+ -- * Discussion
+ -- $discussion
+ ) where
+
+#if MIN_VERSION_base(4,18,0)
+#else
+import Control.Applicative (liftA2)
+#endif
+import Colonnade (Colonnade)
+import Control.Monad
+import Data.Foldable
+import Data.String (IsString (..))
+import Data.Text (Text)
+import Lucid hiding (for_)
+
+import qualified Colonnade.Encode as E
+import qualified Data.Text as T
+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
+
+{- $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 @\@ or @\ | @ elements
+that wrap this HTML content.
+-}
+
+{- | The attributes that will be applied to a @\ | @ 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 = (<>)
+
+-- | 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) =>
+ -- | Attributes of @\@ element
+ [Attribute] ->
+ -- | How to encode data as columns
+ Colonnade h a (Html d) ->
+ -- | Collection of data
+ f a ->
+ 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) =>
+ -- | Attributes of @\@ element
+ [Attribute] ->
+ -- | How to encode data as columns
+ Colonnade h a (Cell d) ->
+ -- | Collection of data
+ f a ->
+ Html d
+encodeCellTable =
+ encodeTable
+ (E.headednessPure ([], []))
+ mempty
+ (const mempty)
+ htmlFromCell
+
+encodeCellTableSized ::
+ (E.Headedness h, Foldable f, Monoid d) =>
+ -- | Attributes of @\@ element
+ [Attribute] ->
+ -- | How to encode data as columns
+ Colonnade (E.Sized Int h) a (Cell d) ->
+ -- | Collection of data
+ f a ->
+ 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 @\@ 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) =>
+ -- | Attributes of @\@ and its @\@
+ h ([Attribute], [Attribute]) ->
+ -- | Attributes of @\ @ element
+ [Attribute] ->
+ -- | Attributes of each @\@ element
+ (a -> [Attribute]) ->
+ -- | Wrap content and convert to 'Html'
+ (([Attribute] -> Html d -> Html d) -> c -> Html d) ->
+ -- | Attributes of @\@ element
+ [Attribute] ->
+ -- | How to encode data as a row
+ Colonnade h a c ->
+ -- | Collection of data
+ f a ->
+ 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) =>
+ -- | Attributes of each @\@ element
+ (a -> [Attribute]) ->
+ -- | Wrap content and convert to 'Html'
+ (([Attribute] -> Html d -> Html d) -> c -> Html d) ->
+ -- | Attributes of @\ @ element
+ [Attribute] ->
+ -- | How to encode data as a row
+ Colonnade h a c ->
+ -- | Collection of data
+ f a ->
+ 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.
+ (Foldable f, E.Headedness h, Monoid d) =>
+ -- | Attributes of @\@ and its @\@
+ h ([Attribute], [Attribute]) ->
+ -- | Attributes of @\ @ element
+ [Attribute] ->
+ -- | Attributes of each @\@ element
+ (a -> [Attribute]) ->
+ -- | Wrap content and convert to 'Html'
+ (([Attribute] -> Html d -> Html d) -> (Cell d) -> Html d) ->
+ -- | Attributes of @\@ element
+ [Attribute] ->
+ -- | How to encode data as a row
+ Colonnade (E.Sized Int h) a (Cell d) ->
+ -- | Collection of data
+ f a ->
+ Html ()
+encodeTableSized mtheadAttrs tbodyAttrs trAttrs wrapContent tableAttrs colonnade xs =
+ table_ tableAttrs $ do
+ _ <- 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 @\@ and the row
+content the child of a @\ | @. 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) =>
+ -- | @\@ tag attributes
+ [Attribute] ->
+ -- | Attributes of @\@ and its @\@, pass 'Nothing' to omit @\@
+ Maybe ([Attribute], [Attribute]) ->
+ -- | @\ @ tag attributes
+ [Attribute] ->
+ -- | @\@ tag attributes for data rows
+ (a -> [Attribute]) ->
+ -- | Section divider encoding strategy
+ (b -> Cell c) ->
+ -- | Data encoding strategy
+ Colonnade h a (Cell c) ->
+ -- | Collection of data
+ f (b, g a) ->
+ 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
diff --git a/yesod-colonnade/LICENSE b/yesod-colonnade/LICENSE
deleted file mode 100644
index 9beb3f9..0000000
--- a/yesod-colonnade/LICENSE
+++ /dev/null
@@ -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.
\ No newline at end of file
diff --git a/yesod-colonnade/Setup.hs b/yesod-colonnade/Setup.hs
deleted file mode 100644
index 9a994af..0000000
--- a/yesod-colonnade/Setup.hs
+++ /dev/null
@@ -1,2 +0,0 @@
-import Distribution.Simple
-main = defaultMain
diff --git a/yesod-colonnade/hackage-docs.sh b/yesod-colonnade/hackage-docs.sh
deleted file mode 100755
index 0ddbc20..0000000
--- a/yesod-colonnade/hackage-docs.sh
+++ /dev/null
@@ -1,48 +0,0 @@
-#!/bin/bash
-set -e
-
-if [ "$#" -ne 1 ]; then
- echo "Usage: scripts/hackage-docs.sh HACKAGE_USER"
- exit 1
-fi
-
-user=$1
-
-cabal_file=$(find . -maxdepth 1 -name "*.cabal" -print -quit)
-if [ ! -f "$cabal_file" ]; then
- echo "Run this script in the top-level package directory"
- exit 1
-fi
-
-pkg=$(awk -F ":[[:space:]]*" 'tolower($1)=="name" { print $2 }' < "$cabal_file")
-ver=$(awk -F ":[[:space:]]*" 'tolower($1)=="version" { print $2 }' < "$cabal_file")
-
-if [ -z "$pkg" ]; then
- echo "Unable to determine package name"
- exit 1
-fi
-
-if [ -z "$ver" ]; then
- echo "Unable to determine package version"
- exit 1
-fi
-
-echo "Detected package: $pkg-$ver"
-
-dir=$(mktemp -d build-docs.XXXXXX)
-trap 'rm -r "$dir"' EXIT
-
-# cabal haddock --hoogle --hyperlink-source --html-location='/package/$pkg-$version/docs' --contents-location='/package/$pkg-$version'
-stack haddock
-
-cp -R .stack-work/dist/x86_64-linux/Cabal-1.22.5.0/doc/html/$pkg/ $dir/$pkg-$ver-docs
-# /home/andrew/.stack/snapshots/x86_64-linux/lts-5.17/7.10.3/doc/index.html
-
-tar cvz -C $dir --format=ustar -f $dir/$pkg-$ver-docs.tar.gz $pkg-$ver-docs
-
-curl -X PUT \
- -H 'Content-Type: application/x-tar' \
- -H 'Content-Encoding: gzip' \
- -u "$user" \
- --data-binary "@$dir/$pkg-$ver-docs.tar.gz" \
- "https://hackage.haskell.org/package/$pkg-$ver/docs"
diff --git a/yesod-colonnade/src/Yesod/Colonnade.hs b/yesod-colonnade/src/Yesod/Colonnade.hs
deleted file mode 100644
index 5fb0a35..0000000
--- a/yesod-colonnade/src/Yesod/Colonnade.hs
+++ /dev/null
@@ -1,183 +0,0 @@
--- | Build HTML tables using @yesod@ and @colonnade@. To learn
--- how to use this module, first read the documentation for @colonnade@,
--- and then read the documentation for @blaze-colonnade@. This library
--- and @blaze-colonnade@ are entirely distinct; neither depends on the
--- other. However, the interfaces they expose are very similar, and
--- the explanations provided counterpart are sufficient to understand
--- this library.
-module Yesod.Colonnade
- ( -- * Build
- Cell(..)
- , cell
- , stringCell
- , textCell
- , builderCell
- , anchorCell
- , anchorWidget
- -- * Apply
- , encodeWidgetTable
- , encodeCellTable
- , encodeDefinitionTable
- , encodeListItems
- ) where
-
-import Yesod.Core
-import Yesod.Core.Types (Body(..),GWData(..),WidgetFor(..),wdRef)
-import Colonnade (Colonnade,Headed,Headless)
-import Data.Text (Text)
-import Control.Monad
-import Data.IORef (modifyIORef')
-import Data.Monoid
-import Data.String (IsString(..))
-import Text.Blaze (Attribute,toValue)
-import Data.Foldable
-import Yesod.Elements (table_,thead_,tbody_,tr_,td_,th_,ul_,li_,a_)
-import Data.Semigroup (Semigroup)
-import qualified Data.Semigroup as SG
-import qualified Text.Blaze.Html5.Attributes as HA
-import qualified Text.Blaze.Html5 as H
-import qualified Colonnade.Encode as E
-import qualified Data.Text as Text
-import qualified Data.Text.Lazy as LText
-import qualified Data.Text.Lazy.Builder as TBuilder
-
--- | The attributes that will be applied to a @@ and
--- the HTML content that will go inside it.
-data Cell site = Cell
- { cellAttrs :: [Attribute]
- , cellContents :: !(WidgetFor site ())
- }
-
-instance IsString (Cell site) where
- fromString = stringCell
-
-instance Semigroup (Cell site) where
- Cell a1 c1 <> Cell a2 c2 = Cell (mappend a1 a2) (mappend c1 c2)
-instance Monoid (Cell site) where
- mempty = Cell mempty mempty
- mappend = (SG.<>)
-
--- | Create a 'Cell' from a 'Widget'
-cell :: WidgetFor site () -> Cell site
-cell = Cell mempty
-
--- | Create a 'Cell' from a 'String'
-stringCell :: String -> Cell site
-stringCell = cell . fromString
-
--- | Create a 'Cell' from a 'Text'
-textCell :: Text -> Cell site
-textCell = cell . toWidget . toHtml
-
--- | Create a 'Cell' from a text builder
-builderCell :: TBuilder.Builder -> Cell site
-builderCell = cell . toWidget . toHtml . LText.toStrict . TBuilder.toLazyText
-
--- | Create a 'Cell' whose content is hyperlinked by wrapping
--- it in an @\@.
-anchorCell ::
- (a -> Route site) -- ^ Route that will go in @href@ attribute
- -> (a -> WidgetFor site ()) -- ^ Content wrapped by @@ tag
- -> a -- ^ Value
- -> Cell site
-anchorCell getRoute getContent = cell . anchorWidget getRoute getContent
-
--- | Create a widget whose content is hyperlinked by wrapping
--- it in an @\@.
-anchorWidget ::
- (a -> Route site) -- ^ Route that will go in @href@ attribute
- -> (a -> WidgetFor site ()) -- ^ Content wrapped by @@ tag
- -> a -- ^ Value
- -> WidgetFor site ()
-anchorWidget getRoute getContent a = do
- urlRender <- getUrlRender
- a_ [HA.href (toValue (urlRender (getRoute a)))] (getContent a)
-
--- | This determines the attributes that are added
--- to the individual @li@s by concatenating the header\'s
--- attributes with the data\'s attributes.
-encodeListItems ::
- (WidgetFor site () -> WidgetFor site ())
- -- ^ Wrapper for items, often @ul@
- -> (WidgetFor site () -> WidgetFor site () -> WidgetFor site ())
- -- ^ Combines header with data
- -> Colonnade Headed a (Cell site)
- -- ^ How to encode data as a row
- -> a
- -- ^ The value to display
- -> WidgetFor site ()
-encodeListItems ulWrap combine enc =
- ulWrap . E.bothMonadic_ enc
- (\(Cell ha hc) (Cell ba bc) ->
- li_ (ha <> ba) (combine hc bc)
- )
-
--- | A two-column table with the header content displayed in the
--- first column and the data displayed in the second column. Note
--- that the generated HTML table does not have a @thead@.
-encodeDefinitionTable ::
- [Attribute]
- -- ^ Attributes of @table@ element.
- -> Colonnade Headed a (Cell site)
- -- ^ How to encode data as a row
- -> a
- -- ^ The value to display
- -> WidgetFor site ()
-encodeDefinitionTable attrs enc a = table_ attrs $ tbody_ [] $
- E.bothMonadic_ enc
- (\theKey theValue -> tr_ [] $ do
- widgetFromCell td_ theKey
- widgetFromCell td_ theValue
- ) a
-
--- | Encode an html table with attributes on the table cells.
--- If you are using the bootstrap css framework, then you may want
--- to call this with the first argument as:
---
--- > encodeCellTable (HA.class_ "table table-striped") ...
-encodeCellTable :: (Foldable f, E.Headedness h)
- => [Attribute] -- ^ Attributes of @table@ element
- -> Colonnade h a (Cell site) -- ^ How to encode data as a row
- -> f a -- ^ Rows of data
- -> WidgetFor site ()
-encodeCellTable = encodeTable
- (E.headednessPure mempty) mempty (const mempty) widgetFromCell
-
--- | Encode an html table.
-encodeWidgetTable :: (Foldable f, E.Headedness h)
- => [Attribute] -- ^ Attributes of @\@ element
- -> Colonnade h a (WidgetFor site ()) -- ^ How to encode data as columns
- -> f a -- ^ Rows of data
- -> WidgetFor site ()
-encodeWidgetTable = encodeTable
- (E.headednessPure mempty) mempty (const mempty) ($ mempty)
-
--- | Encode a table. This handles a very general case and
--- is seldom needed by users. One of the arguments provided is
--- used to add attributes to the generated @\@ elements.
-encodeTable ::
- (Foldable f, E.Headedness h)
- => h [Attribute] -- ^ Attributes of @\@
- -> [Attribute] -- ^ Attributes of @\ @ element
- -> (a -> [Attribute]) -- ^ Attributes of each @\@ element
- -> (([Attribute] -> WidgetFor site () -> WidgetFor site ()) -> c -> WidgetFor site ()) -- ^ Wrap content and convert to 'Html'
- -> [Attribute] -- ^ Attributes of @\@ element
- -> Colonnade h a c -- ^ How to encode data as a row
- -> f a -- ^ Collection of data
- -> WidgetFor site ()
-encodeTable theadAttrs tbodyAttrs trAttrs wrapContent tableAttrs colonnade xs =
- table_ tableAttrs $ do
- for_ E.headednessExtract $ \unhead ->
- thead_ (unhead theadAttrs) $ do
- E.headerMonadicGeneral_ colonnade (wrapContent th_)
- tbody_ tbodyAttrs $ do
- forM_ xs $ \x -> do
- tr_ (trAttrs x) (E.rowMonadic_ colonnade (wrapContent td_) x)
-
-widgetFromCell ::
- ([Attribute] -> WidgetFor site () -> WidgetFor site ())
- -> Cell site
- -> WidgetFor site ()
-widgetFromCell f (Cell attrs contents) =
- f attrs contents
-
diff --git a/yesod-colonnade/yesod-colonnade.cabal b/yesod-colonnade/yesod-colonnade.cabal
deleted file mode 100644
index 04fe54b..0000000
--- a/yesod-colonnade/yesod-colonnade.cabal
+++ /dev/null
@@ -1,33 +0,0 @@
-cabal-version: 2.0
-name: yesod-colonnade
-version: 1.3.0.2
-synopsis: Helper functions for using yesod with colonnade
-description: Yesod and colonnade
-homepage: https://github.com/andrewthad/colonnade#readme
-license: BSD3
-license-file: LICENSE
-author: Andrew Martin
-maintainer: andrew.thaddeus@gmail.com
-copyright: 2018 Andrew Martin
-category: web
-build-type: Simple
-
-library
- hs-source-dirs: src
- exposed-modules:
- Yesod.Colonnade
- build-depends:
- base >= 4.9.1 && < 4.18
- , colonnade >= 1.2 && < 1.3
- , yesod-core >= 1.6 && < 1.7
- , conduit >= 1.3 && < 1.4
- , conduit-extra >= 1.3 && < 1.4
- , text >= 1.0 && < 2.1
- , blaze-markup >= 0.7 && < 0.9
- , blaze-html >= 0.8 && < 0.10
- , yesod-elements >= 1.1 && < 1.2
- default-language: Haskell2010
-
-source-repository head
- type: git
- location: https://github.com/andrewthad/colonnade
| | | | | | |