diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,5 +1,31 @@ +## Version 0.5.5.0 + +_Michael Chavinda, 2026-02-22_ + + * `Data.Csv.Incremental`: Fixed the `type role`s of `Builder` and `NamedBuilder`; they're now `nominal` in their parameters. + * `Faster encoding`: Reduce intermediate allocations in encoding logic. + * `Default values for encoding missing fields`: Provides a way to either specify per-column defaults or a general fallback value. + +## Version 0.5.4.1 + +_Andreas Abel, 2025-09-02_ + + * Bump dependency lower bounds to at least GHC 8.0 and Stackage LTS 7.0. + * Build tested with GHC 8.0 - 9.14 alpha1. + * Functionality tested with GHC 8.4 - 9.14 alpha1. + +## Version 0.5.4.0 + +_Andreas Abel, 2025-06-10_ + + * Add `decodeWithP` and `decodeByNameWithP` to `Streaming` interface ([PR #237](https://github.com/haskell-hvr/cassava/pull/237)). + * Build tested with GHC 8.0 - 9.12.2. + * Functionality tested with GHC 8.4 - 9.12.2. + ## Version 0.5.3.2 +_Andreas Abel, 2024-08-03_ + * Proper exception on hanging doublequote ([PR #222](https://github.com/haskell-hvr/cassava/pull/222)). * Allow latest `hashable`. * Build tested with GHC 8.0 - 9.10.1. @@ -7,6 +33,8 @@ ## Version 0.5.3.1 +_Andreas Abel, 2024-04-23_ + * Remove support for GHC 7. * Remove cabal flag `bytestring--LT-0_10_4` and support for `bytestring < 0.10.4`. * Tested with GHC 8.0 - 9.10 alpha3 @@ -23,6 +51,8 @@ ## Version 0.5.3.0 +_Andreas Abel, 2022-07-10_ + * Improve error messages for `lookup` and NamedRecord parsers (#197) * Fix bug (infinite loop) in `FromField Const` instance (#185) * Turn flag `bytestring--LT-0_10_4` off by default (#183) @@ -32,12 +62,16 @@ ## Version 0.5.2.0 +_Herbert Valerio Riedel, 2019-09-01_ + * Add `FromField`/`ToField` instances for `Identity` and `Const` (#158) * New `typeclass`-less decoding functions `decodeWithP` and `decodeByNameWithP` (#67,#167) * Support for final phase of MFP / base-4.13 ## Version 0.5.1.0 +_Herbert Valerio Riedel, 2017-08-12_ + * Add `FromField`/`ToField` instance for `Natural` (#141,#142) * Add `FromField`/`ToField` instances for `Scientific` (#143,#144) * Add support for modifying Generics-based instances (adding @@ -48,6 +82,8 @@ ## Version 0.5.0.0 +_Herbert Valerio Riedel, 2017-06-19_ + ### Semantic changes * Don't unecessarily quote spaces with `QuoteMinimal` (#118,#122,#86) @@ -66,10 +102,14 @@ ## Version 0.4.5.1 +_Herbert Valerio Riedel, 2016-11-10_ + * Restore GHC 7.4 support (#124) ## Version 0.4.5.0 +_Herbert Valerio Riedel, 2016-01-19_ + * Support for GHC 8.0 added; support for GHC 7.4 dropped * Fix defect in `Foldable(foldr)` implementation failing to skip @@ -81,6 +121,8 @@ ## Version 0.4.4.0 +_Johan Tibell, 2015-08-30_ + * Added record instances for larger tuples. * Support attoparsec 0.13. @@ -88,6 +130,8 @@ * Add field instances for short bytestrings. ## Version 0.4.3.0 + +_Johan Tibell, 2015-06-02_ * Documentation overhaul with more examples. diff --git a/cassava.cabal b/cassava.cabal --- a/cassava.cabal +++ b/cassava.cabal @@ -1,6 +1,7 @@ -cabal-version: 1.12 +cabal-version: 1.18 Name: cassava -Version: 0.5.3.2 +Version: 0.5.5.0 + Synopsis: A CSV parsing and encoding library Description: { @@ -39,13 +40,15 @@ Maintainer: https://github.com/haskell-hvr/cassava Category: Text, Web, CSV Build-type: Simple -Extra-source-files: examples/*.hs, - CHANGES.md, +Extra-source-files: examples/*.hs +Extra-doc-files: CHANGES.md README.md Tested-with: - GHC == 9.10.1 - GHC == 9.8.2 - GHC == 9.6.6 + GHC == 9.14.1 + GHC == 9.12.2 + GHC == 9.10.2 + GHC == 9.8.4 + GHC == 9.6.7 GHC == 9.4.8 GHC == 9.2.8 GHC == 9.0.2 @@ -73,6 +76,7 @@ FlexibleContexts FlexibleInstances KindSignatures + RoleAnnotations MultiParamTypeClasses OverloadedStrings PolyKinds @@ -97,21 +101,21 @@ Data.Csv.Types Data.Csv.Util + -- Lower bounds from GHC 8.0 and Stackage LTS 7.0 Build-depends: - base >= 4.9 && < 5 - , array >= 0.4 && < 0.6 - , attoparsec >= 0.11.3.0 && < 0.15 - , bytestring >= 0.10.4 && < 0.13 - , containers >= 0.4.2 && < 0.8 - , deepseq >= 1.1 && < 1.6 - , hashable < 2 - , scientific >= 0.3.4.7 && < 0.4 - , text < 2.2 - , text-short == 0.1.* - , transformers >= 0.2 && < 0.7 - , unordered-containers < 0.3 - , vector >= 0.8 && < 0.14 - , Only >= 0.1 && < 0.1.1 + base >= 4.9 && < 5 + , array >= 0.5.1.1 && < 0.6 + , attoparsec >= 0.11.3.0 && < 0.15 + , bytestring >= 0.10.8.0 && < 0.13 + , containers >= 0.5.7.1 && < 1 + , deepseq >= 1.4.2.0 && < 1.6 + , hashable >= 1.2.4.0 && < 2 + , scientific >= 0.3.4.9 && < 0.4 + , text >= 1.2.2.1 && < 2.2 + , text-short == 0.1.* + , unordered-containers >= 0.2.7.1 && < 0.3 + , vector >= 0.11.0.0 && < 0.14 + , Only >= 0.1 && < 0.1.1 ghc-options: -Wall @@ -135,22 +139,20 @@ Type: exitcode-stdio-1.0 Main-is: UnitTests.hs -- dependencies with version constraints inherited via lib:cassava - Build-depends: attoparsec - , base >= 4.11 && < 5 + Build-depends: base >= 4.11 && < 5 , bytestring , cassava - , hashable , scientific , text , unordered-containers , vector -- extra dependencies not already used by lib:cassava - build-depends: HUnit < 1.7 - , QuickCheck >= 2.14 && < 2.16 - , quickcheck-instances >= 0.3.12 && < 0.4 - , test-framework == 0.8.* - , test-framework-hunit == 0.3.* - , test-framework-quickcheck2 == 0.3.* + build-depends: HUnit >= 1.3.1.2 && < 1.7 + , QuickCheck >= 2.14 && < 3 + , quickcheck-instances >= 0.3.12 && < 0.4 + , test-framework == 0.8.* + , test-framework-hunit == 0.3.* + , test-framework-quickcheck2 == 0.3.* hs-source-dirs: tests diff --git a/examples/NamedRecord.hs b/examples/NamedRecord.hs deleted file mode 100644 --- a/examples/NamedRecord.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -import Data.Text (Text) -import Data.Csv - -data Person = Person { name :: !Text, age :: !Int } - -instance ToNamedRecord Person where - toNamedRecord (Person name age) = namedRecord [ - "name" .= name, "age" .= age] diff --git a/src/Data/Csv.hs b/src/Data/Csv.hs --- a/src/Data/Csv.hs +++ b/src/Data/Csv.hs @@ -56,6 +56,8 @@ , decodeByNameWithP , EncodeOptions(..) , Quoting(..) + , MissingFieldPolicy(..) + , defaultMissingFieldPolicy , defaultEncodeOptions , encodeWith , encodeByNameWith diff --git a/src/Data/Csv/Builder.hs b/src/Data/Csv/Builder.hs --- a/src/Data/Csv/Builder.hs +++ b/src/Data/Csv/Builder.hs @@ -60,7 +60,7 @@ encodeNamedRecordWith :: ToNamedRecord a => EncodeOptions -> Header -> a -> Builder.Builder encodeNamedRecordWith opts hdr nr = - Encoding.encodeNamedRecord hdr (encQuoting opts) (encDelimiter opts) + Encoding.encodeNamedRecord hdr (encQuoting opts) (encDelimiter opts) (encMissingFieldPolicy opts) (toNamedRecord nr) Mon.<> Encoding.recordSep (encUseCrLf opts) -- | Like 'encodeDefaultOrderedNamedRecord', but lets you customize diff --git a/src/Data/Csv/Encoding.hs b/src/Data/Csv/Encoding.hs --- a/src/Data/Csv/Encoding.hs +++ b/src/Data/Csv/Encoding.hs @@ -16,6 +16,8 @@ , decode , decodeByName , Quoting(..) + , MissingFieldPolicy(..) + , defaultMissingFieldPolicy , encode , encodeByName , encodeDefaultOrderedByName @@ -40,14 +42,18 @@ ) where import Data.ByteString.Builder -import Control.Applicative as AP (Applicative(..), (<|>)) + +import Control.Applicative as AP ((<|>)) import Data.Attoparsec.ByteString.Char8 (endOfInput) import qualified Data.Attoparsec.ByteString.Lazy as AL import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy.Char8 as BL8 +import Data.Foldable (asum) +import qualified Data.ByteString.Builder.Prim as P import qualified Data.HashMap.Strict as HM +import Data.Maybe (fromMaybe) import Data.Vector (Vector) import qualified Data.Vector as V import Data.Word (Word8) @@ -62,10 +68,8 @@ import qualified Data.Csv.Parser as Parser import Data.Csv.Types hiding (toNamedRecord) import qualified Data.Csv.Types as Types -import Data.Csv.Util (blankLine, endOfLine, toStrict) - - --- TODO: 'encode' isn't as efficient as it could be. +import Data.Csv.Util (blankLine, endOfLine, doubleQuote, cr, newline, comma) +import Data.Functor (($>)) ------------------------------------------------------------------------ -- * Encoding and decoding @@ -182,6 +186,23 @@ | QuoteAll -- ^ Always quote. deriving (Eq, Show) +-- | How to encode missing fields. +data MissingFieldPolicy = MissingFieldPolicy + { -- | Specify a default field value for each column. + mfpDefaultByColumn :: NamedRecord + + -- | Specify a default field value to use for columns unspecified in + -- 'mfpDefaultByColumn'. If 'Nothing', this situation results in an + -- exception. + , mfpOtherwise :: Maybe Field + } deriving (Eq, Show) + +defaultMissingFieldPolicy :: MissingFieldPolicy +defaultMissingFieldPolicy = MissingFieldPolicy + { mfpDefaultByColumn = HM.empty + , mfpOtherwise = Nothing + } + -- | Options that controls how data is encoded. These options can be -- used to e.g. encode data in a tab-separated format instead of in a -- comma-separated format. @@ -211,15 +232,19 @@ -- | What kind of quoting should be applied to text fields. , encQuoting :: !Quoting + + -- | How to encode missing fields. + , encMissingFieldPolicy :: MissingFieldPolicy } deriving (Eq, Show) -- | Encoding options for CSV files. defaultEncodeOptions :: EncodeOptions defaultEncodeOptions = EncodeOptions - { encDelimiter = 44 -- comma - , encUseCrLf = True - , encIncludeHeader = True - , encQuoting = QuoteMinimal + { encDelimiter = comma + , encUseCrLf = True + , encIncludeHeader = True + , encQuoting = QuoteMinimal + , encMissingFieldPolicy = defaultMissingFieldPolicy } -- | Like 'encode', but lets you customize how the CSV data is @@ -236,11 +261,7 @@ -- | Check if the delimiter is valid. validDelim :: Word8 -> Bool -validDelim delim = delim `notElem` [cr, nl, dquote] - where - nl = 10 - cr = 13 - dquote = 34 +validDelim delim = delim /= cr && delim /= newline && delim /= doubleQuote -- | Raises an exception indicating that the provided delimiter isn't -- valid. See 'validDelim'. @@ -256,37 +277,43 @@ -- | Encode a single record, without the trailing record separator -- (i.e. newline). encodeRecord :: Quoting -> Word8 -> Record -> Builder -encodeRecord qtng delim = mconcat . intersperse (word8 delim) - . map byteString . map (escape qtng delim) . V.toList +encodeRecord qtng delim rec' = + case V.uncons rec' of + Nothing -> mempty + Just (x, xs) -> escape qtng delim x <> + V.foldl' (\acc b -> acc <> d <> escape qtng delim b) mempty xs + where + d = word8 delim {-# INLINE encodeRecord #-} -- | Encode a single named record, without the trailing record -- separator (i.e. newline), using the given field order. -encodeNamedRecord :: Header -> Quoting -> Word8 -> NamedRecord -> Builder -encodeNamedRecord hdr qtng delim = - encodeRecord qtng delim . namedRecordToRecord hdr +encodeNamedRecord :: Header -> Quoting -> Word8 -> MissingFieldPolicy -> NamedRecord -> Builder +encodeNamedRecord hdr qtng delim missingFieldPolicy = + encodeRecord qtng delim . namedRecordToRecord missingFieldPolicy hdr --- TODO: Optimize -escape :: Quoting -> Word8 -> B.ByteString -> B.ByteString +escape :: Quoting -> Word8 -> B.ByteString -> Builder escape !qtng !delim !s - | (qtng == QuoteMinimal && - B.any (\ b -> b == dquote || b == delim || b == nl || b == cr) s - ) || qtng == QuoteAll - = toStrict . toLazyByteString $ - word8 dquote - <> B.foldl - (\ acc b -> acc <> if b == dquote - then byteString "\"\"" - else word8 b) - mempty - s - <> word8 dquote - | otherwise = s + | qtng == QuoteAll = buildQuoted + | qtng == QuoteMinimal && needsQuoting = buildQuoted + | otherwise = byteString s where - dquote = 34 - nl = 10 - cr = 13 + needsQuoting = B.any (\b -> b == doubleQuote || b == delim || b == newline || b == cr) s + dquote :: P.BoundedPrim Word8 + dquote = + P.liftFixedToBounded $ const (doubleQuote, doubleQuote) P.>$< (P.word8 P.>*< P.word8) + + escaper :: P.BoundedPrim Word8 + escaper = P.condB (== doubleQuote) + dquote + (P.liftFixedToBounded P.word8) + + buildQuoted = + word8 doubleQuote <> + P.primMapByteStringBounded escaper s <> + word8 doubleQuote + -- | Like 'encodeByName', but lets you customize how the CSV data is -- encoded. encodeByNameWith :: ToNamedRecord a => EncodeOptions -> Header -> [a] @@ -300,7 +327,7 @@ rows True = encodeRecord (encQuoting opts) (encDelimiter opts) hdr <> recordSep (encUseCrLf opts) <> records records = unlines (recordSep (encUseCrLf opts)) - . map (encodeNamedRecord hdr (encQuoting opts) (encDelimiter opts) + . map (encodeNamedRecord hdr (encQuoting opts) (encDelimiter opts) (encMissingFieldPolicy opts) . toNamedRecord) $ v {-# INLINE encodeByNameWith #-} @@ -315,25 +342,29 @@ toLazyByteString (rows (encIncludeHeader opts)) | otherwise = encodeOptionsError where - hdr = (Conversion.headerOrder (undefined :: a)) + hdr = Conversion.headerOrder (undefined :: a) rows False = records rows True = encodeRecord (encQuoting opts) (encDelimiter opts) hdr <> recordSep (encUseCrLf opts) <> records records = unlines (recordSep (encUseCrLf opts)) - . map (encodeNamedRecord hdr (encQuoting opts) (encDelimiter opts) + . map (encodeNamedRecord hdr (encQuoting opts) (encDelimiter opts) (encMissingFieldPolicy opts) . toNamedRecord) $ v {-# INLINE encodeDefaultOrderedByNameWith #-} -namedRecordToRecord :: Header -> NamedRecord -> Record -namedRecordToRecord hdr nr = V.map find hdr +namedRecordToRecord :: MissingFieldPolicy -> Header -> NamedRecord -> Record +namedRecordToRecord missingFieldPolicy hdr nr = V.map find hdr where - find n = case HM.lookup n nr of - Nothing -> moduleError "namedRecordToRecord" $ - "header contains name " ++ show (B8.unpack n) ++ - " which is not present in the named record" - Just v -> v + find n = fromMaybe (fallbackError n) $ asum + [ HM.lookup n nr + , HM.lookup n $ mfpDefaultByColumn missingFieldPolicy + , mfpOtherwise missingFieldPolicy + ] + fallbackError n = moduleError "namedRecordToRecord" $ + "header contains name " ++ show (B8.unpack n) ++ + " which is not present in the named record" + moduleError :: String -> String -> a moduleError func msg = error $ "Data.Csv.Encoding." ++ func ++ ": " ++ msg {-# NOINLINE moduleError #-} @@ -346,14 +377,6 @@ unlines _ [] = mempty unlines sep (b:bs) = b <> sep <> unlines sep bs -intersperse :: Builder -> [Builder] -> [Builder] -intersperse _ [] = [] -intersperse sep (x:xs) = x : prependToAll sep xs - -prependToAll :: Builder -> [Builder] -> [Builder] -prependToAll _ [] = [] -prependToAll sep (x:xs) = sep <> x : prependToAll sep xs - decodeWithP' :: AL.Parser a -> L.ByteString -> Either String a decodeWithP' p s = case AL.parse p s of @@ -362,7 +385,7 @@ where errMsg = "parse error (" ++ msg ++ ") at " ++ (if BL8.length left > 100 - then (take 100 $ BL8.unpack left) ++ " (truncated)" + then take 100 (BL8.unpack left) ++ " (truncated)" else show (BL8.unpack left)) {-# INLINE decodeWithP' #-} @@ -386,11 +409,11 @@ records = do !r <- record (decDelimiter opts) if blankLine r - then (endOfInput *> pure []) <|> (endOfLine *> records) + then (endOfInput $> []) <|> (endOfLine *> records) else case runParser (_parseRecord r) of Left msg -> fail $ "conversion error: " ++ msg Right val -> do - !vals <- (endOfInput *> AP.pure []) <|> (endOfLine *> records) + !vals <- (endOfInput $> []) <|> (endOfLine *> records) return (val : vals) {-# INLINE csv #-} @@ -406,11 +429,11 @@ records hdr = do !r <- record (decDelimiter opts) if blankLine r - then (endOfInput *> pure []) <|> (endOfLine *> records hdr) + then (endOfInput $> []) <|> (endOfLine *> records hdr) else case runParser (convert hdr r) of Left msg -> fail $ "conversion error: " ++ msg Right val -> do - !vals <- (endOfInput *> pure []) <|> (endOfLine *> records hdr) + !vals <- (endOfInput $> []) <|> (endOfLine *> records hdr) return (val : vals) convert hdr = _parseNamedRecord . Types.toNamedRecord hdr diff --git a/src/Data/Csv/Incremental.hs b/src/Data/Csv/Incremental.hs --- a/src/Data/Csv/Incremental.hs +++ b/src/Data/Csv/Incremental.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns, CPP, DeriveFunctor, ScopedTypeVariables #-} +{-# LANGUAGE RoleAnnotations, KindSignatures #-} -- | This module allows for incremental decoding and encoding of CSV -- data. This is useful if you e.g. want to interleave I\/O with @@ -81,6 +82,7 @@ , NamedBuilder ) where +import Data.Kind (Type) import Control.Applicative ((<|>)) import qualified Data.Attoparsec.ByteString as A import Data.Attoparsec.ByteString.Char8 (endOfInput) @@ -95,7 +97,7 @@ toNamedRecord) import qualified Data.Csv.Conversion as Conversion import qualified Data.Csv.Encoding as Encoding -import Data.Csv.Encoding (EncodeOptions(..), Quoting(..), recordSep) +import Data.Csv.Encoding (EncodeOptions(..), Quoting(..), MissingFieldPolicy(..), recordSep) import Data.Csv.Parser import Data.Csv.Types import Data.Csv.Util (endOfLine) @@ -357,7 +359,8 @@ -- right-associative, 'foldr' style. Using '<>' to compose builders in -- a left-associative, `foldl'` style makes the building not be -- incremental. -newtype Builder a = Builder { +type role Builder nominal +newtype Builder (a :: Type) = Builder { runBuilder :: Quoting -> Word8 -> Bool -> Builder.Builder } @@ -396,7 +399,7 @@ Builder.toLazyByteString $ encHdr <> runNamedBuilder b hdr (encQuoting opts) (encDelimiter opts) - (encUseCrLf opts) + (encMissingFieldPolicy opts) (encUseCrLf opts) where encHdr | encIncludeHeader opts = @@ -413,7 +416,7 @@ Builder.toLazyByteString $ encHdr <> runNamedBuilder b hdr (encQuoting opts) - (encDelimiter opts) (encUseCrLf opts) + (encDelimiter opts) (encMissingFieldPolicy opts) (encUseCrLf opts) where hdr = Conversion.headerOrder (undefined :: a) @@ -425,8 +428,8 @@ -- | Encode a single named record. encodeNamedRecord :: ToNamedRecord a => a -> NamedBuilder a -encodeNamedRecord nr = NamedBuilder $ \ hdr qtng delim useCrLf -> - Encoding.encodeNamedRecord hdr qtng delim +encodeNamedRecord nr = NamedBuilder $ \ hdr qtng delim missingFieldPolicy useCrLf -> + Encoding.encodeNamedRecord hdr qtng delim missingFieldPolicy (Conversion.toNamedRecord nr) <> recordSep useCrLf -- | A builder for building the CSV data incrementally. Just like the @@ -434,15 +437,16 @@ -- right-associative, 'foldr' style. Using '<>' to compose builders in -- a left-associative, `foldl'` style makes the building not be -- incremental. -newtype NamedBuilder a = NamedBuilder { - runNamedBuilder :: Header -> Quoting -> Word8 -> Bool -> Builder.Builder +type role NamedBuilder nominal +newtype NamedBuilder (a :: Type) = NamedBuilder { + runNamedBuilder :: Header -> Quoting -> Word8 -> MissingFieldPolicy -> Bool -> Builder.Builder } -- | @since 0.5.0.0 instance Semigroup (NamedBuilder a) where NamedBuilder f <> NamedBuilder g = - NamedBuilder $ \ hdr qtng delim useCrlf -> - f hdr qtng delim useCrlf <> g hdr qtng delim useCrlf + NamedBuilder $ \ hdr qtng delim missing useCrlf -> + f hdr qtng delim missing useCrlf <> g hdr qtng delim missing useCrlf instance Monoid (NamedBuilder a) where mempty = NamedBuilder (\ _ _ _ _ -> mempty) diff --git a/src/Data/Csv/Parser.hs b/src/Data/Csv/Parser.hs --- a/src/Data/Csv/Parser.hs +++ b/src/Data/Csv/Parser.hs @@ -36,7 +36,7 @@ import Data.Word (Word8) import Data.Csv.Types -import Data.Csv.Util ((<$!>), blankLine, endOfLine, liftM2', cr, newline, doubleQuote, toStrict) +import Data.Csv.Util ((<$!>), blankLine, endOfLine, liftM2', cr, comma, newline, doubleQuote, toStrict) -- | Options that controls how data is decoded. These options can be -- used to e.g. decode tab-separated data instead of comma-separated @@ -57,7 +57,7 @@ -- | Decoding options for parsing CSV files. defaultDecodeOptions :: DecodeOptions defaultDecodeOptions = DecodeOptions - { decDelimiter = 44 -- comma + { decDelimiter = comma } -- | Parse a CSV file that does not include a header. @@ -179,8 +179,8 @@ h <- Z.takeWhile (/= doubleQuote) let rest = do start <- Z.take 2 - if (S.unsafeHead start == doubleQuote && - S.unsafeIndex start 1 == doubleQuote) + if S.unsafeHead start == doubleQuote && + S.unsafeIndex start 1 == doubleQuote then go (acc `mappend` byteString h `mappend` charUtf8 '"') else fail "invalid CSV escape sequence" done <- Z.atEnd diff --git a/src/Data/Csv/Streaming.hs b/src/Data/Csv/Streaming.hs --- a/src/Data/Csv/Streaming.hs +++ b/src/Data/Csv/Streaming.hs @@ -21,11 +21,13 @@ , HasHeader(..) , decode , decodeWith + , decodeWithP -- ** Name-based record conversion -- $namebased , decodeByName , decodeByNameWith + , decodeByNameWithP ) where import Control.DeepSeq (NFData(rnf)) @@ -36,8 +38,9 @@ import Prelude hiding (foldr) import Data.Csv.Conversion +import qualified Data.Csv.Conversion as Conversion import Data.Csv.Incremental hiding (decode, decodeByName, decodeByNameWith, - decodeWith) + decodeByNameWithP, decodeWith, decodeWithP) import qualified Data.Csv.Incremental as I import Data.Csv.Parser import Data.Csv.Types @@ -134,8 +137,19 @@ -- skipped -> BL.ByteString -- ^ CSV data -> Records a -decodeWith !opts hasHeader s0 = - go (BL.toChunks s0) (I.decodeWith opts hasHeader) +decodeWith = decodeWithP parseRecord + +-- | Like 'decodeWith', but lets you specify a parser function. +-- +-- @since 0.5.4.0 +decodeWithP :: (Record -> Conversion.Parser a) + -> DecodeOptions -- ^ Decoding options + -> HasHeader -- ^ Data contains header that should be + -- skipped + -> BL.ByteString -- ^ CSV data + -> Records a +decodeWithP _parseRecord !opts hasHeader s0 = + go (BL.toChunks s0) (I.decodeWithP _parseRecord opts hasHeader) where go ss (Done xs) = foldr Cons (Nil Nothing (BL.fromChunks ss)) xs go ss (Fail rest err) = Nil (Just err) (BL.fromChunks (rest:ss)) @@ -159,7 +173,18 @@ => DecodeOptions -- ^ Decoding options -> BL.ByteString -- ^ CSV data -> Either String (Header, Records a) -decodeByNameWith !opts s0 = go (BL.toChunks s0) (I.decodeByNameWith opts) +decodeByNameWith = decodeByNameWithP parseNamedRecord + +-- | Like 'decodeByNameWith', but lets you specify a parser function. +-- +-- @since 0.5.4.0 +decodeByNameWithP :: (NamedRecord -> Conversion.Parser a) + -- ^ Custom parser function + -> DecodeOptions -- ^ Decoding options + -> BL.ByteString -- ^ CSV data + -> Either String (Header, Records a) +decodeByNameWithP _parseNamedRecord !opts s0 = + go (BL.toChunks s0) (I.decodeByNameWithP _parseNamedRecord opts) where go ss (DoneH hdr p) = Right (hdr, go2 ss p) go ss (FailH rest err) = Left $ err ++ " at " ++ diff --git a/src/Data/Csv/Util.hs b/src/Data/Csv/Util.hs --- a/src/Data/Csv/Util.hs +++ b/src/Data/Csv/Util.hs @@ -8,10 +8,12 @@ , doubleQuote , newline , cr + , comma , toStrict ) where import Control.Applicative ((<|>)) +import Data.Functor ( ($>) ) import Data.Word (Word8) import Data.Attoparsec.ByteString.Char8 (string) import qualified Data.Attoparsec.ByteString as A @@ -31,15 +33,14 @@ -- | 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)) +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) + f x <$> b {-# INLINE liftM2' #-} @@ -47,10 +48,11 @@ -- return followed by a newline character @\"\\r\\n\"@, or a single -- carriage return @\'\\r\'@. endOfLine :: Parser () -endOfLine = (A.word8 newline *> return ()) <|> (string "\r\n" *> return ()) <|> (A.word8 cr *> return ()) +endOfLine = (A.word8 newline $> ()) <|> (string "\r\n" $> ()) <|> (A.word8 cr $> ()) {-# INLINE endOfLine #-} -doubleQuote, newline, cr :: Word8 +doubleQuote, newline, cr, comma :: Word8 doubleQuote = 34 newline = 10 cr = 13 +comma = 44 diff --git a/tests/UnitTests.hs b/tests/UnitTests.hs --- a/tests/UnitTests.hs +++ b/tests/UnitTests.hs @@ -383,9 +383,34 @@ cr = 13 dquote = 34 +customMissing :: Assertion +customMissing = encodeByNameWith encOpts hdr nrs @?= ex + where + encOpts = defaultEncodeOptions + { encMissingFieldPolicy = defaultMissingFieldPolicy + { mfpDefaultByColumn = HM.fromList + [ ("abc", "abc default") + , ("def", "def default") + , ("jkl", "ghi default") + ] + , mfpOtherwise = Just "fallback" + } + } + hdr = V.fromList ["abc", "def", "ghi"] + nrs :: [NamedRecord] + nrs = + [ HM.fromList [("abc", "123")] + , HM.fromList [("def", "456")] + , HM.fromList [("abc", "234"), ("def", "567")] + , HM.fromList [("abc", "234"), ("def", "567"), ("ghi", "890")] + , HM.fromList [] + ] + ex = "abc,def,ghi\r\n123,def default,fallback\r\nabc default,456,fallback\r\n234,567,fallback\r\n234,567,890\r\nabc default,def default,fallback\r\n" + customOptionsTests :: [TF.Test] customOptionsTests = [ testProperty "customDelim" customDelim + , testCase "customMissing" customMissing ] ------------------------------------------------------------------------