From 8e00c8355d3d831f597d662d50b4af4d89d4cb55 Mon Sep 17 00:00:00 2001 From: Brian McKeon Date: Wed, 6 Mar 2024 12:02:18 -0500 Subject: [PATCH] Prepare 1.0.2 release. Removed other subprojects. Reformatted. Use new .github workflows. Added changelog. Export `charCell`. --- .github/CODEOWNERS | 1 + .github/workflows/build.yaml | 11 + .github/workflows/release.yaml | 10 + .gitignore | 1 + CHANGELOG.md | 6 + blaze-colonnade/LICENSE => LICENSE | 0 README.md | 11 - blaze-colonnade/Setup.hs | 2 - blaze-colonnade/blaze-colonnade.cabal | 38 - blaze-colonnade/hackage-docs.sh | 48 -- blaze-colonnade/src/Text/Blaze/Colonnade.hs | 549 ------------ build | 16 - cabal.project | 5 - colonnade/LICENSE | 30 - colonnade/Setup.hs | 2 - colonnade/colonnade.cabal | 50 -- colonnade/hackage-docs.sh | 48 -- colonnade/src/Colonnade.hs | 438 ---------- colonnade/src/Colonnade/Encode.hs | 691 --------------- fourmolu.yaml | 51 ++ geolite-csv/LICENSE | 30 - geolite-csv/Setup.hs | 2 - .../data/small/GeoLite2-City-Blocks-IPv4.csv | 11 - .../data/small/GeoLite2-City-Locations-en.csv | 21 - .../data/small/GeoLite2-City-Locations-ja.csv | 21 - geolite-csv/geolite-csv.cabal | 52 -- geolite-csv/hackage-docs.sh | 48 -- geolite-csv/scripts/load-full-databases | 35 - geolite-csv/src/Geolite/Csv.hs | 59 -- geolite-csv/src/Geolite/Types.hs | 43 - geolite-csv/test/Spec.hs | 91 -- lucid-colonnade.cabal | 36 + lucid-colonnade/LICENSE | 30 - lucid-colonnade/Setup.hs | 2 - lucid-colonnade/lucid-colonnade.cabal | 29 - lucid-colonnade/src/Lucid/Colonnade.hs | 292 ------- projects/cabal-8.0.2.project | 4 - projects/cabal-8.2.2.project | 4 - projects/cabal-8.4.3.project | 3 - siphon/CHANGELOG.md | 9 - siphon/LICENSE | 30 - siphon/Setup.hs | 2 - siphon/hackage-docs.sh | 48 -- siphon/siphon.cabal | 58 -- siphon/src/Siphon.hs | 791 ------------------ siphon/src/Siphon/ByteString/Char8.hs | 1 - siphon/src/Siphon/Content.hs | 8 - siphon/src/Siphon/Decoding.hs | 336 -------- siphon/src/Siphon/Encoding.hs | 30 - siphon/src/Siphon/Internal.hs | 214 ----- siphon/src/Siphon/Internal/Text.hs | 189 ----- siphon/src/Siphon/Text.hs | 33 - siphon/src/Siphon/Types.hs | 84 -- siphon/test/Test.hs | 388 --------- src/Lucid/Colonnade.hs | 346 ++++++++ yesod-colonnade/LICENSE | 30 - yesod-colonnade/Setup.hs | 2 - yesod-colonnade/hackage-docs.sh | 48 -- yesod-colonnade/src/Yesod/Colonnade.hs | 183 ---- yesod-colonnade/yesod-colonnade.cabal | 33 - 60 files changed, 462 insertions(+), 5222 deletions(-) create mode 100644 .github/CODEOWNERS create mode 100644 .github/workflows/build.yaml create mode 100644 .github/workflows/release.yaml create mode 100644 CHANGELOG.md rename blaze-colonnade/LICENSE => LICENSE (100%) delete mode 100644 README.md delete mode 100644 blaze-colonnade/Setup.hs delete mode 100644 blaze-colonnade/blaze-colonnade.cabal delete mode 100755 blaze-colonnade/hackage-docs.sh delete mode 100644 blaze-colonnade/src/Text/Blaze/Colonnade.hs delete mode 100755 build delete mode 100644 cabal.project delete mode 100644 colonnade/LICENSE delete mode 100644 colonnade/Setup.hs delete mode 100644 colonnade/colonnade.cabal delete mode 100755 colonnade/hackage-docs.sh delete mode 100644 colonnade/src/Colonnade.hs delete mode 100644 colonnade/src/Colonnade/Encode.hs create mode 100644 fourmolu.yaml delete mode 100644 geolite-csv/LICENSE delete mode 100644 geolite-csv/Setup.hs delete mode 100644 geolite-csv/data/small/GeoLite2-City-Blocks-IPv4.csv delete mode 100644 geolite-csv/data/small/GeoLite2-City-Locations-en.csv delete mode 100644 geolite-csv/data/small/GeoLite2-City-Locations-ja.csv delete mode 100644 geolite-csv/geolite-csv.cabal delete mode 100755 geolite-csv/hackage-docs.sh delete mode 100755 geolite-csv/scripts/load-full-databases delete mode 100644 geolite-csv/src/Geolite/Csv.hs delete mode 100644 geolite-csv/src/Geolite/Types.hs delete mode 100644 geolite-csv/test/Spec.hs create mode 100644 lucid-colonnade.cabal delete mode 100644 lucid-colonnade/LICENSE delete mode 100644 lucid-colonnade/Setup.hs delete mode 100644 lucid-colonnade/lucid-colonnade.cabal delete mode 100644 lucid-colonnade/src/Lucid/Colonnade.hs delete mode 100644 projects/cabal-8.0.2.project delete mode 100644 projects/cabal-8.2.2.project delete mode 100644 projects/cabal-8.4.3.project delete mode 100644 siphon/CHANGELOG.md delete mode 100644 siphon/LICENSE delete mode 100644 siphon/Setup.hs delete mode 100755 siphon/hackage-docs.sh delete mode 100644 siphon/siphon.cabal delete mode 100644 siphon/src/Siphon.hs delete mode 100644 siphon/src/Siphon/ByteString/Char8.hs delete mode 100644 siphon/src/Siphon/Content.hs delete mode 100644 siphon/src/Siphon/Decoding.hs delete mode 100644 siphon/src/Siphon/Encoding.hs delete mode 100644 siphon/src/Siphon/Internal.hs delete mode 100644 siphon/src/Siphon/Internal/Text.hs delete mode 100644 siphon/src/Siphon/Text.hs delete mode 100644 siphon/src/Siphon/Types.hs delete mode 100644 siphon/test/Test.hs create mode 100644 src/Lucid/Colonnade.hs delete mode 100644 yesod-colonnade/LICENSE delete mode 100644 yesod-colonnade/Setup.hs delete mode 100755 yesod-colonnade/hackage-docs.sh delete mode 100644 yesod-colonnade/src/Yesod/Colonnade.hs delete mode 100644 yesod-colonnade/yesod-colonnade.cabal diff --git a/.github/CODEOWNERS b/.github/CODEOWNERS new file mode 100644 index 0000000..f6c0b22 --- /dev/null +++ b/.github/CODEOWNERS @@ -0,0 +1 @@ +@byteverse/l3c diff --git a/.github/workflows/build.yaml b/.github/workflows/build.yaml new file mode 100644 index 0000000..fa1c5d7 --- /dev/null +++ b/.github/workflows/build.yaml @@ -0,0 +1,11 @@ +name: build +on: + pull_request: + branches: + - "*" + +jobs: + call-workflow: + uses: byteverse/.github/.github/workflows/build-matrix.yaml@main + with: + cabal-file: lucid-colonnade.cabal diff --git a/.github/workflows/release.yaml b/.github/workflows/release.yaml new file mode 100644 index 0000000..9411962 --- /dev/null +++ b/.github/workflows/release.yaml @@ -0,0 +1,10 @@ +name: release +on: + push: + tags: + - "*" + +jobs: + call-workflow: + uses: byteverse/.github/.github/workflows/release.yaml@main + secrets: inherit diff --git a/.gitignore b/.gitignore index 50024bb..728f225 100644 --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,4 @@ +.vscode/ *.aux cabal-dev .cabal-sandbox diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 index 0000000..598dff4 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,6 @@ +# Revision history for lucid-colonnade + +## 1.0.2 -- 2024-03-06 + +* Update package metadata. +* Export `charCell`. diff --git a/blaze-colonnade/LICENSE b/LICENSE similarity index 100% rename from blaze-colonnade/LICENSE rename to LICENSE diff --git a/README.md b/README.md deleted file mode 100644 index 79c5498..0000000 --- a/README.md +++ /dev/null @@ -1,11 +0,0 @@ -Most of the tests use doctest, which isn't run like a normal test suite (I guess). - -To run these tests, first make sure `doctest` is on the `PATH` (i.e. `cabal install doctest`), then run the following commands: - -``` -cabal repl --build-depends=QuickCheck --with-ghc=doctest --repl-options="-fno-warn-orphans" siphon -cabal repl --build-depends=QuickCheck --with-ghc=doctest --repl-options="-fno-warn-orphans" colonnade -cabal repl --build-depends=QuickCheck --with-ghc=doctest --repl-options="-fno-warn-orphans" blaze-colonnade -``` - -There are no tests for lucid-colonnade at present. diff --git a/blaze-colonnade/Setup.hs b/blaze-colonnade/Setup.hs deleted file mode 100644 index 9a994af..0000000 --- a/blaze-colonnade/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/blaze-colonnade/blaze-colonnade.cabal b/blaze-colonnade/blaze-colonnade.cabal deleted file mode 100644 index 42bd1c8..0000000 --- a/blaze-colonnade/blaze-colonnade.cabal +++ /dev/null @@ -1,38 +0,0 @@ -name: blaze-colonnade -version: 1.2.2.1 -synopsis: blaze-html backend for colonnade -description: - This library provides a backend for using blaze-html with colonnade. - It generates standard HTML tables with ``, ``, ``, - ``, `
`, 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) --- --- --- --- --- --- --- --- --- ---
GradeLetter
90-100A
80-89B
70-79C
-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) --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
NameAge
Thaddeus34
Lucia33
Pranav57
--- --- 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) --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
NameAgeDept.
Thaddeus34Sales
Lucia33Engineering
Pranav57Management
- --- $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]) --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
PersonalWork
NameAgeDept.
Thaddeus34Sales
- -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..5afa2a7 --- /dev/null +++ b/src/Lucid/Colonnade.hs @@ -0,0 +1,346 @@ +{-# LANGUAGE BangPatterns #-} +{-# 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 + +import Colonnade (Colonnade) +import qualified Colonnade.Encode as E +import Control.Monad +import Data.Foldable +import Data.String (IsString (..)) +import Data.Text (Text) +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 +import Lucid hiding (for_) + +{- $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