summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorqfpl <>2018-08-10 06:12:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2018-08-10 06:12:00 (GMT)
commit6bb2979c7d53705fec0a3aef2f0ce4e9a6b5555f (patch)
tree9ee82f237bf4280d9924b70135d47cac85e590e5
parent8c058cf1759a379357c05cc94ab07dd6b346acfb (diff)
version 0.2.1HEAD0.2.1master
-rw-r--r--changelog.md5
-rw-r--r--src/Data/Sv/Decode/Core.hs2
-rw-r--r--src/Data/Sv/Encode/Core.hs106
-rw-r--r--src/Data/Sv/Encode/Type.hs31
-rw-r--r--sv-core.cabal2
5 files changed, 124 insertions, 22 deletions
diff --git a/changelog.md b/changelog.md
index 0a3feb4..b27d825 100644
--- a/changelog.md
+++ b/changelog.md
@@ -1,5 +1,10 @@
# Revision history for sv-core
+## 0.2.1 -- 2018-08-10
+
+* Add column-name-based encoding. NameEncode, NameEncode', and
+ related functions
+
## 0.2 -- 2018-07-25
* Add column-name-based decoding NameDecode, NameDecode', and associated
diff --git a/src/Data/Sv/Decode/Core.hs b/src/Data/Sv/Decode/Core.hs
index 3ebc14f..53d4841 100644
--- a/src/Data/Sv/Decode/Core.hs
+++ b/src/Data/Sv/Decode/Core.hs
@@ -533,6 +533,8 @@ column s d =
(v, l, i') -> (v, l <> pure False, i')
-- | Infix alias for 'column'
+--
+-- Mnemonic: __D__ot colon names __D__ecoders, __E__qual colon names __E__ncoders.
(.:) :: Ord s => s -> Decode' s a -> NameDecode' s a
(.:) = column
{-# INLINE (.:) #-}
diff --git a/src/Data/Sv/Encode/Core.hs b/src/Data/Sv/Encode/Core.hs
index dabdf69..0c8227a 100644
--- a/src/Data/Sv/Encode/Core.hs
+++ b/src/Data/Sv/Encode/Core.hs
@@ -68,9 +68,13 @@ module Data.Sv.Encode.Core (
-- * Running an Encode
, encode
+, encodeNamed
, encodeToHandle
+, encodeNamedToHandle
, encodeToFile
+, encodeNamedToFile
, encodeBuilder
+, encodeNamedBuilder
, encodeRow
, encodeRowBuilder
@@ -78,6 +82,9 @@ module Data.Sv.Encode.Core (
, module Data.Sv.Encode.Options
-- * Primitive encodes
+-- ** Name-based
+, named
+, (=:)
-- ** Field-based
, const
, show
@@ -125,14 +132,17 @@ import Prelude hiding (const, show)
import Control.Lens (Getting, preview, view)
import Control.Monad (join)
+import Control.Monad.Writer (runWriter, writer)
import qualified Data.Bool as B (bool)
import qualified Data.ByteString as Strict
import qualified Data.ByteString.Builder as BS
import qualified Data.ByteString.Lazy as LBS
import Data.Foldable (fold)
import Data.Functor.Contravariant (Contravariant (contramap))
+import Data.Functor.Contravariant.Compose (ComposeFC (ComposeFC, getComposeFC))
import Data.Functor.Contravariant.Divisible (Divisible (conquer), Decidable (choose))
import Data.Monoid (Monoid (mempty), First, (<>), mconcat)
+import Data.Sequence (Seq)
import qualified Data.Sequence as Seq
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
@@ -140,8 +150,8 @@ import GHC.Word (Word8)
import System.IO (BufferMode (BlockBuffering), Handle, hClose, hSetBinaryMode, hSetBuffering, openFile, IOMode (WriteMode))
import Data.Sv.Alien.Containers (intersperseSeq)
-import Data.Sv.Encode.Options (EncodeOptions (..), HasEncodeOptions (..), HasSeparator (..), defaultEncodeOptions, Quoting (..))
-import Data.Sv.Encode.Type (Encode (Encode, getEncode))
+import Data.Sv.Encode.Options (EncodeOptions (EncodeOptions, _encodeSeparator, _newline, _terminalNewline, _quoting), HasEncodeOptions (), HasSeparator (separator), defaultEncodeOptions, Quoting (Always, AsNeeded, Never))
+import Data.Sv.Encode.Type (Encode (Encode, getEncode), NameEncode (NameEncode, unNamedE))
import Data.Sv.Structure.Newline (newlineToBuilder)
-- | Make an 'Encode' from a function that builds one 'Field'.
@@ -157,25 +167,46 @@ unsafeBuilder :: (a -> BS.Builder) -> Encode a
unsafeBuilder b = Encode (\_ a -> pure (b a))
{-# INLINE unsafeBuilder #-}
--- | Encode the given list with the given 'Encode', configured by the given
+-- | Encode the given list using the given 'Encode', configured by the given
-- 'EncodeOptions'.
encode :: Encode a -> EncodeOptions -> [a] -> LBS.ByteString
encode enc opts = BS.toLazyByteString . encodeBuilder enc opts
+-- | Encode the given list with a header using the given 'NameEncode',
+-- configured by the given 'EncodeOptions'.
+encodeNamed :: NameEncode a -> EncodeOptions -> [a] -> LBS.ByteString
+encodeNamed enc opts = BS.toLazyByteString . encodeNamedBuilder enc opts
+
-- | Encode, writing the output to a file handle.
encodeToHandle :: Encode a -> EncodeOptions -> [a] -> Handle -> IO ()
encodeToHandle enc opts as h =
BS.hPutBuilder h (encodeBuilder enc opts as)
+-- | Encode with a header, writing the output to a file handle.
+encodeNamedToHandle :: NameEncode a -> EncodeOptions -> [a] -> Handle -> IO ()
+encodeNamedToHandle enc opts as h =
+ BS.hPutBuilder h (encodeNamedBuilder enc opts as)
+
-- | Encode, writing to a file. This way is more efficient than encoding to
-- a 'ByteString' and then writing to file.
encodeToFile :: Encode a -> EncodeOptions -> [a] -> FilePath -> IO ()
-encodeToFile enc opts as fp = do
+encodeToFile = genericEncodeToFile encodeToHandle
+
+-- | Encode with a header, writing to a file. This way is more efficient
+-- than encoding to a 'ByteString' and then writing to file.
+encodeNamedToFile :: NameEncode a -> EncodeOptions -> [a] -> FilePath -> IO ()
+encodeNamedToFile = genericEncodeToFile encodeNamedToHandle
+
+genericEncodeToFile
+ :: (enc -> EncodeOptions -> [a] -> Handle -> IO ())
+ -> enc -> EncodeOptions -> [a] -> FilePath -> IO ()
+genericEncodeToFile encHandle enc opts as fp = do
h <- openFile fp WriteMode
hSetBuffering h (BlockBuffering Nothing)
hSetBinaryMode h True
- encodeToHandle enc opts as h
+ encHandle enc opts as h
hClose h
+{-# INLINE genericEncodeToFile #-}
-- | Encode to a ByteString 'Builder', which is useful if you are going
-- to combine the output with other 'ByteString's.
@@ -188,6 +219,20 @@ encodeBuilder e opts as =
[] -> terminal
(a:as') -> enc a <> mconcat [nl <> enc a' | a' <- as'] <> terminal
+-- | Encode with column names to a ByteString 'Builder', which is useful
+-- if you are going to combine the output with other 'ByteString's.
+encodeNamedBuilder :: NameEncode a -> EncodeOptions -> [a] -> BS.Builder
+encodeNamedBuilder ne opts as =
+ case runNamed ne of
+ (e, builders) ->
+ let mkHeader = fold . addSeparators opts . addQuoting opts
+ addQuoting = fmap . enquote
+ nl = newlineToBuilder (_newline opts)
+ header = mkHeader builders
+ in header <> case as of
+ [] -> if _terminalNewline opts then nl else mempty
+ (_:_) -> nl <> encodeBuilder e opts as
+
-- | Encode one row only
encodeRow :: Encode a -> EncodeOptions -> a -> LBS.ByteString
encodeRow e opts = BS.toLazyByteString . encodeRowBuilder e opts
@@ -195,8 +240,11 @@ encodeRow e opts = BS.toLazyByteString . encodeRowBuilder e opts
-- | Encode one row only, as a ByteString 'Builder'
encodeRowBuilder :: Encode a -> EncodeOptions -> a -> BS.Builder
encodeRowBuilder e opts =
- let addSeparators = intersperseSeq (BS.word8 (view separator opts))
- in fold . addSeparators . getEncode e opts
+ fold . addSeparators opts . getEncode e opts
+
+addSeparators :: HasSeparator s => s -> Seq BS.Builder -> Seq BS.Builder
+addSeparators opts = intersperseSeq (BS.word8 (view separator opts))
+{-# INLINE addSeparators #-}
-- | Encode this 'Data.ByteString.ByteString' every time, ignoring the input.
const :: Strict.ByteString -> Encode a
@@ -262,6 +310,19 @@ quotingIsNecessary opts bs =
w == 13 || -- cr
w == 34 -- double quote
+enquote :: EncodeOptions -> BS.Builder -> BS.Builder
+enquote opts s =
+ let lbs = BS.toLazyByteString s
+ quoted = quote lbs
+ in case _quoting opts of
+ Never ->
+ s
+ AsNeeded ->
+ if quotingIsNecessary opts lbs
+ then quoted
+ else s
+ Always -> quoted
+
quote :: LBS.ByteString -> BS.Builder
quote bs =
let q = BS.charUtf8 '"'
@@ -310,17 +371,7 @@ lazyByteString = escaped BS.lazyByteString
escaped :: (s -> BS.Builder) -> Encode s
escaped build =
mkEncodeWithOpts $ \opts s ->
- let s' = build s
- lbs = BS.toLazyByteString s'
- quoted = quote lbs
- in case _quoting opts of
- Never ->
- s'
- AsNeeded ->
- if quotingIsNecessary opts lbs
- then quoted
- else s'
- Always -> quoted
+ enquote opts (build s)
-- | Encode a 'Bool' as True or False
boolTrueFalse :: Encode Bool
@@ -346,6 +397,25 @@ boolYN = mkEncodeBS $ B.bool "N" "Y"
bool10 :: Encode Bool
bool10 = mkEncodeBS $ B.bool "0" "1"
+mkNamed :: Encode a -> Seq BS.Builder -> NameEncode a
+mkNamed enc b = NameEncode (ComposeFC (writer (enc, b)))
+
+-- | Attach a column name to an 'Encode'. This is used for building 'Encode's
+-- with headers.
+--
+-- Best used with @OverloadedStrings@
+named :: BS.Builder -> Encode a -> NameEncode a
+named name enc = mkNamed enc (pure name)
+
+-- | Synonym for 'named'.
+--
+-- Mnemonic: __D__ot colon names __D__ecoders, __E__qual colon names __E__ncoders.
+(=:) :: BS.Builder -> Encode a -> NameEncode a
+(=:) = named
+
+runNamed :: NameEncode a -> (Encode a, Seq BS.Builder)
+runNamed = runWriter . getComposeFC . unNamedE
+
-- | Given an optic from @s@ to @a@, Try to use it to build an encode.
--
-- @
diff --git a/src/Data/Sv/Encode/Type.hs b/src/Data/Sv/Encode/Type.hs
index 3159cdc..a12488a 100644
--- a/src/Data/Sv/Encode/Type.hs
+++ b/src/Data/Sv/Encode/Type.hs
@@ -13,13 +13,17 @@ The core type for encoding
module Data.Sv.Encode.Type (
Encode (Encode, getEncode)
+, NameEncode (..)
) where
+import Control.Applicative (liftA2)
+import Control.Monad.Writer (Writer)
import Data.Bifoldable (bifoldMap)
import Data.ByteString.Builder (Builder)
import Data.Functor.Contravariant (Contravariant (contramap))
+import Data.Functor.Contravariant.Compose (ComposeFC (ComposeFC))
import Data.Functor.Contravariant.Divisible (Divisible (divide, conquer), Decidable (choose, lose))
-import Data.Semigroup (Semigroup)
+import Data.Semigroup (Semigroup ((<>)))
import Data.Sequence (Seq)
import Data.Void (absurd)
@@ -28,8 +32,9 @@ import Data.Sv.Encode.Options
-- | An 'Encode' converts its argument into one or more textual fields, to be
-- written out as CSV.
--
--- It is 'Semigroup', 'Contravariant', 'Divisible', and 'Decidable', allowing
--- for composition of these values to build bigger 'Encode's from smaller ones.
+-- It is 'Semigroup', 'Monoid', 'Contravariant', 'Divisible', and 'Decidable',
+-- allowing for composition of these values to build bigger 'Encode's
+-- from smaller ones.
newtype Encode a =
Encode { getEncode :: EncodeOptions -> a -> Seq Builder }
deriving (Semigroup, Monoid)
@@ -46,3 +51,23 @@ instance Decidable Encode where
lose f = Encode (const (absurd . f))
choose f (Encode x) (Encode y) =
Encode $ \e a -> either (x e) (y e) (f a)
+
+-- | A 'NameEncode' is an 'Encode' with an attached column name.
+--
+-- It is 'Semigroup', 'Monoid', 'Contravariant', and 'Divisible', allowing
+-- for composition of these values to build bigger 'NameEncode's
+-- from smaller ones.
+--
+-- Notably, 'NameEncode' is not 'Decidable', since taking the sum of column
+-- names does not make sense.
+newtype NameEncode a =
+ NameEncode { unNamedE :: ComposeFC (Writer (Seq Builder)) Encode a}
+ deriving (Contravariant, Divisible) -- intentionally not Decidable
+
+instance Semigroup (NameEncode a) where
+ NameEncode (ComposeFC a) <> NameEncode (ComposeFC b) =
+ NameEncode (ComposeFC (liftA2 (<>) a b))
+
+instance Monoid (NameEncode a) where
+ mappend = (<>)
+ mempty = NameEncode (ComposeFC (pure mempty))
diff --git a/sv-core.cabal b/sv-core.cabal
index 189d6b0..d3efbcf 100644
--- a/sv-core.cabal
+++ b/sv-core.cabal
@@ -1,5 +1,5 @@
name: sv-core
-version: 0.2
+version: 0.2.1
license: BSD3
license-file: LICENCE
author: George Wilson