diff --git a/colonnade/colonnade.cabal b/colonnade/colonnade.cabal index 2f014c2..033bfb9 100644 --- a/colonnade/colonnade.cabal +++ b/colonnade/colonnade.cabal @@ -10,6 +10,8 @@ description: 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 diff --git a/lucid-colonnade/LICENSE b/lucid-colonnade/LICENSE new file mode 100644 index 0000000..9beb3f9 --- /dev/null +++ b/lucid-colonnade/LICENSE @@ -0,0 +1,30 @@ +Copyright Andrew Martin (c) 2016 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Andrew Martin nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. \ No newline at end of file diff --git a/lucid-colonnade/Setup.hs b/lucid-colonnade/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/lucid-colonnade/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/lucid-colonnade/lucid-colonnade.cabal b/lucid-colonnade/lucid-colonnade.cabal new file mode 100644 index 0000000..377e37e --- /dev/null +++ b/lucid-colonnade/lucid-colonnade.cabal @@ -0,0 +1,28 @@ +name: lucid-colonnade +version: 1.0 +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.7 && < 5 + , colonnade >= 1.1.1 && < 1.3 + , lucid >= 2.9 && < 3.0 + , text >= 1.0 && < 1.3 + 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 new file mode 100644 index 0000000..600b99e --- /dev/null +++ b/lucid-colonnade/src/Lucid/Colonnade.hs @@ -0,0 +1,193 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +-- | 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 + , encodeTable + -- * Cell + -- $build + , Cell(..) + , htmlCell + , stringCell + , textCell + , lazyTextCell + , builderCell + , htmlFromCell + -- * Discussion + -- $discussion + ) where + +import Colonnade (Colonnade,Headed,Headless,Fascia,Cornice) +import Data.Text (Text) +import Control.Monad +import Data.Monoid +import Data.Foldable +import Data.String (IsString(..)) +import Data.Maybe (listToMaybe) +import Data.Char (isSpace) +import Control.Applicative (liftA2) +import Lucid +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 + +-- $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 Monoid d => Monoid (Cell d) where + mempty = Cell mempty (return mempty) + mappend (Cell a1 c1) (Cell a2 c2) = Cell (mappend a1 a2) (liftA2 mappend c1 c2) + +-- | Create a 'Cell' from a 'Widget' +htmlCell :: Html d -> Cell d +htmlCell = Cell mempty + +-- | Create a 'Cell' from a 'String' +stringCell :: String -> Cell () +stringCell = htmlCell . fromString + +-- | Create a 'Cell' from a 'Char' +charCell :: Char -> Cell () +charCell = stringCell . pure + +-- | Create a 'Cell' from a 'Text' +textCell :: Text -> Cell () +textCell = htmlCell . toHtml + +-- | Create a 'Cell' from a lazy text +lazyTextCell :: LText.Text -> Cell () +lazyTextCell = textCell . LText.toStrict + +-- | Create a 'Cell' from a text builder +builderCell :: TBuilder.Builder -> Cell () +builderCell = lazyTextCell . TBuilder.toLazyText + +-- | Encode a table. Table cell element do not have +-- any attributes applied to them. +encodeHtmlTable :: + (E.Headedness h, Foldable f, Monoid d) + => [Attribute] -- ^ Attributes of @\@ 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 + +-- | 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 + +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. + + diff --git a/siphon/src/Siphon.hs b/siphon/src/Siphon.hs index 716ceb6..8f46484 100644 --- a/siphon/src/Siphon.hs +++ b/siphon/src/Siphon.hs @@ -8,20 +8,8 @@ -- | 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 the following --- setup: --- --- >>> :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 qualified Data.Text.Lazy.IO as LTIO --- >>> import qualified Data.Text.Lazy.Builder as LB --- >>> import Data.Text (Text) --- >>> import Data.Maybe (fromMaybe) --- >>> data Person = Person { name :: Text, age :: Int, company :: Maybe Text} +-- 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 @@ -29,7 +17,7 @@ module Siphon , encodeCsvUtf8 , encodeCsvStreamUtf8 -- * Decode CSV - , decodeHeadedUtf8Csv + , decodeCsvUtf8 -- * Build Siphon , headed , headless @@ -40,6 +28,8 @@ module Siphon , Indexed(..) -- * Utility , humanizeSiphonError + -- * Imports + -- $setup ) where import Siphon.Types @@ -89,11 +79,11 @@ data Ended = EndedYes | EndedNo data CellResult c = CellResultData !c | CellResultNewline !c !Ended deriving (Show) -decodeHeadedUtf8Csv :: Monad m +decodeCsvUtf8 :: Monad m => Siphon CE.Headed ByteString a -> Stream (Of ByteString) m () -- ^ encoded csv -> Stream (Of a) m (Maybe SiphonError) -decodeHeadedUtf8Csv headedSiphon s1 = do +decodeCsvUtf8 headedSiphon s1 = do e <- lift (consumeHeaderRowUtf8 s1) case e of Left err -> return (Just err) @@ -353,7 +343,7 @@ field !delim = do case mb of Just b | b == doubleQuote -> do - (bs,tc) <- escapedField delim + (bs,tc) <- escapedField case tc of TrailCharComma -> return (CellResultData bs) TrailCharNewline -> return (CellResultNewline bs EndedNo) @@ -376,8 +366,8 @@ field !delim = do eatNewlines :: AL.Parser S.ByteString eatNewlines = A.takeWhile (\x -> x == 10 || x == 13) -escapedField :: Word8 -> AL.Parser (S.ByteString,TrailChar) -escapedField !delim = do +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. @@ -445,16 +435,6 @@ unescape = (LByteString.toStrict . toLazyByteString) <$!> go mempty where blankLine :: V.Vector B.ByteString -> Bool blankLine v = V.length v == 1 && (B.null (V.head v)) --- | A version of 'liftM2' that is strict in the result of its first --- action. -liftM2' :: (Monad m) => (a -> b -> c) -> m a -> m b -> m c -liftM2' f a b = do - !x <- a - y <- b - return (f x y) -{-# INLINE liftM2' #-} - - doubleQuote, newline, cr, comma :: Word8 doubleQuote = 34 newline = 10 diff --git a/siphon/test/Test.hs b/siphon/test/Test.hs index 04fb931..77b6ab0 100644 --- a/siphon/test/Test.hs +++ b/siphon/test/Test.hs @@ -69,7 +69,7 @@ tests = ] , testCase "Headed Decoding (int,char,bool)" $ ( runIdentity . SMP.toList ) - ( S.decodeHeadedUtf8Csv decodingB + ( S.decodeCsvUtf8 decodingB ( mapM_ (SMP.yield . BC8.singleton) $ concat [ "number,letter,boolean\n" , "244,z,true\n" @@ -78,7 +78,7 @@ tests = ) @?= ([(244,'z',True)] :> Nothing) , testCase "Headed Decoding (escaped characters, one big chunk)" $ ( runIdentity . SMP.toList ) - ( S.decodeHeadedUtf8Csv decodingF + ( S.decodeCsvUtf8 decodingF ( SMP.yield $ BC8.pack $ concat [ "name\n" , "drew\n" @@ -88,7 +88,7 @@ tests = ) @?= (["drew","martin, drew"] :> Nothing) , testCase "Headed Decoding (escaped characters, character per chunk)" $ ( runIdentity . SMP.toList ) - ( S.decodeHeadedUtf8Csv decodingF + ( S.decodeCsvUtf8 decodingF ( mapM_ (SMP.yield . BC8.singleton) $ concat [ "name\n" , "drew\n" @@ -98,7 +98,7 @@ tests = ) @?= (["drew","martin, drew"] :> Nothing) , testProperty "Headed Isomorphism (int,char,bool)" $ propIsoStream BC8.unpack - (S.decodeHeadedUtf8Csv decodingB) + (S.decodeCsvUtf8 decodingB) (S.encodeCsvStreamUtf8 encodingB) ] ] diff --git a/stack.yaml b/stack.yaml index a8113eb..e9b0485 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,44 +1,9 @@ -# This file was automatically generated by 'stack init' -# -# Some commonly used options have been documented as comments in this file. -# For advanced use and comprehensive documentation of the format, please see: -# http://docs.haskellstack.org/en/stable/yaml_configuration/ - -# Resolver to choose a 'specific' stackage snapshot or a compiler version. -# A snapshot resolver dictates the compiler version and the set of packages -# to be used for project dependencies. For example: -# -# resolver: lts-3.5 -# resolver: nightly-2015-09-21 -# resolver: ghc-7.10.2 -# resolver: ghcjs-0.1.0_ghc-7.10.2 -# resolver: -# name: custom-snapshot -# location: "./custom-snapshot.yaml" resolver: lts-8.0 - -# User packages to be built. -# Various formats can be used as shown in the example below. -# -# packages: -# - some-directory -# - https://example.com/foo/bar/baz-0.0.2.tar.gz -# - location: -# git: https://github.com/commercialhaskell/stack.git -# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a -# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a -# extra-dep: true -# subdirs: -# - auto-update -# - wai -# -# A package marked 'extra-dep: true' will only be built if demanded by a -# non-dependency (i.e. a user package), and its test suites and benchmarks -# will not be run. This is useful for tweaking upstream packages. packages: - 'colonnade' - 'yesod-colonnade' - 'blaze-colonnade' +- 'lucid-colonnade' - 'siphon' # - 'geolite-csv' # Dependency packages to be pulled from upstream that are not in the resolver