diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,11 @@ +## 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_ diff --git a/cassava.cabal b/cassava.cabal --- a/cassava.cabal +++ b/cassava.cabal @@ -1,6 +1,6 @@ cabal-version: 1.18 Name: cassava -Version: 0.5.4.1 +Version: 0.5.5.0 Synopsis: A CSV parsing and encoding library Description: { @@ -76,6 +76,7 @@ FlexibleContexts FlexibleInstances KindSignatures + RoleAnnotations MultiParamTypeClasses OverloadedStrings PolyKinds 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/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 ] ------------------------------------------------------------------------