diff --git a/CHANGES.md b/CHANGES.md new file mode 100644 --- /dev/null +++ b/CHANGES.md @@ -0,0 +1,100 @@ +## Version 0.5.1.0 + + * Add `FromField`/`ToField` instance for `Natural` (#141,#142) + * Add `FromField`/`ToField` instances for `Scientific` (#143,#144) + * Add support for modifying Generics-based instances (adding + `Options`, `defaultOptions`, `fieldLabelModifier`, + `genericParseRecord`, `genericToRecord`, `genericToNamedRecord`, + `genericHeaderOrder`) (#139,#140) + * Documentation improvements + +## Version 0.5.0.0 + +### Semantic changes + + * Don't unecessarily quote spaces with `QuoteMinimal` (#118,#122,#86) + * Fix semantics of `foldl'` (#102) + * Fix field error diagnostics being mapped to `endOfInput` in `Parser` monad. (#99) + * Honor `encIncludeHeader` in incremental API (#136) + +### Other changes + + * Support GHC 8.2.1 + * Use factored-out `Only` package + * Add `FromField`/`ToField` instance for `ShortText` + * Add `MonadFail` and `Semigroup` instance for `Parser` + * Add `Semigroup` instance for incremental CSV API `Builder` & `NamedBuilder` + * Port to `ByteString` builder & drop dependency on `blaze-builder` + +## Version 0.4.5.1 + + * Restore GHC 7.4 support (#124) + +## Version 0.4.5.0 + + * Support for GHC 8.0 added; support for GHC 7.4 dropped + + * Fix defect in `Foldable(foldr)` implementation failing to skip + unconvertable records (#102) + + * Documentation fixes + + * Maintainer changed + +## Version 0.4.4.0 + + * Added record instances for larger tuples. + + * Support attoparsec 0.13. + + * Add field instances for short bytestrings. + +## Version 0.4.3.0 + + * Documentation overhaul with more examples. + + * Add Data.Csv.Builder, a low-level bytestring builder API. + + * Add a high-level builder API to Data.Csv.Incremental. + + * Generalize the default FromNamedRecord/ToNamedRecord instances. + + * Improved support for deriving instances using GHC.Generics. + + * Added some control over quoting. + +## Version 0.4.2.4 + + * Support attoparsec 0.13. + +## Version 0.4.2.3 + + * Support GHC 7.10. + +## Version 0.4.2.2 + + * Support blaze-builder 0.4. + + * Make sure inlining doesn't prevent rules from firing. + + * Fix incorrect INLINE pragmas. + +## Version 0.4.2.1 + + * Support deepseq-1.4. + +## Version 0.4.2.0 + + * Minor performance improvements. + + * Add 8 and 9 tuple instances for From/ToRecord. + + * Support text-1.2. + +## Version 0.4.1.0 + + * Ignore whitespace when converting numeric fields. + + * Accept \r as a line terminator. + + * Support attoparsec-0.12. diff --git a/Cassava.cabal b/Cassava.cabal new file mode 100644 --- /dev/null +++ b/Cassava.cabal @@ -0,0 +1,180 @@ +cabal-version: 1.12 +Name: Cassava +Version: 0.5.1.0 +Synopsis: A CSV parsing and encoding library +Description: { + +@cassava@ is a library for parsing and encoding [RFC 4180](https://tools.ietf.org/html/rfc4180) +compliant [comma-separated values (CSV)](https://en.wikipedia.org/wiki/Comma-separated_values) data, +which is a textual line-oriented format commonly used for exchanging tabular data. +. +@cassava@'s API includes support for +. +- Index-based record-conversion +- Name-based record-conversion +- Typeclass directed conversion of fields and records +- Built-in field-conversion instances for standard types +- Customizable record-conversion instance derivation via GHC generics +- Low-level [bytestring](https://hackage.haskell.org/package/bytestring) builders (see "Data.Csv.Builder") +- Incremental decoding and encoding API (see "Data.Csv.Incremental") +- Streaming API for constant-space decoding (see "Data.Csv.Streaming") +. +Moreover, this library is designed to be easy to use; for instance, here's a +very simple example of encoding CSV data: +. +>>> Data.Csv.encode [("John",27),("Jane",28)] +"John,27\r\nJane,28\r\n" +. +Please refer to the documentation in "Data.Csv" and the included [README](#readme) for more usage examples. + +} +Homepage: https://github.com/hvr/cassava +License: BSD3 +License-file: LICENSE +Bug-reports: https://github.com/hvr/cassava/issues +Copyright: (c) 2012 Johan Tibell + (c) 2012 Bryan O'Sullivan + (c) 2011 MailRank, Inc. +Author: Johan Tibell +Maintainer: hvr@gnu.org +Category: Text, Web, CSV +Build-type: Simple +Extra-source-files: examples/*.hs, + CHANGES.md, + README.md +Tested-with: GHC ==8.2.1, GHC ==8.0.2, GHC ==8.0.1, GHC ==7.10.3, GHC ==7.8.4, GHC ==7.6.3, GHC ==7.4.2 + +---------------------------------------------------------------------------- + +source-repository head + type: git + location: https://github.com/hvr/cassava.git + +flag bytestring-LT-0_10_4 + description: [bytestring](https://hackage.haskell.org/haskell/package/bytestring) < 0.10.4 + +Library + default-language: Haskell2010 + other-extensions: + BangPatterns + CPP + DataKinds + DefaultSignatures + DeriveFunctor + FlexibleContexts + FlexibleInstances + KindSignatures + MultiParamTypeClasses + OverloadedStrings + PolyKinds + Rank2Types + ScopedTypeVariables + TypeOperators + UndecidableInstances + + if impl(ghc >= 8.0) + other-extensions: + DataKinds + PolyKinds + + Exposed-modules: + Data.Csv + Data.Csv.Builder + Data.Csv.Incremental + Data.Csv.Parser + Data.Csv.Streaming + + Other-modules: + Data.Csv.Conversion + Data.Csv.Conversion.Internal + Data.Csv.Encoding + Data.Csv.Types + Data.Csv.Util + + Build-depends: + array >= 0.4 && < 0.6, + attoparsec >= 0.11.3.0 && < 0.14, + base >= 4.5 && < 5, + bytestring >= 0.9.2 && < 0.11, + containers >= 0.4.2 && < 0.6, + deepseq >= 1.1 && < 1.5, + hashable < 1.3, + scientific >= 0.3.4.7 && < 0.4, + text < 1.3, + unordered-containers < 0.3, + vector >= 0.8 && < 0.13, + Only >= 0.1 && < 0.1.1 + + if flag(bytestring-LT-0_10_4) + build-depends: bytestring < 0.10.4 + , bytestring-builder >= 0.10.8 && < 0.11 + else + build-depends: bytestring >= 0.10.4 + , text-short == 0.1.* + + -- GHC.Generics lived in `ghc-prim` for GHC 7.2 & GHC 7.4 only + if impl(ghc < 7.6) + build-depends: ghc-prim == 0.2.* + + -- For Numeric.Natural + if impl(ghc < 7.10) + build-depends: nats >= 1 && < 1.2 + + -- https://ghc.haskell.org/trac/ghc/wiki/Migration/8.0#Recommendationsforforward-compatibility + if impl(ghc >= 8.0) + ghc-options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances + else + -- provide/emulate `Control.Monad.Fail` and `Data.Semigroups` API for pre-GHC8 + build-depends: fail == 4.9.*, semigroups == 0.18.* + + if impl(ghc >= 8.2) + ghc-options: -Wcpp-undef + + ghc-options: -Wall -O2 + +---------------------------------------------------------------------------- + +Test-suite unit-tests + default-language: Haskell2010 + + Type: exitcode-stdio-1.0 + Main-is: UnitTests.hs + -- dependencies with version constraints inherited via lib:cassava + Build-depends: attoparsec + , base + , bytestring + , Cassava + , hashable + , scientific + , text + , unordered-containers + , vector + -- extra dependencies not already used by lib:cassava + build-depends: HUnit < 1.7 + , QuickCheck == 2.10.* + , 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 + + -- GHC.Generics lived in `ghc-prim` for GHC 7.2 & GHC 7.4 only + if impl(ghc < 7.6) + build-depends: ghc-prim == 0.2.* + + -- For Numeric.Natural + if impl(ghc < 7.10) + build-depends: nats >= 1 && < 1.2 + + -- https://ghc.haskell.org/trac/ghc/wiki/Migration/8.0#Recommendationsforforward-compatibility + if impl(ghc >= 8.0) + ghc-options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances + else + -- provide/emulate `Control.Monad.Fail` and `Data.Semigroups` API for pre-GHC8 + build-depends: fail == 4.9.*, semigroups == 0.18.* + + if impl(ghc >= 8.2) + ghc-options: -Wcpp-undef + + ghc-options: -Wall diff --git a/Data/Csv.hs b/Data/Csv.hs new file mode 100644 --- /dev/null +++ b/Data/Csv.hs @@ -0,0 +1,406 @@ +-- | This module implements encoding and decoding +-- of [comma-separated values (CSV)](https://en.wikipedia.org/wiki/Comma-separated_values) +-- data. The implementation is [RFC 4180](https://tools.ietf.org/html/rfc4180) +-- 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). +module Data.Csv + ( + -- * Usage examples + -- $example + + -- ** Encoding and decoding custom data types + -- $example-instance + + -- *** Index-based record conversion + -- $example-indexed-instance + + -- *** Name-based record conversion + -- $example-named-instance + + -- * Treating CSV data as opaque byte strings + -- $generic-processing + + -- * Custom type conversions for fields + -- $customtypeconversions + + -- ** Dealing with bad data + -- $baddata + + -- * Encoding and decoding + -- $encoding + HasHeader(..) + , decode + , decodeByName + , encode + , encodeByName + , encodeDefaultOrderedByName + , DefaultOrdered(..) + + -- ** Encoding and decoding options + -- $options + , DecodeOptions(..) + , defaultDecodeOptions + , decodeWith + , decodeByNameWith + , EncodeOptions(..) + , Quoting(..) + , defaultEncodeOptions + , encodeWith + , encodeByNameWith + , encodeDefaultOrderedByNameWith + + -- * Core CSV types + , Csv + , Record + , Field + , Header + , Name + , NamedRecord + + -- * Type conversion + -- $typeconversion + + -- ** Index-based record conversion + -- $indexbased + , FromRecord(..) + , Parser + , runParser + , index + , (.!) + , unsafeIndex + , ToRecord(..) + , record + , Only(..) + + -- ** Name-based record conversion + -- $namebased + , FromNamedRecord(..) + , lookup + , (.:) + , ToNamedRecord(..) + , namedRecord + , namedField + , (.=) + , header + + -- ** Field conversion + -- $fieldconversion + , FromField(..) + , ToField(..) + + -- ** 'Generic' record conversion + -- $genericconversion + , genericParseRecord + , genericToRecord + , genericParseNamedRecord + , genericToNamedRecord + , genericHeaderOrder + + -- *** 'Generic' type conversion options + , Options + , defaultOptions + , fieldLabelModifier + + -- *** 'Generic' type conversion class name + -- $genericconversionclass + , GFromRecord + , GToRecord + , GFromNamedRecord + , GToNamedRecordHeader + ) where + +import Prelude hiding (lookup) + +import Data.Csv.Conversion +import Data.Csv.Encoding +import Data.Csv.Types + +-- $example +-- +-- Encoding standard Haskell types: +-- +-- >>> :set -XOverloadedStrings +-- >>> import Data.Text (Text) +-- >>> encode [("John" :: Text, 27 :: Int), ("Jane", 28)] +-- "John,27\r\nJane,28\r\n" +-- +-- Since we enabled the [-XOverloadedStrings extension](https://downloads.haskell.org/~ghc/8.2.1/docs/html/users_guide/glasgow_exts.html#overloaded-string-literals), +-- string literals are polymorphic and we have to supply a type +-- signature as the compiler couldn't deduce which string type (i.e. +-- 'String', 'Data.Text.Short.ShortText', or 'Data.Text.Text') we want to use. In most cases +-- type inference will infer the type from the context and you can +-- omit type signatures. +-- +-- Decoding standard Haskell types: +-- +-- >>> import Data.Vector (Vector) +-- >>> decode NoHeader "John,27\r\nJane,28\r\n" :: Either String (Vector (Text, Int)) +-- Right [("John",27),("Jane",28)] +-- +-- We pass 'NoHeader' as the first argument to indicate that the CSV +-- input data isn't preceded by a header. +-- +-- In practice, the return type of 'decode' rarely needs to be given, +-- as it can often be inferred from the context. + +-- $example-instance +-- +-- To encode and decode your own data types you need to defined +-- instances of either 'ToRecord' and 'FromRecord' or 'ToNamedRecord' +-- and 'FromNamedRecord'. The former is used for encoding/decoding +-- using the column index and the latter using the column name. +-- +-- There are two ways to to define these instances, either by manually +-- defining them or by using GHC generics to derive them automatically. + +-- $example-indexed-instance +-- +-- "GHC.Generics"-derived: +-- +-- > {-# LANGUAGE DeriveGeneric #-} +-- > +-- > import Data.Text (Text) +-- > import GHC.Generics (Generic) +-- > +-- > data Person = Person { name :: !Text , salary :: !Int } +-- > deriving (Generic, Show) +-- > +-- > instance FromRecord Person +-- > instance ToRecord Person +-- +-- Manually defined: +-- +-- > import Control.Monad (mzero) +-- > +-- > data Person = Person { name :: !Text , salary :: !Int } +-- > deriving (Show) +-- > +-- > instance FromRecord Person where +-- > parseRecord v +-- > | length v == 2 = Person <$> v .! 0 <*> v .! 1 +-- > | otherwise = mzero +-- > instance ToRecord Person where +-- > toRecord (Person name' age') = record [ +-- > toField name', toField age'] +-- +-- We can now use e.g. 'encode' and 'decode' to encode and decode our +-- data type. +-- +-- Encoding: +-- +-- >>> encode [Person ("John" :: Text) 27] +-- "John,27\r\n" +-- +-- Decoding: +-- +-- >>> decode NoHeader "John,27\r\n" :: Either String (Vector Person) +-- Right [Person {name = "John", salary = 27}] +-- + +-- $example-named-instance +-- +-- "GHC.Generics"-derived: +-- +-- > {-# LANGUAGE DeriveGeneric #-} +-- > +-- > import Data.Text (Text) +-- > import GHC.Generics (Generic) +-- > +-- > data Person = Person { name :: !Text , salary :: !Int } +-- > deriving (Generic, Show) +-- > +-- > instance FromNamedRecord Person +-- > instance ToNamedRecord Person +-- > instance DefaultOrdered Person +-- +-- Manually defined: +-- +-- > data Person = Person { name :: !Text , salary :: !Int } +-- > deriving (Show) +-- > +-- > instance FromNamedRecord Person where +-- > parseNamedRecord m = Person <$> m .: "name" <*> m .: "salary" +-- > instance ToNamedRecord Person where +-- > toNamedRecord (Person name salary) = namedRecord [ +-- > "name" .= name, "salary" .= salary] +-- > instance DefaultOrdered Person where +-- > headerOrder _ = header ["name", "salary"] +-- +-- We can now use e.g. 'encodeDefaultOrderedByName' (or 'encodeByName' +-- with an explicit header order) and 'decodeByName' to encode and +-- decode our data type. +-- +-- Encoding: +-- +-- >>> encodeDefaultOrderedByName [Person ("John" :: Text) 27] +-- "name,salary\r\nJohn,27\r\n" +-- +-- Decoding: +-- +-- >>> decodeByName "name,salary\r\nJohn,27\r\n" :: Either String (Header, Vector Person) +-- Right (["name","salary"],[Person {name = "John", salary = 27}]) +-- + +-- $generic-processing +-- +-- Sometimes you might want to work with a CSV file which contents is +-- unknown to you. For example, you might want remove the second +-- column of a file without knowing anything about its content. To +-- parse a CSV file to a generic representation, just convert each +-- record to a @'Vector' 'ByteString'@ value, like so: +-- +-- >>> import Data.ByteString (ByteString) +-- >>> decode NoHeader "John,27\r\nJane,28\r\n" :: Either String (Vector (Vector ByteString)) +-- Right [["John","27"],["Jane","28"]] +-- +-- As the example output above shows, all the fields are returned as +-- uninterpreted 'ByteString' values. + +-- $customtypeconversions +-- +-- Most of the time the existing 'FromField' and 'ToField' instances +-- do what you want. However, if you need to parse a different format +-- (e.g. hex) but use a type (e.g. 'Int') for which there's already a +-- 'FromField' instance, you need to use a @newtype@. Example: +-- +-- > newtype Hex = Hex Int +-- > +-- > parseHex :: ByteString -> Parser Int +-- > parseHex = ... +-- > +-- > instance FromField Hex where +-- > parseField s = Hex <$> parseHex s +-- +-- Other than giving an explicit type signature, you can pattern match +-- on the @newtype@ constructor to indicate which type conversion you +-- want to have the library use: +-- +-- > case decode NoHeader "0xff,0xaa\r\n0x11,0x22\r\n" of +-- > Left err -> putStrLn err +-- > Right v -> forM_ v $ \ (Hex val1, Hex val2) -> +-- > print (val1, val2) +-- +-- If a field might be in one several different formats, you can use a +-- newtype to normalize the result: +-- +-- > newtype HexOrDecimal = HexOrDecimal Int +-- > +-- > instance FromField DefaultToZero where +-- > parseField s = case runParser (parseField s :: Parser Hex) of +-- > Left err -> HexOrDecimal <$> parseField s -- Uses Int instance +-- > Right n -> pure $ HexOrDecimal n +-- +-- You can use the unit type, @()@, to ignore a column. The +-- 'parseField' method for @()@ doesn't look at the 'Field' and thus +-- always decodes successfully. Note that it lacks a corresponding +-- 'ToField' instance. Example: +-- +-- > case decode NoHeader "foo,1\r\nbar,22" of +-- > Left err -> putStrLn err +-- > Right v -> forM_ v $ \ ((), i) -> print (i :: Int) + +-- $baddata +-- +-- If your input might contain invalid fields, you can write a custom +-- 'FromField' instance to deal with them. Example: +-- +-- > newtype DefaultToZero = DefaultToZero Int +-- > +-- > instance FromField DefaultToZero where +-- > parseField s = case runParser (parseField s) of +-- > Left err -> pure $ DefaultToZero 0 +-- > Right n -> pure $ DefaultToZero n + +-- $encoding +-- +-- Encoding and decoding is a two step process. To encode a value, it +-- is first converted to a generic representation, using either +-- 'ToRecord' or 'ToNamedRecord'. The generic representation is then +-- encoded as CSV data. To decode a value the process is reversed and +-- either 'FromRecord' or 'FromNamedRecord' is used instead. Both +-- these steps are combined in the 'encode' and 'decode' functions. + +-- $typeconversion +-- +-- There are two ways to convert CSV records to and from and +-- user-defined data types: index-based conversion and name-based +-- conversion. + +-- $indexbased +-- +-- Index-based conversion lets you convert CSV records to and from +-- user-defined data types by referring to a field's position (its +-- index) in the record. The first column in a CSV file is given index +-- 0, the second index 1, and so on. + +-- $namebased +-- +-- Name-based conversion lets you convert CSV records to and from +-- user-defined data types by referring to a field's name. The names +-- of the fields are defined by the first line in the file, also known +-- as the header. Name-based conversion is more robust to changes in +-- the file structure e.g. to reording or addition of columns, but can +-- be a bit slower. + +-- $options +-- +-- These functions can be used to control how data is encoded and +-- decoded. For example, they can be used to encode data in a +-- tab-separated format instead of in a comma-separated format. + +-- $fieldconversion +-- +-- The 'FromField' and 'ToField' classes define how to convert between +-- 'Field's and values you care about (e.g. 'Int's). Most of the time +-- you don't need to write your own instances as the standard ones +-- cover most use cases. + +-- $genericconversion +-- +-- There may be times that you do not want to manually write out class +-- instances for record conversion, but you can't rely upon the +-- default instances (e.g. you can't create field names that match the +-- actual column names in expected data). +-- +-- For example, consider you have a type @MyType@ where you have +-- prefixed certain columns with an underscore, but in the actual data +-- they're not. You can then write: +-- +-- > myOptions :: Options +-- > myOptions = defaultOptions { fieldLabelmodifier = rmUnderscore } +-- > where +-- > rmUnderscore ('_':str) = str +-- > rmUnderscore str = str +-- > +-- > instance ToNamedRecord MyType where +-- > toNamedRecord = genericToNamedRecord myOptions +-- > +-- > instance FromNamedRecord MyType where +-- > parseNamedRecord = genericParseNamedRecord myOptions +-- > +-- > instance DefaultOrdered MyType where +-- > headerOrder = genericHeaderOrder myOptions + +-- $genericconversionclass +-- +-- __NOTE__: Only the class /names/ are exposed in order to make it possible to write type signatures referring to these classes + +-- $setup +-- >>> :set -XOverloadedStrings -XDeriveGeneric +-- >>> import Data.Text (Text) +-- >>> import Data.Vector (Vector) +-- >>> import GHC.Generics (Generic) +-- >>> +-- >>> data Person = Person { name :: !Text, salary :: !Int } deriving (Generic, Show) +-- >>> instance FromRecord Person +-- >>> instance ToRecord Person +-- >>> instance FromNamedRecord Person +-- >>> instance ToNamedRecord Person +-- >>> instance DefaultOrdered Person diff --git a/Data/Csv/Builder.hs b/Data/Csv/Builder.hs new file mode 100644 --- /dev/null +++ b/Data/Csv/Builder.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Low-level bytestring builders. Most users want to use the more +-- type-safe "Data.Csv.Incremental" module instead. +module Data.Csv.Builder + ( + -- * Encoding single records and headers + encodeHeader + , encodeRecord + , encodeNamedRecord + , encodeDefaultOrderedNamedRecord + -- ** Encoding options + , encodeHeaderWith + , encodeRecordWith + , encodeNamedRecordWith + , encodeDefaultOrderedNamedRecordWith + ) where + +import Data.Monoid + +import Data.ByteString.Builder as Builder +import Data.Csv.Conversion +import qualified Data.Csv.Encoding as Encoding +import Data.Csv.Encoding (EncodeOptions(..)) +import Data.Csv.Types hiding (toNamedRecord) + +-- | Encode a header. +encodeHeader :: Header -> Builder.Builder +encodeHeader = encodeRecord + +-- | Encode a single record. +encodeRecord :: ToRecord a => a -> Builder.Builder +encodeRecord = encodeRecordWith Encoding.defaultEncodeOptions + +-- | Encode a single named record, given the field order. +encodeNamedRecord :: ToNamedRecord a => + Header -> a -> Builder.Builder +encodeNamedRecord = encodeNamedRecordWith Encoding.defaultEncodeOptions + +-- | Encode a single named record, using the default field order. +encodeDefaultOrderedNamedRecord :: + (DefaultOrdered a, ToNamedRecord a) => a -> Builder.Builder +encodeDefaultOrderedNamedRecord = + encodeDefaultOrderedNamedRecordWith Encoding.defaultEncodeOptions + +-- | Like 'encodeHeader', but lets you customize how the CSV data is +-- encoded. +encodeHeaderWith :: EncodeOptions -> Header -> Builder.Builder +encodeHeaderWith = encodeRecordWith + +-- | Like 'encodeRecord', but lets you customize how the CSV data is +-- encoded. +encodeRecordWith :: ToRecord a => EncodeOptions -> a -> Builder.Builder +encodeRecordWith opts r = + Encoding.encodeRecord (encQuoting opts) (encDelimiter opts) (toRecord r) + <> Encoding.recordSep (encUseCrLf opts) + +-- | Like 'encodeNamedRecord', but lets you customize how the CSV data +-- is encoded. +encodeNamedRecordWith :: ToNamedRecord a => + EncodeOptions -> Header -> a -> Builder.Builder +encodeNamedRecordWith opts hdr nr = + Encoding.encodeNamedRecord hdr (encQuoting opts) (encDelimiter opts) + (toNamedRecord nr) <> Encoding.recordSep (encUseCrLf opts) + +-- | Like 'encodeDefaultOrderedNamedRecord', but lets you customize +-- how the CSV data is encoded. +encodeDefaultOrderedNamedRecordWith :: + forall a. (DefaultOrdered a, ToNamedRecord a) => + EncodeOptions -> a -> Builder.Builder +encodeDefaultOrderedNamedRecordWith opts = + encodeNamedRecordWith opts (headerOrder (undefined :: a)) diff --git a/Data/Csv/Conversion.hs b/Data/Csv/Conversion.hs new file mode 100644 --- /dev/null +++ b/Data/Csv/Conversion.hs @@ -0,0 +1,1388 @@ +{-# LANGUAGE + BangPatterns, + CPP, + DefaultSignatures, + FlexibleContexts, + FlexibleInstances, + KindSignatures, + MultiParamTypeClasses, + OverloadedStrings, + Rank2Types, + ScopedTypeVariables, + TypeOperators, + UndecidableInstances + #-} + +#if __GLASGOW_HASKELL__ >= 800 +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +#endif + +#if !MIN_VERSION_bytestring(0,10,4) +# define MIN_VERSION_text_short(a,b,c) 0 +#endif + +#if !defined(MIN_VERSION_text_short) +# error **INVARIANT BROKEN** Detected invalid combination of `text-short` and `bytestring` versions. Please verify the `pre-bytestring-0.10-4` flag-logic in the .cabal file wasn't elided. +#endif + +module Data.Csv.Conversion + ( + -- * Type conversion + Only(..) + , FromRecord(..) + , FromNamedRecord(..) + , ToNamedRecord(..) + , DefaultOrdered(..) + , FromField(..) + , ToRecord(..) + , ToField(..) + + -- ** Generic type conversion + , genericParseRecord + , genericToRecord + , genericParseNamedRecord + , genericToNamedRecord + , genericHeaderOrder + + -- *** Generic type conversion options + , Options + , defaultOptions + , fieldLabelModifier + + -- *** Generic type conversion class names + , GFromRecord + , GToRecord + , GFromNamedRecord + , GToNamedRecordHeader + + -- * Parser + , Parser + , runParser + + -- * Accessors + , index + , (.!) + , unsafeIndex + , lookup + , (.:) + , namedField + , (.=) + , record + , namedRecord + , header + ) where + +import Control.Applicative (Alternative, (<|>), empty) +import Control.Monad (MonadPlus, mplus, mzero) +import qualified Control.Monad.Fail as Fail +import Data.Attoparsec.ByteString.Char8 (double) +import qualified Data.Attoparsec.ByteString.Char8 as A8 +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as B8 +import qualified Data.ByteString.Lazy as L +#if MIN_VERSION_bytestring(0,10,4) +import qualified Data.ByteString.Short as SBS +#endif +import Data.List (intercalate) +import Data.Hashable (Hashable) +import qualified Data.HashMap.Lazy as HM +import Data.Int (Int8, Int16, Int32, Int64) +import qualified Data.IntMap as IM +import qualified Data.Map as M +import Data.Scientific (Scientific) +import Data.Semigroup (Semigroup, (<>)) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.Lazy as LT +import qualified Data.Text.Lazy.Encoding as LT +#if MIN_VERSION_text_short(0,1,0) +import qualified Data.Text.Short as T.S +#endif +import Data.Tuple.Only (Only(..)) +import Data.Vector (Vector, (!)) +import qualified Data.Vector as V +import qualified Data.Vector.Unboxed as U +import Data.Word (Word8, Word16, Word32, Word64) +import GHC.Float (double2Float) +import GHC.Generics +import Numeric.Natural +import Prelude hiding (lookup, takeWhile) + +import Data.Csv.Conversion.Internal +import Data.Csv.Types + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative (Applicative, (<$>), (<*>), (<*), (*>), pure) +import Data.Monoid (Monoid, mappend, mempty) +import Data.Traversable (traverse) +import Data.Word (Word) +#endif + +------------------------------------------------------------------------ +-- bytestring compatibility + +toStrict :: L.ByteString -> B.ByteString +fromStrict :: B.ByteString -> L.ByteString +#if MIN_VERSION_bytestring(0,10,0) +toStrict = L.toStrict +fromStrict = L.fromStrict +#else +toStrict = B.concat . L.toChunks +fromStrict = L.fromChunks . (:[]) +#endif +{-# INLINE toStrict #-} +{-# INLINE fromStrict #-} + +------------------------------------------------------------------------ +-- Type conversion + +------------------------------------------------------------------------ +-- Index-based conversion + +-- | Options to customise how to generically encode\/decode your +-- datatype to\/from CSV. +-- +-- @since 0.5.1.0 +newtype Options = Options + { fieldLabelModifier :: String -> String + -- ^ How to convert Haskell field labels to CSV fields. + -- + -- @since 0.5.1.0 + } + +instance Show Options where + show (Options fld) = + "Options {" + ++ intercalate "," + [ "fieldLabelModifier =~ " ++ show sampleField ++ " -> " ++ show (fld sampleField) + ] + ++ "}" + where + sampleField = "_column_A" + +-- | Default conversion options. +-- +-- @ +-- Options +-- { 'fieldLabelModifier' = id +-- } +-- @ +-- +-- @since 0.5.1.0 +defaultOptions :: Options +defaultOptions = Options + { fieldLabelModifier = id + } + +-- | A type that can be converted from a single CSV record, with the +-- possibility of failure. +-- +-- When writing an instance, use 'empty', 'mzero', or 'fail' to make a +-- conversion fail, e.g. if a 'Record' has the wrong number of +-- columns. +-- +-- Given this example data: +-- +-- > John,56 +-- > Jane,55 +-- +-- here's an example type and instance: +-- +-- > data Person = Person { name :: !Text, age :: !Int } +-- > +-- > instance FromRecord Person where +-- > parseRecord v +-- > | length v == 2 = Person <$> +-- > v .! 0 <*> +-- > v .! 1 +-- > | otherwise = mzero +class FromRecord a where + parseRecord :: Record -> Parser a + + default parseRecord :: (Generic a, GFromRecord (Rep a)) => Record -> Parser a + parseRecord = genericParseRecord defaultOptions + +-- | A configurable CSV record parser. This function applied to +-- 'defaultOptions' is used as the default for 'parseRecord' when the +-- type is an instance of 'Generic'. +-- +-- @since 0.5.1.0 +genericParseRecord :: (Generic a, GFromRecord (Rep a)) => Options -> Record -> Parser a +genericParseRecord opts r = to <$> gparseRecord opts r + +-- | A type that can be converted to a single CSV record. +-- +-- An example type and instance: +-- +-- > data Person = Person { name :: !Text, age :: !Int } +-- > +-- > instance ToRecord Person where +-- > toRecord (Person name age) = record [ +-- > toField name, toField age] +-- +-- Outputs data on this form: +-- +-- > John,56 +-- > Jane,55 +class ToRecord a where + -- | Convert a value to a record. + toRecord :: a -> Record + + default toRecord :: (Generic a, GToRecord (Rep a) Field) => a -> Record + toRecord = genericToRecord defaultOptions + +-- | A configurable CSV record creator. This function applied to +-- 'defaultOptions' is used as the default for 'toRecord' when the +-- type is an instance of 'Generic'. +-- +-- @since 0.5.1.0 +genericToRecord :: (Generic a, GToRecord (Rep a) Field) => Options -> a -> Record +genericToRecord opts = V.fromList . gtoRecord opts . from + +instance FromField a => FromRecord (Only a) where + parseRecord v + | n == 1 = Only <$> unsafeIndex v 0 + | otherwise = lengthMismatch 1 v + where + n = V.length v + +-- TODO: Check if we want all toRecord conversions to be stricter. + +instance ToField a => ToRecord (Only a) where + toRecord = V.singleton . toField . fromOnly + +instance (FromField a, FromField b) => FromRecord (a, b) where + parseRecord v + | n == 2 = (,) <$> unsafeIndex v 0 + <*> unsafeIndex v 1 + | otherwise = lengthMismatch 2 v + where + n = V.length v + +instance (ToField a, ToField b) => ToRecord (a, b) where + toRecord (a, b) = V.fromList [toField a, toField b] + +instance (FromField a, FromField b, FromField c) => FromRecord (a, b, c) where + parseRecord v + | n == 3 = (,,) <$> unsafeIndex v 0 + <*> unsafeIndex v 1 + <*> unsafeIndex v 2 + | otherwise = lengthMismatch 3 v + where + n = V.length v + +instance (ToField a, ToField b, ToField c) => + ToRecord (a, b, c) where + toRecord (a, b, c) = V.fromList [toField a, toField b, toField c] + +instance (FromField a, FromField b, FromField c, FromField d) => + FromRecord (a, b, c, d) where + parseRecord v + | n == 4 = (,,,) <$> unsafeIndex v 0 + <*> unsafeIndex v 1 + <*> unsafeIndex v 2 + <*> unsafeIndex v 3 + | otherwise = lengthMismatch 4 v + where + n = V.length v + +instance (ToField a, ToField b, ToField c, ToField d) => + ToRecord (a, b, c, d) where + toRecord (a, b, c, d) = V.fromList [ + toField a, toField b, toField c, toField d] + +instance (FromField a, FromField b, FromField c, FromField d, FromField e) => + FromRecord (a, b, c, d, e) where + parseRecord v + | n == 5 = (,,,,) <$> unsafeIndex v 0 + <*> unsafeIndex v 1 + <*> unsafeIndex v 2 + <*> unsafeIndex v 3 + <*> unsafeIndex v 4 + | otherwise = lengthMismatch 5 v + where + n = V.length v + +instance (ToField a, ToField b, ToField c, ToField d, ToField e) => + ToRecord (a, b, c, d, e) where + toRecord (a, b, c, d, e) = V.fromList [ + toField a, toField b, toField c, toField d, toField e] + +instance (FromField a, FromField b, FromField c, FromField d, FromField e, + FromField f) => + FromRecord (a, b, c, d, e, f) where + parseRecord v + | n == 6 = (,,,,,) <$> unsafeIndex v 0 + <*> unsafeIndex v 1 + <*> unsafeIndex v 2 + <*> unsafeIndex v 3 + <*> unsafeIndex v 4 + <*> unsafeIndex v 5 + | otherwise = lengthMismatch 6 v + where + n = V.length v + +instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f) => + ToRecord (a, b, c, d, e, f) where + toRecord (a, b, c, d, e, f) = V.fromList [ + toField a, toField b, toField c, toField d, toField e, toField f] + +instance (FromField a, FromField b, FromField c, FromField d, FromField e, + FromField f, FromField g) => + FromRecord (a, b, c, d, e, f, g) where + parseRecord v + | n == 7 = (,,,,,,) <$> unsafeIndex v 0 + <*> unsafeIndex v 1 + <*> unsafeIndex v 2 + <*> unsafeIndex v 3 + <*> unsafeIndex v 4 + <*> unsafeIndex v 5 + <*> unsafeIndex v 6 + | otherwise = lengthMismatch 7 v + where + n = V.length v + +instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, + ToField g) => + ToRecord (a, b, c, d, e, f, g) where + toRecord (a, b, c, d, e, f, g) = V.fromList [ + toField a, toField b, toField c, toField d, toField e, toField f, + toField g] + +instance (FromField a, FromField b, FromField c, FromField d, FromField e, + FromField f, FromField g, FromField h) => + FromRecord (a, b, c, d, e, f, g, h) where + parseRecord v + | n == 8 = (,,,,,,,) <$> unsafeIndex v 0 + <*> unsafeIndex v 1 + <*> unsafeIndex v 2 + <*> unsafeIndex v 3 + <*> unsafeIndex v 4 + <*> unsafeIndex v 5 + <*> unsafeIndex v 6 + <*> unsafeIndex v 7 + | otherwise = lengthMismatch 8 v + where + n = V.length v + +instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, + ToField g, ToField h) => + ToRecord (a, b, c, d, e, f, g, h) where + toRecord (a, b, c, d, e, f, g, h) = V.fromList [ + toField a, toField b, toField c, toField d, toField e, toField f, + toField g, toField h] + +instance (FromField a, FromField b, FromField c, FromField d, FromField e, + FromField f, FromField g, FromField h, FromField i) => + FromRecord (a, b, c, d, e, f, g, h, i) where + parseRecord v + | n == 9 = (,,,,,,,,) <$> unsafeIndex v 0 + <*> unsafeIndex v 1 + <*> unsafeIndex v 2 + <*> unsafeIndex v 3 + <*> unsafeIndex v 4 + <*> unsafeIndex v 5 + <*> unsafeIndex v 6 + <*> unsafeIndex v 7 + <*> unsafeIndex v 8 + | otherwise = lengthMismatch 9 v + where + n = V.length v + +instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, + ToField g, ToField h, ToField i) => + ToRecord (a, b, c, d, e, f, g, h, i) where + toRecord (a, b, c, d, e, f, g, h, i) = V.fromList [ + toField a, toField b, toField c, toField d, toField e, toField f, + toField g, toField h, toField i] + +instance (FromField a, FromField b, FromField c, FromField d, FromField e, + FromField f, FromField g, FromField h, FromField i, FromField j) => + FromRecord (a, b, c, d, e, f, g, h, i, j) where + parseRecord v + | n == 10 = (,,,,,,,,,) <$> unsafeIndex v 0 + <*> unsafeIndex v 1 + <*> unsafeIndex v 2 + <*> unsafeIndex v 3 + <*> unsafeIndex v 4 + <*> unsafeIndex v 5 + <*> unsafeIndex v 6 + <*> unsafeIndex v 7 + <*> unsafeIndex v 8 + <*> unsafeIndex v 9 + | otherwise = lengthMismatch 10 v + where + n = V.length v + +instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, + ToField g, ToField h, ToField i, ToField j) => + ToRecord (a, b, c, d, e, f, g, h, i, j) where + toRecord (a, b, c, d, e, f, g, h, i, j) = V.fromList [ + toField a, toField b, toField c, toField d, toField e, toField f, + toField g, toField h, toField i, toField j] + +instance (FromField a, FromField b, FromField c, FromField d, FromField e, + FromField f, FromField g, FromField h, FromField i, FromField j, + FromField k) => + FromRecord (a, b, c, d, e, f, g, h, i, j, k) where + parseRecord v + | n == 11 = (,,,,,,,,,,) <$> unsafeIndex v 0 + <*> unsafeIndex v 1 + <*> unsafeIndex v 2 + <*> unsafeIndex v 3 + <*> unsafeIndex v 4 + <*> unsafeIndex v 5 + <*> unsafeIndex v 6 + <*> unsafeIndex v 7 + <*> unsafeIndex v 8 + <*> unsafeIndex v 9 + <*> unsafeIndex v 10 + | otherwise = lengthMismatch 11 v + where + n = V.length v + +instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, + ToField g, ToField h, ToField i, ToField j, ToField k) => + ToRecord (a, b, c, d, e, f, g, h, i, j, k) where + toRecord (a, b, c, d, e, f, g, h, i, j, k) = V.fromList [ + toField a, toField b, toField c, toField d, toField e, toField f, + toField g, toField h, toField i, toField j, toField k] + +instance (FromField a, FromField b, FromField c, FromField d, FromField e, + FromField f, FromField g, FromField h, FromField i, FromField j, + FromField k, FromField l) => + FromRecord (a, b, c, d, e, f, g, h, i, j, k, l) where + parseRecord v + | n == 12 = (,,,,,,,,,,,) <$> unsafeIndex v 0 + <*> unsafeIndex v 1 + <*> unsafeIndex v 2 + <*> unsafeIndex v 3 + <*> unsafeIndex v 4 + <*> unsafeIndex v 5 + <*> unsafeIndex v 6 + <*> unsafeIndex v 7 + <*> unsafeIndex v 8 + <*> unsafeIndex v 9 + <*> unsafeIndex v 10 + <*> unsafeIndex v 11 + | otherwise = lengthMismatch 12 v + where + n = V.length v + +instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, + ToField g, ToField h, ToField i, ToField j, ToField k, ToField l) => + ToRecord (a, b, c, d, e, f, g, h, i, j, k, l) where + toRecord (a, b, c, d, e, f, g, h, i, j, k, l) = V.fromList [ + toField a, toField b, toField c, toField d, toField e, toField f, + toField g, toField h, toField i, toField j, toField k, toField l] + +instance (FromField a, FromField b, FromField c, FromField d, FromField e, + FromField f, FromField g, FromField h, FromField i, FromField j, + FromField k, FromField l, FromField m) => + FromRecord (a, b, c, d, e, f, g, h, i, j, k, l, m) where + parseRecord v + | n == 13 = (,,,,,,,,,,,,) <$> unsafeIndex v 0 + <*> unsafeIndex v 1 + <*> unsafeIndex v 2 + <*> unsafeIndex v 3 + <*> unsafeIndex v 4 + <*> unsafeIndex v 5 + <*> unsafeIndex v 6 + <*> unsafeIndex v 7 + <*> unsafeIndex v 8 + <*> unsafeIndex v 9 + <*> unsafeIndex v 10 + <*> unsafeIndex v 11 + <*> unsafeIndex v 12 + | otherwise = lengthMismatch 13 v + where + n = V.length v + +instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, + ToField g, ToField h, ToField i, ToField j, ToField k, ToField l, + ToField m) => + ToRecord (a, b, c, d, e, f, g, h, i, j, k, l, m) where + toRecord (a, b, c, d, e, f, g, h, i, j, k, l, m) = V.fromList [ + toField a, toField b, toField c, toField d, toField e, toField f, + toField g, toField h, toField i, toField j, toField k, toField l, + toField m] + +instance (FromField a, FromField b, FromField c, FromField d, FromField e, + FromField f, FromField g, FromField h, FromField i, FromField j, + FromField k, FromField l, FromField m, FromField n) => + FromRecord (a, b, c, d, e, f, g, h, i, j, k, l, m, n) where + parseRecord v + | n == 14 = (,,,,,,,,,,,,,) <$> unsafeIndex v 0 + <*> unsafeIndex v 1 + <*> unsafeIndex v 2 + <*> unsafeIndex v 3 + <*> unsafeIndex v 4 + <*> unsafeIndex v 5 + <*> unsafeIndex v 6 + <*> unsafeIndex v 7 + <*> unsafeIndex v 8 + <*> unsafeIndex v 9 + <*> unsafeIndex v 10 + <*> unsafeIndex v 11 + <*> unsafeIndex v 12 + <*> unsafeIndex v 13 + | otherwise = lengthMismatch 14 v + where + n = V.length v + +instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, + ToField g, ToField h, ToField i, ToField j, ToField k, ToField l, + ToField m, ToField n) => + ToRecord (a, b, c, d, e, f, g, h, i, j, k, l, m, n) where + toRecord (a, b, c, d, e, f, g, h, i, j, k, l, m, n) = V.fromList [ + toField a, toField b, toField c, toField d, toField e, toField f, + toField g, toField h, toField i, toField j, toField k, toField l, + toField m, toField n] + +instance (FromField a, FromField b, FromField c, FromField d, FromField e, + FromField f, FromField g, FromField h, FromField i, FromField j, + FromField k, FromField l, FromField m, FromField n, FromField o) => + FromRecord (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) where + parseRecord v + | n == 15 = (,,,,,,,,,,,,,,) <$> unsafeIndex v 0 + <*> unsafeIndex v 1 + <*> unsafeIndex v 2 + <*> unsafeIndex v 3 + <*> unsafeIndex v 4 + <*> unsafeIndex v 5 + <*> unsafeIndex v 6 + <*> unsafeIndex v 7 + <*> unsafeIndex v 8 + <*> unsafeIndex v 9 + <*> unsafeIndex v 10 + <*> unsafeIndex v 11 + <*> unsafeIndex v 12 + <*> unsafeIndex v 13 + <*> unsafeIndex v 14 + | otherwise = lengthMismatch 15 v + where + n = V.length v + +instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, + ToField g, ToField h, ToField i, ToField j, ToField k, ToField l, + ToField m, ToField n, ToField o) => + ToRecord (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) where + toRecord (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) = V.fromList [ + toField a, toField b, toField c, toField d, toField e, toField f, + toField g, toField h, toField i, toField j, toField k, toField l, + toField m, toField n, toField o] + +lengthMismatch :: Int -> Record -> Parser a +lengthMismatch expected v = + fail $ "cannot unpack array of length " ++ + show n ++ " into a " ++ desired ++ ". Input record: " ++ + show v + where + n = V.length v + desired | expected == 1 = "Only" + | expected == 2 = "pair" + | otherwise = show expected ++ "-tuple" + +instance FromField a => FromRecord [a] where + parseRecord = traverse parseField . V.toList + +instance ToField a => ToRecord [a] where + toRecord = V.fromList . map toField + +instance FromField a => FromRecord (V.Vector a) where + parseRecord = traverse parseField + +instance ToField a => ToRecord (Vector a) where + toRecord = V.map toField + +instance (FromField a, U.Unbox a) => FromRecord (U.Vector a) where + parseRecord = fmap U.convert . traverse parseField + +instance (ToField a, U.Unbox a) => ToRecord (U.Vector a) where + toRecord = V.map toField . U.convert + +------------------------------------------------------------------------ +-- Name-based conversion + +-- | A type that can be converted from a single CSV record, with the +-- possibility of failure. +-- +-- When writing an instance, use 'empty', 'mzero', or 'fail' to make a +-- conversion fail, e.g. if a 'Record' has the wrong number of +-- columns. +-- +-- Given this example data: +-- +-- > name,age +-- > John,56 +-- > Jane,55 +-- +-- here's an example type and instance: +-- +-- > {-# LANGUAGE OverloadedStrings #-} +-- > +-- > data Person = Person { name :: !Text, age :: !Int } +-- > +-- > instance FromNamedRecord Person where +-- > parseNamedRecord m = Person <$> +-- > m .: "name" <*> +-- > m .: "age" +-- +-- Note the use of the @OverloadedStrings@ language extension which +-- enables 'B8.ByteString' values to be written as string literals. +class FromNamedRecord a where + parseNamedRecord :: NamedRecord -> Parser a + + default parseNamedRecord :: (Generic a, GFromNamedRecord (Rep a)) => NamedRecord -> Parser a + parseNamedRecord = genericParseNamedRecord defaultOptions + +-- | A configurable CSV named record parser. This function applied to +-- 'defaultOptions' is used as the default for 'parseNamedRecord' +-- when the type is an instance of 'Generic'. +-- +-- @since 0.5.1.0 +genericParseNamedRecord :: (Generic a, GFromNamedRecord (Rep a)) => Options -> NamedRecord -> Parser a +genericParseNamedRecord opts r = to <$> gparseNamedRecord opts r + +-- | A type that can be converted to a single CSV record. +-- +-- An example type and instance: +-- +-- > data Person = Person { name :: !Text, age :: !Int } +-- > +-- > instance ToNamedRecord Person where +-- > toNamedRecord (Person name age) = namedRecord [ +-- > "name" .= name, "age" .= age] +class ToNamedRecord a where + -- | Convert a value to a named record. + toNamedRecord :: a -> NamedRecord + + default toNamedRecord :: + (Generic a, GToRecord (Rep a) (B.ByteString, B.ByteString)) => + a -> NamedRecord + toNamedRecord = genericToNamedRecord defaultOptions + +-- | A configurable CSV named record creator. This function applied +-- to 'defaultOptions' is used as the default for 'toNamedRecord' when +-- the type is an instance of 'Generic'. +-- +-- @since 0.5.1.0 +genericToNamedRecord :: (Generic a, GToRecord (Rep a) (B.ByteString, B.ByteString)) + => Options -> a -> NamedRecord +genericToNamedRecord opts = namedRecord . gtoRecord opts . from + +-- | A type that has a default field order when converted to CSV. This +-- class lets you specify how to get the headers to use for a record +-- type that's an instance of 'ToNamedRecord'. +-- +-- To derive an instance, the type is required to only have one +-- constructor and that constructor must have named fields (also known +-- as selectors) for all fields. +-- +-- Right: @data Foo = Foo { foo :: !Int }@ +-- +-- Wrong: @data Bar = Bar Int@ +-- +-- If you try to derive an instance using GHC generics and your type +-- doesn't have named fields, you will get an error along the lines +-- of: +-- +-- > :9:10: +-- > No instance for (DefaultOrdered (M1 S NoSelector (K1 R Char) ())) +-- > arising from a use of ‘Data.Csv.Conversion.$gdmheader’ +-- > In the expression: Data.Csv.Conversion.$gdmheader +-- > In an equation for ‘header’: +-- > header = Data.Csv.Conversion.$gdmheader +-- > In the instance declaration for ‘DefaultOrdered Foo’ +-- +class DefaultOrdered a where + -- | The header order for this record. Should include the names + -- used in the 'NamedRecord' returned by 'toNamedRecord'. Pass + -- 'undefined' as the argument, together with a type annotation + -- e.g. @'headerOrder' ('undefined' :: MyRecord)@. + headerOrder :: a -> Header -- TODO: Add Generic implementation + + default headerOrder :: + (Generic a, GToNamedRecordHeader (Rep a)) => + a -> Header + headerOrder = genericHeaderOrder defaultOptions + +-- | A configurable CSV header record generator. This function +-- applied to 'defaultOptions' is used as the default for +-- 'headerOrder' when the type is an instance of 'Generic'. +-- +-- @since 0.5.1.0 +genericHeaderOrder :: (Generic a, GToNamedRecordHeader (Rep a)) + => Options -> a -> Header +genericHeaderOrder opts = V.fromList. gtoNamedRecordHeader opts . from + +instance (FromField a, FromField b, Ord a) => FromNamedRecord (M.Map a b) where + parseNamedRecord m = M.fromList <$> + (traverse parseBoth $ HM.toList m) + +instance (ToField a, ToField b, Ord a) => ToNamedRecord (M.Map a b) where + toNamedRecord = HM.fromList . map (\ (k, v) -> (toField k, toField v)) . M.toList + +instance (Eq a, FromField a, FromField b, Hashable a) => FromNamedRecord (HM.HashMap a b) where + parseNamedRecord m = HM.fromList <$> + (traverse parseBoth $ HM.toList m) + +instance (Eq a, ToField a, ToField b, Hashable a) => ToNamedRecord (HM.HashMap a b) where + toNamedRecord = HM.fromList . map (\ (k, v) -> (toField k, toField v)) . HM.toList + +parseBoth :: (FromField a, FromField b) => (Field, Field) -> Parser (a, b) +parseBoth (k, v) = (,) <$> parseField k <*> parseField v + +------------------------------------------------------------------------ +-- Individual field conversion + +-- | A type that can be converted from a single CSV field, with the +-- possibility of failure. +-- +-- When writing an instance, use 'empty', 'mzero', or 'fail' to make a +-- conversion fail, e.g. if a 'Field' can't be converted to the given +-- type. +-- +-- Example type and instance: +-- +-- > {-# LANGUAGE OverloadedStrings #-} +-- > +-- > data Color = Red | Green | Blue +-- > +-- > instance FromField Color where +-- > parseField s +-- > | s == "R" = pure Red +-- > | s == "G" = pure Green +-- > | s == "B" = pure Blue +-- > | otherwise = mzero +class FromField a where + parseField :: Field -> Parser a + +-- | A type that can be converted to a single CSV field. +-- +-- Example type and instance: +-- +-- > {-# LANGUAGE OverloadedStrings #-} +-- > +-- > data Color = Red | Green | Blue +-- > +-- > instance ToField Color where +-- > toField Red = "R" +-- > toField Green = "G" +-- > toField Blue = "B" +class ToField a where + toField :: a -> Field + +-- | 'Nothing' if the 'Field' is 'B.empty', 'Just' otherwise. +instance FromField a => FromField (Maybe a) where + parseField s + | B.null s = pure Nothing + | otherwise = Just <$> parseField s + {-# INLINE parseField #-} + +-- | 'Nothing' is encoded as an 'B.empty' field. +instance ToField a => ToField (Maybe a) where + toField = maybe B.empty toField + {-# INLINE toField #-} + +-- | @'Left' field@ if conversion failed, 'Right' otherwise. +instance FromField a => FromField (Either Field a) where + parseField s = case runParser (parseField s) of + Left _ -> pure $ Left s + Right a -> pure $ Right a + {-# INLINE parseField #-} + +-- | Ignores the 'Field'. Always succeeds. +instance FromField () where + parseField _ = pure () + {-# INLINE parseField #-} + +-- | Assumes UTF-8 encoding. +instance FromField Char where + parseField s = + case T.decodeUtf8' s of + Left e -> fail $ show e + Right t + | T.compareLength t 1 == EQ -> pure (T.head t) + | otherwise -> typeError "Char" s Nothing + {-# INLINE parseField #-} + +-- | Uses UTF-8 encoding. +instance ToField Char where + toField = toField . T.encodeUtf8 . T.singleton + {-# INLINE toField #-} + +-- | Accepts the same syntax as 'rational'. Ignores whitespace. +-- +-- @since 0.5.1.0 +instance FromField Scientific where + parseField s = case parseOnly (ws *> A8.scientific <* ws) s of + Left err -> typeError "Scientific" s (Just err) + Right n -> pure n + {-# INLINE parseField #-} + +-- | Uses decimal notation or scientific notation, depending on the number. +-- +-- @since 0.5.1.0 +instance ToField Scientific where + toField = scientific + {-# INLINE toField #-} + +-- | Accepts same syntax as 'rational'. Ignores whitespace. +instance FromField Double where + parseField = parseDouble + {-# INLINE parseField #-} + +-- | Uses decimal notation or scientific notation, depending on the +-- number. +instance ToField Double where + toField = realFloat + {-# INLINE toField #-} + +-- | Accepts same syntax as 'rational'. Ignores whitespace. +instance FromField Float where + parseField s = double2Float <$> parseDouble s + {-# INLINE parseField #-} + +-- | Uses decimal notation or scientific notation, depending on the +-- number. +instance ToField Float where + toField = realFloat + {-# INLINE toField #-} + +parseDouble :: B.ByteString -> Parser Double +parseDouble s = case parseOnly (ws *> double <* ws) s of + Left err -> typeError "Double" s (Just err) + Right n -> pure n +{-# INLINE parseDouble #-} + +-- | Accepts a signed decimal number. Ignores whitespace. +instance FromField Int where + parseField = parseSigned "Int" + {-# INLINE parseField #-} + +-- | Uses decimal encoding with optional sign. +instance ToField Int where + toField = decimal + {-# INLINE toField #-} + +-- | Accepts a signed decimal number. Ignores whitespace. +instance FromField Integer where + parseField = parseSigned "Integer" + {-# INLINE parseField #-} + +-- | Uses decimal encoding with optional sign. +instance ToField Integer where + toField = decimal + {-# INLINE toField #-} + +-- | Accepts a signed decimal number. Ignores whitespace. +instance FromField Int8 where + parseField = parseSigned "Int8" + {-# INLINE parseField #-} + +-- | Uses decimal encoding with optional sign. +instance ToField Int8 where + toField = decimal + {-# INLINE toField #-} + +-- | Accepts a signed decimal number. Ignores whitespace. +instance FromField Int16 where + parseField = parseSigned "Int16" + {-# INLINE parseField #-} + +-- | Uses decimal encoding with optional sign. +instance ToField Int16 where + toField = decimal + {-# INLINE toField #-} + +-- | Accepts a signed decimal number. Ignores whitespace. +instance FromField Int32 where + parseField = parseSigned "Int32" + {-# INLINE parseField #-} + +-- | Uses decimal encoding with optional sign. +instance ToField Int32 where + toField = decimal + {-# INLINE toField #-} + +-- | Accepts a signed decimal number. Ignores whitespace. +instance FromField Int64 where + parseField = parseSigned "Int64" + {-# INLINE parseField #-} + +-- | Uses decimal encoding with optional sign. +instance ToField Int64 where + toField = decimal + {-# INLINE toField #-} + +-- | Accepts an unsigned decimal number. Ignores whitespace. +instance FromField Word where + parseField = parseUnsigned "Word" + {-# INLINE parseField #-} + +-- | Uses decimal encoding. +instance ToField Word where + toField = decimal + {-# INLINE toField #-} + +-- | Accepts an unsigned decimal number. Ignores whitespace. +-- +-- @since 0.5.1.0 +instance FromField Natural where + parseField = parseUnsigned "Natural" + {-# INLINE parseField #-} + +-- | Uses decimal encoding. +-- +-- @since 0.5.1.0 +instance ToField Natural where + toField = decimal + {-# INLINE toField #-} + +-- | Accepts an unsigned decimal number. Ignores whitespace. +instance FromField Word8 where + parseField = parseUnsigned "Word8" + {-# INLINE parseField #-} + +-- | Uses decimal encoding. +instance ToField Word8 where + toField = decimal + {-# INLINE toField #-} + +-- | Accepts an unsigned decimal number. Ignores whitespace. +instance FromField Word16 where + parseField = parseUnsigned "Word16" + {-# INLINE parseField #-} + +-- | Uses decimal encoding. +instance ToField Word16 where + toField = decimal + {-# INLINE toField #-} + +-- | Accepts an unsigned decimal number. Ignores whitespace. +instance FromField Word32 where + parseField = parseUnsigned "Word32" + {-# INLINE parseField #-} + +-- | Uses decimal encoding. +instance ToField Word32 where + toField = decimal + {-# INLINE toField #-} + +-- | Accepts an unsigned decimal number. Ignores whitespace. +instance FromField Word64 where + parseField = parseUnsigned "Word64" + {-# INLINE parseField #-} + +-- | Uses decimal encoding. +instance ToField Word64 where + toField = decimal + {-# INLINE toField #-} + +instance FromField B.ByteString where + parseField = pure + {-# INLINE parseField #-} + +instance ToField B.ByteString where + toField = id + {-# INLINE toField #-} + +instance FromField L.ByteString where + parseField = pure . fromStrict + {-# INLINE parseField #-} + +instance ToField L.ByteString where + toField = toStrict + {-# INLINE toField #-} + +#if MIN_VERSION_bytestring(0,10,4) +instance FromField SBS.ShortByteString where + parseField = pure . SBS.toShort + {-# INLINE parseField #-} + +instance ToField SBS.ShortByteString where + toField = SBS.fromShort + {-# INLINE toField #-} +#endif + +#if MIN_VERSION_text_short(0,1,0) +-- | Assumes UTF-8 encoding. Fails on invalid byte sequences. +-- +-- @since 0.5.0.0 +instance FromField T.S.ShortText where + parseField = maybe (fail "Invalid UTF-8 stream") pure . T.S.fromByteString + {-# INLINE parseField #-} + +-- | Uses UTF-8 encoding. +-- +-- @since 0.5.0.0 +instance ToField T.S.ShortText where + toField = T.S.toByteString + {-# INLINE toField #-} +#endif + +-- | Assumes UTF-8 encoding. Fails on invalid byte sequences. +instance FromField T.Text where + parseField = either (fail . show) pure . T.decodeUtf8' + {-# INLINE parseField #-} + +-- | Uses UTF-8 encoding. +instance ToField T.Text where + toField = toField . T.encodeUtf8 + {-# INLINE toField #-} + +-- | Assumes UTF-8 encoding. Fails on invalid byte sequences. +instance FromField LT.Text where + parseField = either (fail . show) (pure . LT.fromStrict) . T.decodeUtf8' + {-# INLINE parseField #-} + +-- | Uses UTF-8 encoding. +instance ToField LT.Text where + toField = toField . toStrict . LT.encodeUtf8 + {-# INLINE toField #-} + +-- | Assumes UTF-8 encoding. Fails on invalid byte sequences. +instance FromField [Char] where + parseField = fmap T.unpack . parseField + {-# INLINE parseField #-} + +-- | Uses UTF-8 encoding. +instance ToField [Char] where + toField = toField . T.pack + {-# INLINE toField #-} + +parseSigned :: (Integral a, Num a) => String -> B.ByteString -> Parser a +parseSigned typ s = case parseOnly (ws *> A8.signed A8.decimal <* ws) s of + Left err -> typeError typ s (Just err) + Right n -> pure n +{-# INLINE parseSigned #-} + +parseUnsigned :: Integral a => String -> B.ByteString -> Parser a +parseUnsigned typ s = case parseOnly (ws *> A8.decimal <* ws) s of + Left err -> typeError typ s (Just err) + Right n -> pure n +{-# INLINE parseUnsigned #-} + +ws :: A8.Parser () +ws = A8.skipWhile (\c -> c == ' ' || c == '\t') + + + +------------------------------------------------------------------------ +-- Custom version of attoparsec @parseOnly@ function which fails if +-- there is leftover content after parsing a field. +parseOnly :: A8.Parser a -> B.ByteString -> Either String a +parseOnly parser input = go (A8.parse parser input) where + go (A8.Fail _ _ err) = Left err + go (A8.Partial f) = go2 (f B.empty) + go (A8.Done leftover result) + | B.null leftover = Right result + | otherwise = Left ("incomplete field parse, leftover: " + ++ show (B.unpack leftover)) + + go2 (A8.Fail _ _ err) = Left err + go2 (A8.Partial _) = error "parseOnly: impossible error!" + go2 (A8.Done leftover result) + | B.null leftover = Right result + | otherwise = Left ("incomplete field parse, leftover: " + ++ show (B.unpack leftover)) +{-# INLINE parseOnly #-} + +typeError :: String -> B.ByteString -> Maybe String -> Parser a +typeError typ s mmsg = + fail $ "expected " ++ typ ++ ", got " ++ show (B8.unpack s) ++ cause + where + cause = case mmsg of + Just msg -> " (" ++ msg ++ ")" + Nothing -> "" + +------------------------------------------------------------------------ +-- Constructors and accessors + +-- | Retrieve the /n/th field in the given record. The result is +-- 'empty' if the value cannot be converted to the desired type. +-- Raises an exception if the index is out of bounds. +-- +-- 'index' is a simple convenience function that is equivalent to +-- @'parseField' (v '!' idx)@. If you're certain that the index is not +-- out of bounds, using 'unsafeIndex' is somewhat faster. +index :: FromField a => Record -> Int -> Parser a +index v idx = parseField (v ! idx) +{-# INLINE index #-} + +-- | Alias for 'index'. +(.!) :: FromField a => Record -> Int -> Parser a +(.!) = index +{-# INLINE (.!) #-} +infixl 9 .! + +-- | Like 'index' but without bounds checking. +unsafeIndex :: FromField a => Record -> Int -> Parser a +unsafeIndex v idx = parseField (V.unsafeIndex v idx) +{-# INLINE unsafeIndex #-} + +-- | Retrieve a field in the given record by name. The result is +-- 'empty' if the field is missing or if the value cannot be converted +-- to the desired type. +lookup :: FromField a => NamedRecord -> B.ByteString -> Parser a +lookup m name = maybe (fail err) parseField $ HM.lookup name m + where err = "no field named " ++ show (B8.unpack name) +{-# INLINE lookup #-} + +-- | Alias for 'lookup'. +(.:) :: FromField a => NamedRecord -> B.ByteString -> Parser a +(.:) = lookup +{-# INLINE (.:) #-} + +-- | Construct a pair from a name and a value. For use with +-- 'namedRecord'. +namedField :: ToField a => B.ByteString -> a -> (B.ByteString, B.ByteString) +namedField name val = (name, toField val) +{-# INLINE namedField #-} + +-- | Alias for 'namedField'. +(.=) :: ToField a => B.ByteString -> a -> (B.ByteString, B.ByteString) +(.=) = namedField +{-# INLINE (.=) #-} + +-- | Construct a record from a list of 'B.ByteString's. Use 'toField' +-- to convert values to 'B.ByteString's for use with 'record'. +record :: [B.ByteString] -> Record +record = V.fromList + +-- | Construct a named record from a list of name-value 'B.ByteString' +-- pairs. Use '.=' to construct such a pair from a name and a value. +namedRecord :: [(B.ByteString, B.ByteString)] -> NamedRecord +namedRecord = HM.fromList + +-- | Construct a header from a list of 'B.ByteString's. +header :: [B.ByteString] -> Header +header = V.fromList + +------------------------------------------------------------------------ +-- Parser for converting records to data types + +-- | Failure continuation. +type Failure f r = String -> f r +-- | Success continuation. +type Success a f r = a -> f r + +-- | Conversion of a field to a value might fail e.g. if the field is +-- malformed. This possibility is captured by the 'Parser' type, which +-- lets you compose several field conversions together in such a way +-- that if any of them fail, the whole record conversion fails. +newtype Parser a = Parser { + unParser :: forall (f :: * -> *) (r :: *). + Failure f r + -> Success a f r + -> f r + } + +instance Monad Parser where + m >>= g = Parser $ \kf ks -> let ks' a = unParser (g a) kf ks + in unParser m kf ks' + {-# INLINE (>>=) #-} + (>>) = (*>) + {-# INLINE (>>) #-} + return = pure + {-# INLINE return #-} + fail = Fail.fail + {-# INLINE fail #-} + +-- | @since 0.5.0.0 +instance Fail.MonadFail Parser where + fail msg = Parser $ \kf _ks -> kf msg + {-# INLINE fail #-} + +instance Functor Parser where + fmap f m = Parser $ \kf ks -> let ks' a = ks (f a) + in unParser m kf ks' + {-# INLINE fmap #-} + +instance Applicative Parser where + pure a = Parser $ \_kf ks -> ks a + {-# INLINE pure #-} + (<*>) = apP + {-# INLINE (<*>) #-} + +instance Alternative Parser where + empty = fail "empty" + {-# INLINE empty #-} + (<|>) = mplus + {-# INLINE (<|>) #-} + +instance MonadPlus Parser where + mzero = fail "mzero" + {-# INLINE mzero #-} + mplus a b = Parser $ \kf ks -> let kf' _ = unParser b kf ks + in unParser a kf' ks + {-# INLINE mplus #-} + +-- | @since 0.5.0.0 +instance Semigroup (Parser a) where + (<>) = mplus + {-# INLINE (<>) #-} + +instance Monoid (Parser a) where + mempty = fail "mempty" + {-# INLINE mempty #-} + mappend = (<>) + {-# INLINE mappend #-} + +apP :: Parser (a -> b) -> Parser a -> Parser b +apP d e = do + b <- d + a <- e + pure (b a) +{-# INLINE apP #-} + +-- | Run a 'Parser', returning either @'Left' errMsg@ or @'Right' +-- result@. Forces the value in the 'Left' or 'Right' constructors to +-- weak head normal form. +-- +-- You most likely won't need to use this function directly, but it's +-- included for completeness. +runParser :: Parser a -> Either String a +runParser p = unParser p left right + where + left !errMsg = Left errMsg + right !x = Right x +{-# INLINE runParser #-} + +------------------------------------------------------------------------ +-- Generics + +class GFromRecord f where + gparseRecord :: Options -> Record -> Parser (f p) + +instance GFromRecordSum f Record => GFromRecord (M1 i n f) where + gparseRecord opts v = + case IM.lookup n (gparseRecordSum opts) of + Nothing -> lengthMismatch n v + Just p -> M1 <$> p v + where + n = V.length v + +class GFromNamedRecord f where + gparseNamedRecord :: Options -> NamedRecord -> Parser (f p) + +instance GFromRecordSum f NamedRecord => GFromNamedRecord (M1 i n f) where + gparseNamedRecord opts v = + foldr (\f p -> p <|> M1 <$> f v) empty (IM.elems (gparseRecordSum opts)) + +class GFromRecordSum f r where + gparseRecordSum :: Options -> IM.IntMap (r -> Parser (f p)) + +instance (GFromRecordSum a r, GFromRecordSum b r) => GFromRecordSum (a :+: b) r where + gparseRecordSum opts = + IM.unionWith (\a b r -> a r <|> b r) + (fmap (L1 <$>) <$> gparseRecordSum opts) + (fmap (R1 <$>) <$> gparseRecordSum opts) + +instance GFromRecordProd f r => GFromRecordSum (M1 i n f) r where + gparseRecordSum opts = IM.singleton n (fmap (M1 <$>) f) + where + (n, f) = gparseRecordProd opts 0 + +class GFromRecordProd f r where + gparseRecordProd :: Options -> Int -> (Int, r -> Parser (f p)) + +instance GFromRecordProd U1 r where + gparseRecordProd _ n = (n, const (pure U1)) + +instance (GFromRecordProd a r, GFromRecordProd b r) => GFromRecordProd (a :*: b) r where + gparseRecordProd opts n0 = (n2, f) + where + f r = (:*:) <$> fa r <*> fb r + (n1, fa) = gparseRecordProd opts n0 + (n2, fb) = gparseRecordProd opts n1 + +instance GFromRecordProd f Record => GFromRecordProd (M1 i n f) Record where + gparseRecordProd opts n = fmap (M1 <$>) <$> gparseRecordProd opts n + +instance FromField a => GFromRecordProd (K1 i a) Record where + gparseRecordProd _ n = (n + 1, \v -> K1 <$> parseField (V.unsafeIndex v n)) + +data Proxy s (f :: * -> *) a = Proxy + +instance (FromField a, Selector s) => GFromRecordProd (M1 S s (K1 i a)) NamedRecord where + gparseRecordProd opts n = (n + 1, \v -> (M1 . K1) <$> v .: name) + where + name = T.encodeUtf8 (T.pack (fieldLabelModifier opts (selName (Proxy :: Proxy s f a)))) + + +class GToRecord a f where + gtoRecord :: Options -> a p -> [f] + +instance GToRecord U1 f where + gtoRecord _ U1 = [] + +instance (GToRecord a f, GToRecord b f) => GToRecord (a :*: b) f where + gtoRecord opts (a :*: b) = gtoRecord opts a ++ gtoRecord opts b + +instance (GToRecord a f, GToRecord b f) => GToRecord (a :+: b) f where + gtoRecord opts (L1 a) = gtoRecord opts a + gtoRecord opts (R1 b) = gtoRecord opts b + +instance GToRecord a f => GToRecord (M1 D c a) f where + gtoRecord opts (M1 a) = gtoRecord opts a + +instance GToRecord a f => GToRecord (M1 C c a) f where + gtoRecord opts (M1 a) = gtoRecord opts a + +instance GToRecord a Field => GToRecord (M1 S c a) Field where + gtoRecord opts (M1 a) = gtoRecord opts a + +instance ToField a => GToRecord (K1 i a) Field where + gtoRecord _ (K1 a) = [toField a] + +instance (ToField a, Selector s) => GToRecord (M1 S s (K1 i a)) (B.ByteString, B.ByteString) where + gtoRecord opts m@(M1 (K1 a)) = [name .= toField a] + where + name = T.encodeUtf8 (T.pack (fieldLabelModifier opts (selName m))) + +-- We statically fail on sum types and product types without selectors +-- (field names). + +class GToNamedRecordHeader a + where + gtoNamedRecordHeader :: Options -> a p -> [Name] + +instance GToNamedRecordHeader U1 + where + gtoNamedRecordHeader _ _ = [] + +instance (GToNamedRecordHeader a, GToNamedRecordHeader b) => + GToNamedRecordHeader (a :*: b) + where + gtoNamedRecordHeader opts _ = gtoNamedRecordHeader opts (undefined :: a p) ++ + gtoNamedRecordHeader opts (undefined :: b p) + +instance GToNamedRecordHeader a => GToNamedRecordHeader (M1 D c a) + where + gtoNamedRecordHeader opts _ = gtoNamedRecordHeader opts (undefined :: a p) + +instance GToNamedRecordHeader a => GToNamedRecordHeader (M1 C c a) + where + gtoNamedRecordHeader opts _ = gtoNamedRecordHeader opts (undefined :: a p) + +-- | Instance to ensure that you cannot derive DefaultOrdered for +-- constructors without selectors. +#if MIN_VERSION_base(4,9,0) +instance DefaultOrdered (M1 S ('MetaSel 'Nothing srcpk srcstr decstr) a ()) + => GToNamedRecordHeader (M1 S ('MetaSel 'Nothing srcpk srcstr decstr) a) +#else +instance DefaultOrdered (M1 S NoSelector a ()) => GToNamedRecordHeader (M1 S NoSelector a) +#endif + where + gtoNamedRecordHeader _ _ = + error "You cannot derive DefaultOrdered for constructors without selectors." + +instance Selector s => GToNamedRecordHeader (M1 S s a) + where + gtoNamedRecordHeader opts m + | null name = error "Cannot derive DefaultOrdered for constructors without selectors" + | otherwise = [B8.pack (fieldLabelModifier opts (selName m))] + where name = selName m diff --git a/Data/Csv/Conversion/Internal.hs b/Data/Csv/Conversion/Internal.hs new file mode 100644 --- /dev/null +++ b/Data/Csv/Conversion/Internal.hs @@ -0,0 +1,299 @@ +module Data.Csv.Conversion.Internal + ( decimal + , scientific + , realFloat + ) where + +import Data.ByteString.Builder (Builder, toLazyByteString, word8, char8, + string8, byteString) +import qualified Data.ByteString.Builder.Prim as BP +import Data.ByteString.Builder.Scientific (scientificBuilder) +import Data.Array.Base (unsafeAt) +import Data.Array.IArray +import qualified Data.ByteString as B +import Data.Char (ord) +import Data.Int +import Data.Monoid +import Data.Scientific (Scientific) +import Data.Word + +import Data.Csv.Util (toStrict) + +------------------------------------------------------------------------ +-- Integers + +decimal :: Integral a => a -> B.ByteString +decimal = toStrict . toLazyByteString . formatDecimal +{-# INLINE decimal #-} + +-- TODO: Add an optimized version for Integer. + +formatDecimal :: Integral a => a -> Builder +{-# RULES "formatDecimal/Int" formatDecimal = formatBoundedSigned + :: Int -> Builder #-} +{-# RULES "formatDecimal/Int8" formatDecimal = formatBoundedSigned + :: Int8 -> Builder #-} +{-# RULES "formatDecimal/Int16" formatDecimal = formatBoundedSigned + :: Int16 -> Builder #-} +{-# RULES "formatDecimal/Int32" formatDecimal = formatBoundedSigned + :: Int32 -> Builder #-} +{-# RULES "formatDecimal/Int64" formatDecimal = formatBoundedSigned + :: Int64 -> Builder #-} +{-# RULES "formatDecimal/Word" formatDecimal = formatPositive + :: Word -> Builder #-} +{-# RULES "formatDecimal/Word8" formatDecimal = formatPositive + :: Word8 -> Builder #-} +{-# RULES "formatDecimal/Word16" formatDecimal = formatPositive + :: Word16 -> Builder #-} +{-# RULES "formatDecimal/Word32" formatDecimal = formatPositive + :: Word32 -> Builder #-} +{-# RULES "formatDecimal/Word64" formatDecimal = formatPositive + :: Word64 -> Builder #-} +{-# NOINLINE formatDecimal #-} +formatDecimal i + | i < 0 = minus <> + if i <= -128 + then formatPositive (-(i `quot` 10)) <> digit (-(i `rem` 10)) + else formatPositive (-i) + | otherwise = formatPositive i + +formatBoundedSigned :: (Integral a, Bounded a) => a -> Builder +{-# SPECIALIZE formatBoundedSigned :: Int -> Builder #-} +{-# SPECIALIZE formatBoundedSigned :: Int8 -> Builder #-} +{-# SPECIALIZE formatBoundedSigned :: Int16 -> Builder #-} +{-# SPECIALIZE formatBoundedSigned :: Int32 -> Builder #-} +{-# SPECIALIZE formatBoundedSigned :: Int64 -> Builder #-} +formatBoundedSigned i + | i < 0 = minus <> + if i == minBound + then formatPositive (-(i `quot` 10)) <> digit (-(i `rem` 10)) + else formatPositive (-i) + | otherwise = formatPositive i + +formatPositive :: Integral a => a -> Builder +{-# SPECIALIZE formatPositive :: Int -> Builder #-} +{-# SPECIALIZE formatPositive :: Int8 -> Builder #-} +{-# SPECIALIZE formatPositive :: Int16 -> Builder #-} +{-# SPECIALIZE formatPositive :: Int32 -> Builder #-} +{-# SPECIALIZE formatPositive :: Int64 -> Builder #-} +{-# SPECIALIZE formatPositive :: Word -> Builder #-} +{-# SPECIALIZE formatPositive :: Word8 -> Builder #-} +{-# SPECIALIZE formatPositive :: Word16 -> Builder #-} +{-# SPECIALIZE formatPositive :: Word32 -> Builder #-} +{-# SPECIALIZE formatPositive :: Word64 -> Builder #-} +formatPositive = go + where go n | n < 10 = digit n + | otherwise = go (n `quot` 10) <> digit (n `rem` 10) + +minus :: Builder +minus = word8 45 + +zero :: Word8 +zero = 48 + +digit :: Integral a => a -> Builder +digit n = word8 $! i2w (fromIntegral n) +{-# INLINE digit #-} + +i2w :: Int -> Word8 +i2w i = zero + fromIntegral i +{-# INLINE i2w #-} + +------------------------------------------------------------------------ +-- Floating point numbers + +scientific :: Scientific -> B.ByteString +scientific = toStrict . toLazyByteString . scientificBuilder +{-# INLINE scientific #-} + +realFloat :: RealFloat a => a -> B.ByteString +{-# SPECIALIZE realFloat :: Float -> B.ByteString #-} +{-# SPECIALIZE realFloat :: Double -> B.ByteString #-} +realFloat = toStrict . toLazyByteString . formatRealFloat Generic + +-- | Control the rendering of floating point numbers. +data FPFormat = Exponent + -- ^ Scientific notation (e.g. @2.3e123@). + | Fixed + -- ^ Standard decimal notation. + | Generic + -- ^ Use decimal notation for values between @0.1@ and + -- @9,999,999@, and scientific notation otherwise. + deriving (Enum, Read, Show) + +formatRealFloat :: RealFloat a => FPFormat -> a -> Builder +{-# SPECIALIZE formatRealFloat :: FPFormat -> Float -> Builder #-} +{-# SPECIALIZE formatRealFloat :: FPFormat -> Double -> Builder #-} +formatRealFloat fmt x + | isNaN x = string8 "NaN" + | isInfinite x = if x < 0 + then string8 "-Infinity" + else string8 "Infinity" + | x < 0 || isNegativeZero x = minus <> doFmt fmt (floatToDigits (-x)) + | otherwise = doFmt fmt (floatToDigits x) + where + doFmt format (is, e) = + let ds = map i2d is in + case format of + Generic -> + doFmt (if e < 0 || e > 7 then Exponent else Fixed) + (is,e) + Exponent -> + let show_e' = formatDecimal (e-1) in + case ds of + [48] -> string8 "0.0e0" + [d] -> word8 d <> string8 ".0e" <> show_e' + (d:ds') -> word8 d <> char8 '.' <> word8s ds' <> + char8 'e' <> show_e' + [] -> error "formatRealFloat/doFmt/Exponent: []" + Fixed + | e <= 0 -> string8 "0." <> + byteString (B.replicate (-e) zero) <> + word8s ds + | otherwise -> + let + f 0 s rs = mk0 (reverse s) <> char8 '.' <> mk0 rs + f n s [] = f (n-1) (zero:s) [] + f n s (r:rs) = f (n-1) (r:s) rs + in + f e [] ds + where mk0 ls = case ls of { [] -> word8 zero ; _ -> word8s ls} + +-- Based on "Printing Floating-Point Numbers Quickly and Accurately" +-- by R.G. Burger and R.K. Dybvig in PLDI 96. +-- This version uses a much slower logarithm estimator. It should be improved. + +-- | 'floatToDigits' takes a base and a non-negative 'RealFloat' number, +-- and returns a list of digits and an exponent. +-- In particular, if @x>=0@, and +-- +-- > floatToDigits base x = ([d1,d2,...,dn], e) +-- +-- then +-- +-- (1) @n >= 1@ +-- +-- (2) @x = 0.d1d2...dn * (base**e)@ +-- +-- (3) @0 <= di <= base-1@ + +floatToDigits :: (RealFloat a) => a -> ([Int], Int) +{-# SPECIALIZE floatToDigits :: Float -> ([Int], Int) #-} +{-# SPECIALIZE floatToDigits :: Double -> ([Int], Int) #-} +floatToDigits 0 = ([0], 0) +floatToDigits x = + let + (f0, e0) = decodeFloat x + (minExp0, _) = floatRange x + p = floatDigits x + b = floatRadix x + minExp = minExp0 - p -- the real minimum exponent + -- Haskell requires that f be adjusted so denormalized numbers + -- will have an impossibly low exponent. Adjust for this. + (f, e) = + let n = minExp - e0 in + if n > 0 then (f0 `quot` (expt b n), e0+n) else (f0, e0) + (r, s, mUp, mDn) = + if e >= 0 then + let be = expt b e in + if f == expt b (p-1) then + (f*be*b*2, 2*b, be*b, be) -- according to Burger and Dybvig + else + (f*be*2, 2, be, be) + else + if e > minExp && f == expt b (p-1) then + (f*b*2, expt b (-e+1)*2, b, 1) + else + (f*2, expt b (-e)*2, 1, 1) + k :: Int + k = + let + k0 :: Int + k0 = + if b == 2 then + -- logBase 10 2 is very slightly larger than 8651/28738 + -- (about 5.3558e-10), so if log x >= 0, the approximation + -- k1 is too small, hence we add one and need one fixup step less. + -- If log x < 0, the approximation errs rather on the high side. + -- That is usually more than compensated for by ignoring the + -- fractional part of logBase 2 x, but when x is a power of 1/2 + -- or slightly larger and the exponent is a multiple of the + -- denominator of the rational approximation to logBase 10 2, + -- k1 is larger than logBase 10 x. If k1 > 1 + logBase 10 x, + -- we get a leading zero-digit we don't want. + -- With the approximation 3/10, this happened for + -- 0.5^1030, 0.5^1040, ..., 0.5^1070 and values close above. + -- The approximation 8651/28738 guarantees k1 < 1 + logBase 10 x + -- for IEEE-ish floating point types with exponent fields + -- <= 17 bits and mantissae of several thousand bits, earlier + -- convergents to logBase 10 2 would fail for long double. + -- Using quot instead of div is a little faster and requires + -- fewer fixup steps for negative lx. + let lx = p - 1 + e0 + k1 = (lx * 8651) `quot` 28738 + in if lx >= 0 then k1 + 1 else k1 + else + -- f :: Integer, log :: Float -> Float, + -- ceiling :: Float -> Int + ceiling ((log (fromInteger (f+1) :: Float) + + fromIntegral e * log (fromInteger b)) / + log 10) +--WAS: fromInt e * log (fromInteger b)) + + fixup n = + if n >= 0 then + if r + mUp <= expt 10 n * s then n else fixup (n+1) + else + if expt 10 (-n) * (r + mUp) <= s then n else fixup (n+1) + in + fixup k0 + + gen ds rn sN mUpN mDnN = + let + (dn, rn') = (rn * 10) `quotRem` sN + mUpN' = mUpN * 10 + mDnN' = mDnN * 10 + in + case (rn' < mDnN', rn' + mUpN' > sN) of + (True, False) -> dn : ds + (False, True) -> dn+1 : ds + (True, True) -> if rn' * 2 < sN then dn : ds else dn+1 : ds + (False, False) -> gen (dn:ds) rn' sN mUpN' mDnN' + + rds = + if k >= 0 then + gen [] r (s * expt 10 k) mUp mDn + else + let bk = expt 10 (-k) in + gen [] (r * bk) s (mUp * bk) (mDn * bk) + in + (map fromIntegral (reverse rds), k) + +-- Exponentiation with a cache for the most common numbers. +minExpt, maxExpt :: Int +minExpt = 0 +maxExpt = 1100 + +expt :: Integer -> Int -> Integer +expt base n + | base == 2 && n >= minExpt && n <= maxExpt = expts `unsafeAt` n + | base == 10 && n <= maxExpt10 = expts10 `unsafeAt` n + | otherwise = base^n + +expts :: Array Int Integer +expts = array (minExpt,maxExpt) [(n,2^n) | n <- [minExpt .. maxExpt]] + +maxExpt10 :: Int +maxExpt10 = 324 + +expts10 :: Array Int Integer +expts10 = array (minExpt,maxExpt10) [(n,10^n) | n <- [minExpt .. maxExpt10]] + +-- | Unsafe conversion for decimal digits. +{-# INLINE i2d #-} +i2d :: Int -> Word8 +i2d i = fromIntegral (ord '0' + i) + +-- | Word8 list rendering +word8s :: [Word8] -> Builder +word8s = BP.primMapListFixed BP.word8 diff --git a/Data/Csv/Encoding.hs b/Data/Csv/Encoding.hs new file mode 100644 --- /dev/null +++ b/Data/Csv/Encoding.hs @@ -0,0 +1,389 @@ +{-# LANGUAGE BangPatterns, OverloadedStrings, ScopedTypeVariables #-} + +-- Module: Data.Csv.Encoding +-- Copyright: (c) 2011 MailRank, Inc. +-- (c) 2012 Johan Tibell +-- License: BSD3 +-- Maintainer: Johan Tibell +-- Stability: experimental +-- Portability: portable +-- +-- Encoding and decoding of data types into CSV. +module Data.Csv.Encoding + ( + -- * Encoding and decoding + HasHeader(..) + , decode + , decodeByName + , Quoting(..) + , encode + , encodeByName + , encodeDefaultOrderedByName + + -- ** Encoding and decoding options + , DecodeOptions(..) + , defaultDecodeOptions + , decodeWith + , decodeByNameWith + , EncodeOptions(..) + , defaultEncodeOptions + , encodeWith + , encodeByNameWith + , encodeDefaultOrderedByNameWith + + -- ** Encoding and decoding single records + , encodeRecord + , encodeNamedRecord + , recordSep + ) where + +import Data.ByteString.Builder +import Control.Applicative as AP (Applicative(..), (<|>)) +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 qualified Data.HashMap.Strict as HM +import Data.Vector (Vector) +import qualified Data.Vector as V +import Data.Word (Word8) +import Data.Monoid +import Prelude hiding (unlines) + +import qualified Data.Csv.Conversion as Conversion +import Data.Csv.Conversion (FromNamedRecord, FromRecord, ToNamedRecord, + ToRecord, parseNamedRecord, parseRecord, runParser, + toNamedRecord, toRecord) +import Data.Csv.Parser hiding (csv, csvWithHeader) +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. + +------------------------------------------------------------------------ +-- * Encoding and decoding + +-- | Efficiently deserialize CSV records from a lazy 'L.ByteString'. +-- If this fails due to incomplete or invalid input, @'Left' msg@ is +-- returned. Equivalent to @'decodeWith' 'defaultDecodeOptions'@. +decode :: FromRecord a + => HasHeader -- ^ Data contains header that should be + -- skipped + -> L.ByteString -- ^ CSV data + -> Either String (Vector a) +decode = decodeWith defaultDecodeOptions +{-# INLINE decode #-} + +-- | Efficiently deserialize CSV records from a lazy 'L.ByteString'. +-- If this fails due to incomplete or invalid input, @'Left' msg@ is +-- returned. The data is assumed to be preceeded by a header. +-- Equivalent to @'decodeByNameWith' 'defaultDecodeOptions'@. +decodeByName :: FromNamedRecord a + => L.ByteString -- ^ CSV data + -> Either String (Header, Vector a) +decodeByName = decodeByNameWith defaultDecodeOptions +{-# INLINE decodeByName #-} + +-- | Efficiently serialize CSV records as a lazy 'L.ByteString'. +encode :: ToRecord a => [a] -> L.ByteString +encode = encodeWith defaultEncodeOptions +{-# INLINE encode #-} + +-- | Efficiently serialize CSV records as a lazy 'L.ByteString'. The +-- header is written before any records and dictates the field order. +encodeByName :: ToNamedRecord a => Header -> [a] -> L.ByteString +encodeByName = encodeByNameWith defaultEncodeOptions +{-# INLINE encodeByName #-} + +-- | Like 'encodeByName', but header and field order is dictated by +-- the 'Conversion.header' method. +encodeDefaultOrderedByName :: (Conversion.DefaultOrdered a, ToNamedRecord a) => + [a] -> L.ByteString +encodeDefaultOrderedByName = encodeDefaultOrderedByNameWith defaultEncodeOptions +{-# INLINE encodeDefaultOrderedByName #-} + +------------------------------------------------------------------------ +-- ** Encoding and decoding options + +-- | Like 'decode', but lets you customize how the CSV data is parsed. +decodeWith :: FromRecord a + => DecodeOptions -- ^ Decoding options + -> HasHeader -- ^ Data contains header that should be + -- skipped + -> L.ByteString -- ^ CSV data + -> Either String (Vector a) +decodeWith = decodeWithC csv +{-# INLINE [1] decodeWith #-} + +{-# RULES + "idDecodeWith" decodeWith = idDecodeWith + #-} + +-- | Same as 'decodeWith', but more efficient as no type +-- conversion is performed. +idDecodeWith :: DecodeOptions -> HasHeader -> L.ByteString + -> Either String (Vector (Vector B.ByteString)) +idDecodeWith = decodeWithC Parser.csv + +-- | Decode CSV data using the provided parser, skipping a leading +-- header if 'hasHeader' is 'HasHeader'. Returns 'Left' @errMsg@ on +-- failure. +decodeWithC :: (DecodeOptions -> AL.Parser a) -> DecodeOptions -> HasHeader + -> BL8.ByteString -> Either String a +decodeWithC p !opts hasHeader = decodeWithP parser + where parser = case hasHeader of + HasHeader -> header (decDelimiter opts) *> p opts + NoHeader -> p opts +{-# INLINE decodeWithC #-} + +-- | Like 'decodeByName', but lets you customize how the CSV data is +-- parsed. +decodeByNameWith :: FromNamedRecord a + => DecodeOptions -- ^ Decoding options + -> L.ByteString -- ^ CSV data + -> Either String (Header, Vector a) +decodeByNameWith !opts = decodeWithP (csvWithHeader opts) + +-- | Should quoting be applied to fields, and at which level? +data Quoting + = QuoteNone -- ^ No quotes. + | QuoteMinimal -- ^ Quotes according to RFC 4180. + | QuoteAll -- ^ Always quote. + deriving (Eq, Show) + +-- | 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. +-- +-- To avoid having your program stop compiling when new fields are +-- added to 'EncodeOptions', create option records by overriding +-- values in 'defaultEncodeOptions'. Example: +-- +-- > myOptions = defaultEncodeOptions { +-- > encDelimiter = fromIntegral (ord '\t') +-- > } +-- +-- /N.B./ The 'encDelimiter' must /not/ be the quote character (i.e. +-- @\"@) or one of the record separator characters (i.e. @\\n@ or +-- @\\r@). +data EncodeOptions = EncodeOptions + { -- | Field delimiter. + encDelimiter :: {-# UNPACK #-} !Word8 + + -- | Record separator selection. @True@ for CRLF (@\\r\\n@) and + -- @False@ for LF (@\\n@). + , encUseCrLf :: !Bool + + -- | Include a header row when encoding @ToNamedRecord@ + -- instances. + , encIncludeHeader :: !Bool + + -- | What kind of quoting should be applied to text fields. + , encQuoting :: !Quoting + } deriving (Eq, Show) + +-- | Encoding options for CSV files. +defaultEncodeOptions :: EncodeOptions +defaultEncodeOptions = EncodeOptions + { encDelimiter = 44 -- comma + , encUseCrLf = True + , encIncludeHeader = True + , encQuoting = QuoteMinimal + } + +-- | Like 'encode', but lets you customize how the CSV data is +-- encoded. +encodeWith :: ToRecord a => EncodeOptions -> [a] -> L.ByteString +encodeWith opts + | validDelim (encDelimiter opts) = + toLazyByteString + . unlines (recordSep (encUseCrLf opts)) + . map (encodeRecord (encQuoting opts) (encDelimiter opts) + . toRecord) + | otherwise = encodeOptionsError +{-# INLINE encodeWith #-} + +-- | Check if the delimiter is valid. +validDelim :: Word8 -> Bool +validDelim delim = delim `notElem` [cr, nl, dquote] + where + nl = 10 + cr = 13 + dquote = 34 + +-- | Raises an exception indicating that the provided delimiter isn't +-- valid. See 'validDelim'. +-- +-- Keep this message consistent with the documentation of +-- 'EncodeOptions'. +encodeOptionsError :: a +encodeOptionsError = error $ "Data.Csv: " ++ + "The 'encDelimiter' must /not/ be the quote character (i.e. " ++ + "\") or one of the record separator characters (i.e. \\n or " ++ + "\\r)" + +-- | 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 +{-# 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 + +-- TODO: Optimize +escape :: Quoting -> Word8 -> B.ByteString -> B.ByteString +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 + where + dquote = 34 + nl = 10 + cr = 13 + +-- | Like 'encodeByName', but lets you customize how the CSV data is +-- encoded. +encodeByNameWith :: ToNamedRecord a => EncodeOptions -> Header -> [a] + -> L.ByteString +encodeByNameWith opts hdr v + | validDelim (encDelimiter opts) = + toLazyByteString (rows (encIncludeHeader opts)) + | otherwise = encodeOptionsError + where + 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) + . toNamedRecord) + $ v +{-# INLINE encodeByNameWith #-} + +-- | Like 'encodeDefaultOrderedByNameWith', but lets you customize how +-- the CSV data is encoded. +encodeDefaultOrderedByNameWith :: + forall a. (Conversion.DefaultOrdered a, ToNamedRecord a) => + EncodeOptions -> [a] -> L.ByteString +encodeDefaultOrderedByNameWith opts v + | validDelim (encDelimiter opts) = + toLazyByteString (rows (encIncludeHeader opts)) + | otherwise = encodeOptionsError + where + 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) + . toNamedRecord) + $ v +{-# INLINE encodeDefaultOrderedByNameWith #-} + +namedRecordToRecord :: Header -> NamedRecord -> Record +namedRecordToRecord 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 + +moduleError :: String -> String -> a +moduleError func msg = error $ "Data.Csv.Encoding." ++ func ++ ": " ++ msg +{-# NOINLINE moduleError #-} + +recordSep :: Bool -> Builder +recordSep False = word8 10 -- new line (\n) +recordSep True = string8 "\r\n" + +unlines :: Builder -> [Builder] -> Builder +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 + AL.Done _ v -> Right v + AL.Fail left _ msg -> Left errMsg + where + errMsg = "parse error (" ++ msg ++ ") at " ++ + (if BL8.length left > 100 + then (take 100 $ BL8.unpack left) ++ " (truncated)" + else show (BL8.unpack left)) +{-# INLINE decodeWithP #-} + +-- These alternative implementation of the 'csv' and 'csvWithHeader' +-- parsers from the 'Parser' module performs the +-- 'FromRecord'/'FromNamedRecord' conversions on-the-fly, thereby +-- avoiding the need to hold a big 'CSV' value in memory. The 'CSV' +-- type has a quite large memory overhead due to high constant +-- overheads of 'B.ByteString' and 'V.Vector'. + +-- TODO: Check that the error messages don't duplicate prefixes, as in +-- "parse error: conversion error: ...". + +-- | Parse a CSV file that does not include a header. +csv :: FromRecord a => DecodeOptions -> AL.Parser (V.Vector a) +csv !opts = do + vals <- records + return $! V.fromList vals + where + records = do + !r <- record (decDelimiter opts) + if blankLine r + then (endOfInput *> pure []) <|> (endOfLine *> records) + else case runParser (parseRecord r) of + Left msg -> fail $ "conversion error: " ++ msg + Right val -> do + !vals <- (endOfInput *> AP.pure []) <|> (endOfLine *> records) + return (val : vals) +{-# INLINE csv #-} + +-- | Parse a CSV file that includes a header. +csvWithHeader :: FromNamedRecord a => DecodeOptions + -> AL.Parser (Header, V.Vector a) +csvWithHeader !opts = do + !hdr <- header (decDelimiter opts) + vals <- records hdr + let !v = V.fromList vals + return (hdr, v) + where + records hdr = do + !r <- record (decDelimiter opts) + if blankLine r + then (endOfInput *> pure []) <|> (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) + return (val : vals) + + convert hdr = parseNamedRecord . Types.toNamedRecord hdr diff --git a/Data/Csv/Incremental.hs b/Data/Csv/Incremental.hs new file mode 100644 --- /dev/null +++ b/Data/Csv/Incremental.hs @@ -0,0 +1,438 @@ +{-# LANGUAGE BangPatterns, CPP, DeriveFunctor, ScopedTypeVariables #-} + +-- | This module allows for incremental decoding and encoding of CSV +-- data. This is useful if you e.g. want to interleave I\/O with +-- parsing or if you want finer grained control over how you deal with +-- type conversion errors. +-- +-- Decoding example: +-- +-- > main :: IO () +-- > main = withFile "salaries.csv" ReadMode $ \ csvFile -> do +-- > let loop !_ (Fail _ errMsg) = putStrLn errMsg >> exitFailure +-- > loop acc (Many rs k) = loop (acc + sumSalaries rs) =<< feed k +-- > loop acc (Done rs) = putStrLn $ "Total salaries: " ++ +-- > show (sumSalaries rs + acc) +-- > +-- > feed k = do +-- > isEof <- hIsEOF csvFile +-- > if isEof +-- > then return $ k B.empty +-- > else k `fmap` B.hGetSome csvFile 4096 +-- > loop 0 (decode NoHeader) +-- > where +-- > sumSalaries rs = sum [salary | Right (_ :: String, salary :: Int) <- rs] +-- +-- Encoding example: +-- +-- > data Person = Person { name :: !String, salary :: !Int } +-- > deriving Generic +-- > +-- > instance FromNamedRecord Person +-- > instance ToNamedRecord Person +-- > instance DefaultOrdered Person +-- > +-- > persons :: [Person] +-- > persons = [Person "John" 50000, Person "Jane" 60000] +-- > +-- > main :: IO () +-- > main = putStrLn $ encodeDefaultOrderedByName (go persons) +-- > where +-- > go (x:xs) = encodeNamedRecord x <> go xs +-- +module Data.Csv.Incremental + ( + -- * Decoding + HeaderParser(..) + , decodeHeader + , decodeHeaderWith + + -- $typeconversion + , Parser(..) + + -- ** Index-based record conversion + -- $indexbased + , HasHeader(..) + , decode + , decodeWith + + -- ** Name-based record conversion + -- $namebased + , decodeByName + , decodeByNameWith + + -- * Encoding + -- ** Index-based record conversion + -- $indexbased + , encode + , encodeWith + , encodeRecord + , Builder + + -- ** Name-based record conversion + -- $namebased + , encodeByName + , encodeDefaultOrderedByName + , encodeByNameWith + , encodeDefaultOrderedByNameWith + , encodeNamedRecord + , NamedBuilder + ) where + +import Control.Applicative ((<|>)) +import qualified Data.Attoparsec.ByteString as A +import Data.Attoparsec.ByteString.Char8 (endOfInput) +import qualified Data.ByteString as B +import qualified Data.ByteString.Builder as Builder +import qualified Data.ByteString.Lazy as L +import Data.Semigroup (Semigroup, (<>)) +import qualified Data.Vector as V +import Data.Word (Word8) + +import Data.Csv.Conversion hiding (Parser, header, namedRecord, record, + 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.Parser +import Data.Csv.Types +import Data.Csv.Util (endOfLine) + +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid (Monoid(mappend, mempty)) +import Control.Applicative ((<*)) +#endif + +-- $feed-header +-- +-- These functions are sometimes convenient when working with +-- 'HeaderParser', but don't let you do anything you couldn't already +-- do using the 'HeaderParser' constructors directly. + +-- $indexbased +-- +-- See documentation on index-based conversion in "Data.Csv" for more +-- information. + +-- $namebased +-- +-- See documentation on name-based conversion in "Data.Csv" for more +-- information. + +-- $feed-records +-- +-- These functions are sometimes convenient when working with +-- 'Parser', but don't let you do anything you couldn't already do +-- using the 'Parser' constructors directly. + +------------------------------------------------------------------------ +-- * Decoding headers + +-- | An incremental parser that when fed data eventually returns a +-- parsed 'Header', or an error. +data HeaderParser a = + -- | The input data was malformed. The first field contains any + -- unconsumed input and second field contains information about + -- the parse error. + FailH !B.ByteString String + + -- | The parser needs more input data before it can produce a + -- result. Use an 'B.empty' string to indicate that no more + -- input data is available. If fed an 'B.empty string', the + -- continuation is guaranteed to return either 'FailH' or + -- 'DoneH'. + | PartialH (B.ByteString -> HeaderParser a) + + -- | The parse succeeded and produced the given 'Header'. + | DoneH !Header a + deriving Functor + +instance Show a => Show (HeaderParser a) where + showsPrec d (FailH rest msg) = showParen (d > appPrec) showStr + where + showStr = showString "FailH " . showsPrec (appPrec+1) rest . + showString " " . showsPrec (appPrec+1) msg + showsPrec _ (PartialH _) = showString "PartialH " + showsPrec d (DoneH hdr x) = showParen (d > appPrec) showStr + where + showStr = showString "DoneH " . showsPrec (appPrec+1) hdr . + showString " " . showsPrec (appPrec+1) x + +-- Application has precedence one more than the most tightly-binding +-- operator +appPrec :: Int +appPrec = 10 + +-- | Parse a CSV header in an incremental fashion. When done, the +-- 'HeaderParser' returns any unconsumed input in the second field of +-- the 'DoneH' constructor. +decodeHeader :: HeaderParser B.ByteString +decodeHeader = decodeHeaderWith defaultDecodeOptions + +-- | Like 'decodeHeader', but lets you customize how the CSV data is +-- parsed. +decodeHeaderWith :: DecodeOptions -> HeaderParser B.ByteString +decodeHeaderWith !opts = PartialH (go . parser) + where + parser = A.parse (header $ decDelimiter opts) + + go (A.Fail rest _ msg) = FailH rest err + where err = "parse error (" ++ msg ++ ")" + -- TODO: Check empty and give attoparsec one last chance to return + -- something: + go (A.Partial k) = PartialH $ \ s -> go (k s) + go (A.Done rest r) = DoneH r rest + +------------------------------------------------------------------------ +-- * Decoding records + +-- $typeconversion +-- +-- Just like in the case of non-incremental decoding, there are two +-- ways to convert CSV records to and from and user-defined data +-- types: index-based conversion and name-based conversion. + +-- | An incremental parser that when fed data eventually produces some +-- parsed records, converted to the desired type, or an error in case +-- of malformed input data. +data Parser a = + -- | The input data was malformed. The first field contains any + -- unconsumed input and second field contains information about + -- the parse error. + Fail !B.ByteString String + + -- | The parser parsed and converted zero or more records. Any + -- records that failed type conversion are returned as @'Left' + -- errMsg@ and the rest as @'Right' val@. Feed a 'B.ByteString' + -- to the continuation to continue parsing. Use an 'B.empty' + -- string to indicate that no more input data is available. If + -- fed an 'B.empty' string, the continuation is guaranteed to + -- return either 'Fail' or 'Done'. + | Many [Either String a] (B.ByteString -> Parser a) + + -- | The parser parsed and converted some records. Any records + -- that failed type conversion are returned as @'Left' errMsg@ + -- and the rest as @'Right' val@. + | Done [Either String a] + deriving Functor + +instance Show a => Show (Parser a) where + showsPrec d (Fail rest msg) = showParen (d > appPrec) showStr + where + showStr = showString "Fail " . showsPrec (appPrec+1) rest . + showString " " . showsPrec (appPrec+1) msg + showsPrec d (Many rs _) = showParen (d > appPrec) showStr + where + showStr = showString "Many " . showsPrec (appPrec+1) rs . + showString " " + showsPrec d (Done rs) = showParen (d > appPrec) showStr + where + showStr = showString "Done " . showsPrec (appPrec+1) rs + +-- | Have we read all available input? +data More = Incomplete | Complete + deriving (Eq, Show) + +-- | Efficiently deserialize CSV in an incremental fashion. Equivalent +-- to @'decodeWith' 'defaultDecodeOptions'@. +decode :: FromRecord a + => HasHeader -- ^ Data contains header that should be + -- skipped + -> Parser a +decode = decodeWith defaultDecodeOptions + +-- | Like 'decode', but lets you customize how the CSV data is parsed. +decodeWith :: FromRecord a + => DecodeOptions -- ^ Decoding options + -> HasHeader -- ^ Data contains header that should be + -- skipped + -> Parser a +decodeWith !opts hasHeader = case hasHeader of + HasHeader -> go (decodeHeaderWith opts) + NoHeader -> Many [] $ \ s -> decodeWithP parseRecord opts s + where go (FailH rest msg) = Fail rest msg + go (PartialH k) = Many [] $ \ s' -> go (k s') + go (DoneH _ rest) = decodeWithP parseRecord opts rest + +------------------------------------------------------------------------ + +-- | Efficiently deserialize CSV in an incremental fashion. The data +-- is assumed to be preceeded by a header. Returns a 'HeaderParser' +-- that when done produces a 'Parser' for parsing the actual records. +-- Equivalent to @'decodeByNameWith' 'defaultDecodeOptions'@. +decodeByName :: FromNamedRecord a + => HeaderParser (Parser a) +decodeByName = decodeByNameWith defaultDecodeOptions + +-- | Like 'decodeByName', but lets you customize how the CSV data is +-- parsed. +decodeByNameWith :: FromNamedRecord a + => DecodeOptions -- ^ Decoding options + -> HeaderParser (Parser a) +decodeByNameWith !opts = go (decodeHeaderWith opts) + where + go (FailH rest msg) = FailH rest msg + go (PartialH k) = PartialH $ \ s -> go (k s) + go (DoneH hdr rest) = + DoneH hdr (decodeWithP (parseNamedRecord . toNamedRecord hdr) opts rest) + +------------------------------------------------------------------------ + +-- TODO: 'decodeWithP' should probably not take an initial +-- 'B.ByteString' input. + +-- | Like 'decode', but lets you customize how the CSV data is parsed. +decodeWithP :: (Record -> Conversion.Parser a) -> DecodeOptions -> B.ByteString + -> Parser a +decodeWithP p !opts = go Incomplete [] . parser + where + go !_ !acc (A.Fail rest _ msg) + | null acc = Fail rest err + | otherwise = Many (reverse acc) (\ s -> Fail (rest `B.append` s) err) + where err = "parse error (" ++ msg ++ ")" + go Incomplete acc (A.Partial k) = Many (reverse acc) cont + where cont s = go m [] (k s) + where m | B.null s = Complete + | otherwise = Incomplete + go Complete _ (A.Partial _) = moduleError "decodeWithP" msg + where msg = "attoparsec should never return Partial in this case" + go m acc (A.Done rest r) + | B.null rest = case m of + Complete -> Done (reverse acc') + Incomplete -> Many (reverse acc') (cont []) + | otherwise = go m acc' (parser rest) + where cont acc'' s + | B.null s = Done (reverse acc'') + | otherwise = go Incomplete acc'' (parser s) + acc' | blankLine r = acc + | otherwise = let !r' = convert r in r' : acc + + parser = A.parse (record (decDelimiter opts) <* (endOfLine <|> endOfInput)) + convert = runParser . p +{-# INLINE decodeWithP #-} + +blankLine :: V.Vector B.ByteString -> Bool +blankLine v = V.length v == 1 && (B.null (V.head v)) + +------------------------------------------------------------------------ +-- * Encoding + +-- | Efficiently serialize records in an incremental +-- fashion. Equivalent to @'encodeWith' 'defaultEncodeOptions'@. +encode :: ToRecord a => Builder a -> L.ByteString +encode = encodeWith Encoding.defaultEncodeOptions + +-- | Like 'encode', but lets you customize how the CSV data is +-- encoded. +encodeWith :: ToRecord a => EncodeOptions -> Builder a + -> L.ByteString +encodeWith opts b = + Builder.toLazyByteString $ + runBuilder b (encQuoting opts) (encDelimiter opts) (encUseCrLf opts) + +-- | Encode a single record. +encodeRecord :: ToRecord a => a -> Builder a +encodeRecord r = Builder $ \ qtng delim useCrLf -> + Encoding.encodeRecord qtng delim (toRecord r) <> recordSep useCrLf + +-- | A builder for building the CSV data incrementally. Just like the +-- @ByteString@ builder, this builder should be used in a +-- right-associative, 'foldr' style. Using '<>' to compose builders in +-- a left-associative, `foldl'` style makes the building not be +-- incremental. +newtype Builder a = Builder { + runBuilder :: Quoting -> Word8 -> Bool -> Builder.Builder + } + +-- | @since 0.5.0.0 +instance Semigroup (Builder a) where + Builder f <> Builder g = + Builder $ \ qtng delim useCrlf -> + f qtng delim useCrlf <> g qtng delim useCrlf + +instance Monoid (Builder a) where + mempty = Builder (\ _ _ _ -> mempty) + mappend = (<>) + +------------------------------------------------------------------------ +-- ** Index-based record conversion + +-- | Efficiently serialize named records in an incremental fashion, +-- including the leading header. Equivalent to @'encodeWith' +-- 'defaultEncodeOptions'@. The header is written before any records +-- and dictates the field order. +encodeByName :: ToNamedRecord a => Header -> NamedBuilder a -> L.ByteString +encodeByName = encodeByNameWith Encoding.defaultEncodeOptions + +-- | Like 'encodeByName', but header and field order is dictated by +-- the 'Conversion.headerOrder' method. +encodeDefaultOrderedByName :: (DefaultOrdered a, ToNamedRecord a) => + NamedBuilder a -> L.ByteString +encodeDefaultOrderedByName = + encodeDefaultOrderedByNameWith Encoding.defaultEncodeOptions + +-- | Like 'encodeByName', but lets you customize how the CSV data is +-- encoded. +encodeByNameWith :: ToNamedRecord a => EncodeOptions -> Header -> NamedBuilder a + -> L.ByteString +encodeByNameWith opts hdr b = + Builder.toLazyByteString $ + encHdr <> + runNamedBuilder b hdr (encQuoting opts) (encDelimiter opts) + (encUseCrLf opts) + where + encHdr + | encIncludeHeader opts = + Encoding.encodeRecord (encQuoting opts) (encDelimiter opts) hdr + <> recordSep (encUseCrLf opts) + | otherwise = mempty + +-- | Like 'encodeDefaultOrderedByName', but lets you customize how the +-- CSV data is encoded. +encodeDefaultOrderedByNameWith :: + forall a. (DefaultOrdered a, ToNamedRecord a) => + EncodeOptions -> NamedBuilder a -> L.ByteString +encodeDefaultOrderedByNameWith opts b = + Builder.toLazyByteString $ + encHdr <> + runNamedBuilder b hdr (encQuoting opts) + (encDelimiter opts) (encUseCrLf opts) + where + hdr = Conversion.headerOrder (undefined :: a) + + encHdr + | encIncludeHeader opts = + Encoding.encodeRecord (encQuoting opts) (encDelimiter opts) hdr + <> recordSep (encUseCrLf opts) + | otherwise = mempty + +-- | Encode a single named record. +encodeNamedRecord :: ToNamedRecord a => a -> NamedBuilder a +encodeNamedRecord nr = NamedBuilder $ \ hdr qtng delim useCrLf -> + Encoding.encodeNamedRecord hdr qtng delim + (Conversion.toNamedRecord nr) <> recordSep useCrLf + +-- | A builder for building the CSV data incrementally. Just like the +-- @ByteString@ builder, this builder should be used in a +-- 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 + } + +-- | @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 + +instance Monoid (NamedBuilder a) where + mempty = NamedBuilder (\ _ _ _ _ -> mempty) + mappend = (<>) + +------------------------------------------------------------------------ + +moduleError :: String -> String -> a +moduleError func msg = error $ "Data.Csv.Incremental." ++ func ++ ": " ++ msg +{-# NOINLINE moduleError #-} diff --git a/Data/Csv/Parser.hs b/Data/Csv/Parser.hs new file mode 100644 --- /dev/null +++ b/Data/Csv/Parser.hs @@ -0,0 +1,191 @@ +{-# LANGUAGE BangPatterns, CPP #-} + +-- | 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 Data.Csv.Parser + ( DecodeOptions(..) + , defaultDecodeOptions + , csv + , csvWithHeader + , header + , record + , name + , field + ) where + +import Data.ByteString.Builder (byteString, toLazyByteString, charUtf8) +import Control.Applicative (optional) +import Data.Attoparsec.ByteString.Char8 (char, endOfInput) +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 Data.Word (Word8) + +import Data.Csv.Types +import Data.Csv.Util ((<$!>), blankLine, endOfLine, liftM2', cr, newline, doubleQuote, toStrict) + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>), (*>), (<*), pure) +import Data.Monoid (mappend, mempty) +#endif + +-- | Options that controls how data is decoded. These options can be +-- used to e.g. decode tab-separated data instead of comma-separated +-- data. +-- +-- To avoid having your program stop compiling when new fields are +-- added to 'DecodeOptions', create option records by overriding +-- values in 'defaultDecodeOptions'. Example: +-- +-- > myOptions = defaultDecodeOptions { +-- > decDelimiter = fromIntegral (ord '\t') +-- > } +data DecodeOptions = DecodeOptions + { -- | Field delimiter. + decDelimiter :: {-# UNPACK #-} !Word8 + } deriving (Eq, Show) + +-- | Decoding options for parsing CSV files. +defaultDecodeOptions :: DecodeOptions +defaultDecodeOptions = DecodeOptions + { decDelimiter = 44 -- comma + } + +-- | Parse a CSV file that does not include a header. +csv :: DecodeOptions -> AL.Parser Csv +csv !opts = do + vals <- sepByEndOfLine1' (record (decDelimiter opts)) + _ <- optional endOfLine + endOfInput + let nonEmpty = removeBlankLines vals + return $! V.fromList nonEmpty +{-# INLINE csv #-} + +-- | 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 CSV file that includes a header. +csvWithHeader :: DecodeOptions -> AL.Parser (Header, V.Vector NamedRecord) +csvWithHeader !opts = do + !hdr <- header (decDelimiter opts) + vals <- map (toNamedRecord hdr) . removeBlankLines <$> + sepByEndOfLine1' (record (decDelimiter opts)) + _ <- optional endOfLine + endOfInput + let !v = V.fromList vals + return (hdr, v) + +-- | Parse a header, including the terminating line separator. +header :: Word8 -- ^ Field delimiter + -> AL.Parser Header +header !delim = V.fromList <$!> name delim `sepByDelim1'` delim <* endOfLine + +-- | Parse a header name. Header names have the same format as regular +-- 'field's. +name :: Word8 -> AL.Parser Name +name !delim = field delim + +removeBlankLines :: [Record] -> [Record] +removeBlankLines = filter (not . blankLine) + +-- | 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. +record :: Word8 -- ^ Field delimiter + -> AL.Parser Record +record !delim = V.fromList <$!> field delim `sepByDelim1'` delim +{-# INLINE record #-} + +-- | Parse a field. The field may be in either the escaped or +-- non-escaped format. The return value is unescaped. +field :: Word8 -> AL.Parser Field +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 '"' + +unescape :: Z.Parser S.ByteString +unescape = (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` charUtf8 '"') + else fail "invalid CSV escape sequence" + done <- Z.atEnd + if done + then return (acc `mappend` byteString h) + else rest diff --git a/Data/Csv/Streaming.hs b/Data/Csv/Streaming.hs new file mode 100644 --- /dev/null +++ b/Data/Csv/Streaming.hs @@ -0,0 +1,194 @@ +{-# LANGUAGE BangPatterns, CPP, DeriveFunctor #-} + +-- | This module allows for streaming decoding of CSV data. This is +-- useful if you need to parse large amounts of input in constant +-- space. The API also allows you to ignore type conversion errors on +-- a per-record basis. +module Data.Csv.Streaming + ( + -- * Usage example + -- $example + + -- * Stream representation + -- $stream-representation + Records(..) + + -- * Decoding records + -- $typeconversion + + -- ** Index-based record conversion + -- $indexbased + , HasHeader(..) + , decode + , decodeWith + + -- ** Name-based record conversion + -- $namebased + , decodeByName + , decodeByNameWith + ) where + +import Control.DeepSeq (NFData(rnf)) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Lazy.Char8 as BL8 +import Data.Foldable (Foldable(..)) +import Prelude hiding (foldr) + +import Data.Csv.Conversion +import Data.Csv.Incremental hiding (decode, decodeByName, decodeByNameWith, + decodeWith) +import qualified Data.Csv.Incremental as I +import Data.Csv.Parser +import Data.Csv.Types + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>), (<*>), pure) +import Data.Traversable (Traversable(..)) +#endif + +#if !MIN_VERSION_bytestring(0,10,0) +import qualified Data.ByteString.Lazy.Internal as BL -- for constructors +#endif + +-- $example +-- +-- A short usage example: +-- +-- > for_ (decode NoHeader "John,27\r\nJane,28\r\n") $ \ (name, age :: Int) -> +-- > putStrLn $ name ++ " is " ++ show age ++ " years old" +-- +-- N.B. The 'Foldable' instance, which is used above, skips records +-- that failed to convert. If you don't want this behavior, work +-- directly with the 'Cons' and 'Nil' constructors. + +-- $stream-representation +-- +-- A stream of records is represented as a (lazy) list that may +-- contain errors. + +-- $typeconversion +-- +-- Just like in the case of non-streaming decoding, there are two ways +-- to convert CSV records to and from and user-defined data types: +-- index-based conversion and name-based conversion. + +-- $indexbased +-- +-- See documentation on index-based conversion in "Data.Csv" for more +-- information. + +-- $namebased +-- +-- See documentation on name-based conversion in "Data.Csv" for more +-- information. + +-- | A stream of parsed records. If type conversion failed for the +-- record, the error is returned as @'Left' errMsg@. +data Records a + = -- | A record or an error message, followed by more records. + Cons (Either String a) (Records a) + + -- | End of stream, potentially due to a parse error. If a parse + -- error occured, the first field contains the error message. + -- The second field contains any unconsumed input. + | Nil (Maybe String) BL.ByteString + deriving (Eq, Functor, Show) + +-- | Skips records that failed to convert. +instance Foldable Records where + foldr = foldrRecords +#if MIN_VERSION_base(4,6,0) + foldl' = foldlRecords' +#endif + +foldrRecords :: (a -> b -> b) -> b -> Records a -> b +foldrRecords f = go + where + go z (Cons (Right x) rs) = f x (go z rs) + go z (Cons (Left _) rs) = go z rs + go z _ = z +{-# INLINE foldrRecords #-} + +#if MIN_VERSION_base(4,6,0) +foldlRecords' :: (a -> b -> a) -> a -> Records b -> a +foldlRecords' f = go + where + go z (Cons (Right x) rs) = let z' = f z x in z' `seq` go z' rs + go z (Cons (Left _) rs) = go z rs + go z _ = z +{-# INLINE foldlRecords' #-} +#endif + +instance Traversable Records where + traverse _ (Nil merr rest) = pure $ Nil merr rest + traverse f (Cons x xs) = Cons <$> traverseElem x <*> traverse f xs + where + traverseElem (Left err) = pure $ Left err + traverseElem (Right y) = Right <$> f y + +instance NFData a => NFData (Records a) where + rnf (Cons r rs) = rnf r `seq` rnf rs +#if MIN_VERSION_bytestring(0,10,0) + rnf (Nil errMsg rest) = rnf errMsg `seq` rnf rest +#else + rnf (Nil errMsg rest) = rnf errMsg `seq` rnfLazyByteString rest + +rnfLazyByteString :: BL.ByteString -> () +rnfLazyByteString BL.Empty = () +rnfLazyByteString (BL.Chunk _ b) = rnfLazyByteString b +#endif + +-- | Efficiently deserialize CSV records in a streaming fashion. +-- Equivalent to @'decodeWith' 'defaultDecodeOptions'@. +decode :: FromRecord a + => HasHeader -- ^ Data contains header that should be + -- skipped + -> BL.ByteString -- ^ CSV data + -> Records a +decode = decodeWith defaultDecodeOptions + +-- | Like 'decode', but lets you customize how the CSV data is parsed. +decodeWith :: FromRecord a + => DecodeOptions -- ^ Decoding options + -> HasHeader -- ^ Data contains header that should be + -- skipped + -> BL.ByteString -- ^ CSV data + -> Records a +decodeWith !opts hasHeader s0 = + go (BL.toChunks s0) (I.decodeWith 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)) + go [] (Many xs k) = foldr Cons (go [] (k B.empty)) xs + go (s:ss) (Many xs k) = foldr Cons (go ss (k s)) xs + +-- | Efficiently deserialize CSV in a streaming fashion. The data is +-- assumed to be preceeded by a header. Returns @'Left' errMsg@ if +-- parsing the header fails. Equivalent to @'decodeByNameWith' +-- 'defaultDecodeOptions'@. +decodeByName :: FromNamedRecord a + => BL.ByteString -- ^ CSV data + -> Either String (Header, Records a) +decodeByName = decodeByNameWith defaultDecodeOptions + +-- TODO: Include something more in error messages? + +-- | Like 'decodeByName', but lets you customize how the CSV data is +-- parsed. +decodeByNameWith :: FromNamedRecord a + => DecodeOptions -- ^ Decoding options + -> BL.ByteString -- ^ CSV data + -> Either String (Header, Records a) +decodeByNameWith !opts s0 = go (BL.toChunks s0) (I.decodeByNameWith opts) + where + go ss (DoneH hdr p) = Right (hdr, go2 ss p) + go ss (FailH rest err) = Left $ err ++ " at " ++ + show (BL8.unpack . BL.fromChunks $ rest : ss) + go [] (PartialH k) = go [] (k B.empty) + go (s:ss) (PartialH k) = go ss (k s) + + go2 ss (Done xs) = foldr Cons (Nil Nothing (BL.fromChunks ss)) xs + go2 ss (Fail rest err) = Nil (Just err) (BL.fromChunks (rest:ss)) + go2 [] (Many xs k) = foldr Cons (go2 [] (k B.empty)) xs + go2 (s:ss) (Many xs k) = foldr Cons (go2 ss (k s)) xs diff --git a/Data/Csv/Types.hs b/Data/Csv/Types.hs new file mode 100644 --- /dev/null +++ b/Data/Csv/Types.hs @@ -0,0 +1,50 @@ +module Data.Csv.Types + ( + -- * Core CSV types + Csv + , Record + , Header + , Name + , NamedRecord + , Field + , toNamedRecord + + -- * Header handling + , HasHeader(..) + ) where + +import qualified Data.ByteString as S +import qualified Data.HashMap.Strict as HM +import Data.Vector (Vector) +import qualified Data.Vector as V + +-- | CSV data represented as a Haskell vector of vector of +-- bytestrings. +type Csv = Vector Record + +-- | A record corresponds to a single line in a CSV file. +type Record = Vector Field + +-- | The header corresponds to the first line a CSV file. Not all CSV +-- files have a header. +type Header = Vector Name + +-- | A header has one or more names, describing the data in the column +-- following the name. +type Name = S.ByteString + +-- | A record corresponds to a single line in a CSV file, indexed by +-- the column name rather than the column index. +type NamedRecord = HM.HashMap S.ByteString S.ByteString + +-- | A single field within a record. +type Field = S.ByteString + +-- | Convert a 'Record' to a 'NamedRecord' by attaching column names. +-- The 'Header' and 'Record' must be of the same length. +toNamedRecord :: Header -> Record -> NamedRecord +toNamedRecord hdr v = HM.fromList . V.toList $ V.zip hdr v + +-- | Is the CSV data preceded by a header? +data HasHeader = HasHeader -- ^ The CSV data is preceded by a header + | NoHeader -- ^ The CSV data is not preceded by a header diff --git a/Data/Csv/Util.hs b/Data/Csv/Util.hs new file mode 100644 --- /dev/null +++ b/Data/Csv/Util.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE BangPatterns, CPP, OverloadedStrings #-} + +module Data.Csv.Util + ( (<$!>) + , blankLine + , liftM2' + , endOfLine + , doubleQuote + , newline + , cr + , toStrict + ) where + +import Control.Applicative ((<|>)) +import Data.Word (Word8) +import Data.Attoparsec.ByteString.Char8 (string) +import qualified Data.Attoparsec.ByteString as A +import qualified Data.ByteString as B +import qualified Data.Vector as V +import Data.Attoparsec.ByteString (Parser) + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((*>)) +#endif + +#if MIN_VERSION_bytestring(0,10,0) +import Data.ByteString.Lazy (toStrict) +#else +import qualified Data.ByteString.Lazy as L + +toStrict :: L.ByteString -> B.ByteString +toStrict = B.concat . L.toChunks +#endif + +-- | 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 :: Parser () +endOfLine = (A.word8 newline *> return ()) <|> (string "\r\n" *> return ()) <|> (A.word8 cr *> return ()) +{-# INLINE endOfLine #-} + +doubleQuote, newline, cr :: Word8 +doubleQuote = 34 +newline = 10 +cr = 13 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c)2012, Johan Tibell + +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 Johan Tibell 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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,98 @@ +# `cassava`: A CSV parsing and encoding library [![Hackage](https://img.shields.io/hackage/v/cassava.svg)](https://hackage.haskell.org/package/cassava) [![Build Status](https://travis-ci.org/hvr/cassava.svg)](https://travis-ci.org/hvr/cassava) + +**Please refer to the [package description](https://hackage.haskell.org/package/cassava#description) for an overview of `cassava`.** + +## Usage example + +Here's the two second crash course in using the library. Given a CSV file with this content: + +```csv +John Doe,50000 +Jane Doe,60000 +``` + +here's how you'd process it record-by-record: + +```haskell +{-# LANGUAGE ScopedTypeVariables #-} + +import qualified Data.ByteString.Lazy as BL +import Data.Csv +import qualified Data.Vector as V + +main :: IO () +main = do + csvData <- BL.readFile "salaries.csv" + case decode NoHeader csvData of + Left err -> putStrLn err + Right v -> V.forM_ v $ \ (name, salary :: Int) -> + putStrLn $ name ++ " earns " ++ show salary ++ " dollars" +``` + +If you want to parse a file that includes a header, like this one + +```csv +name,salary +John Doe,50000 +Jane Doe,60000 +``` + +use [`decodeByName`](https://hackage.haskell.org/package/cassava/docs/Data-Csv.html#v:decodeByName): + +```haskell +{-# LANGUAGE OverloadedStrings #-} + +import Control.Applicative +import qualified Data.ByteString.Lazy as BL +import Data.Csv +import qualified Data.Vector as V + +data Person = Person + { name :: !String + , salary :: !Int + } + +instance FromNamedRecord Person where + parseNamedRecord r = Person <$> r .: "name" <*> r .: "salary" + +main :: IO () +main = do + csvData <- BL.readFile "salaries.csv" + case decodeByName csvData of + Left err -> putStrLn err + Right (_, v) -> V.forM_ v $ \ p -> + putStrLn $ name p ++ " earns " ++ show (salary p) ++ " dollars" +``` + +You can find more code examples in the [`examples/` folder](https://github.com/hvr/cassava/tree/master/examples) as well as smaller usage examples in the [`Data.Csv` module documentation](https://hackage.haskell.org/package/cassava/docs/Data-Csv.html). + +## Project Goals for `cassava` + +There's no end to what people consider CSV data. Most programs don't +follow [RFC4180](https://tools.ietf.org/html/rfc4180) so one has to +make a judgment call which contributions to accept. Consequently, not +everything gets accepted, because then we'd end up with a (slow) +general purpose parsing library. There are plenty of those. The goal +is to roughly accept what the Python +[`csv`](https://docs.python.org/3/library/csv.html) module accepts. + +The Python `csv` module (which is implemented in C) is also considered +the base-line for performance. Adding options (e.g. the above +mentioned parsing "flexibility") will have to be a trade off against +performance. There's been complaints about performance in the past, +therefore, if in doubt performance wins over features. + +Last but not least, it's important to keep the dependency footprint +light, as each additional dependency incurs costs and risks in terms +of additional maintenance overhead and loss of flexibility. So adding +a new package dependency should only be done if that dependency is +known to be a reliable package and there's a clear benefit which +outweights the cost. + +## Further reading + +The primary API documentation for `cassava` is its Haddock documentation which can be found at http://hackage.haskell.org/package/cassava/docs/Data-Csv.html + +Below are listed additional recommended third-party blogposts and tutorials + + - [CSV encoding and decoding in Haskell with Cassava](https://www.stackbuilders.com/tutorials/haskell/csv-encoding-decoding/) diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/examples/IncrementalIndexedBasedDecode.hs b/examples/IncrementalIndexedBasedDecode.hs new file mode 100644 --- /dev/null +++ b/examples/IncrementalIndexedBasedDecode.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE BangPatterns, ScopedTypeVariables #-} + +import Control.Monad +import qualified Data.ByteString as B +import Data.Csv.Incremental +import System.Exit +import System.IO + +main :: IO () +main = withFile "salaries.csv" ReadMode $ \ csvFile -> do + let loop !_ (Fail _ errMsg) = putStrLn errMsg >> exitFailure + loop acc (Many rs k) = loop (acc + sumSalaries rs) =<< feed k + loop acc (Done rs) = putStrLn $ "Total salaries: " ++ + show (sumSalaries rs + acc) + + feed k = do + isEof <- hIsEOF csvFile + if isEof + then return $ k B.empty + else k `fmap` B.hGetSome csvFile 4096 + loop 0 (decode NoHeader) + where + sumSalaries rs = sum [salary | Right (_ :: String, salary :: Int) <- rs] diff --git a/examples/IncrementalNamedBasedEncode.hs b/examples/IncrementalNamedBasedEncode.hs new file mode 100644 --- /dev/null +++ b/examples/IncrementalNamedBasedEncode.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE DeriveGeneric #-} +import qualified Data.ByteString.Lazy as L +import Data.Csv hiding (encodeDefaultOrderedByName) +import Data.Csv.Incremental +import Data.Monoid +import GHC.Generics + +data Person = Person + { name :: !String + , salary :: !Int + } + deriving Generic + +instance FromNamedRecord Person +instance ToNamedRecord Person +instance DefaultOrdered Person + +persons :: [Person] +persons = [Person "John" 50000, Person "Jane" 60000] + +main :: IO () +main = L.putStrLn $ encodeDefaultOrderedByName (go persons) + where + go (x:xs) = encodeNamedRecord x <> go xs diff --git a/examples/IndexBasedDecode.hs b/examples/IndexBasedDecode.hs new file mode 100644 --- /dev/null +++ b/examples/IndexBasedDecode.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +import qualified Data.ByteString.Lazy as BL +import Data.Csv +import qualified Data.Vector as V + +main :: IO () +main = do + csvData <- BL.readFile "salaries.csv" + case decode NoHeader csvData of + Left err -> putStrLn err + Right v -> V.forM_ v $ \ (name, salary :: Int) -> + putStrLn $ name ++ " earns " ++ show salary ++ " dollars" diff --git a/examples/IndexBasedGeneric.hs b/examples/IndexBasedGeneric.hs new file mode 100644 --- /dev/null +++ b/examples/IndexBasedGeneric.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE ScopedTypeVariables, DeriveGeneric #-} + +import qualified Data.ByteString.Lazy as BL +import Data.Csv +import qualified Data.Vector as V +import GHC.Generics + +data Person = Person String Int deriving Generic + +instance FromRecord Person +instance ToRecord Person + +persons :: [Person] +persons = [Person "John" 50000, Person "Jane" 60000] + +main :: IO () +main = do + BL.writeFile "salaries.csv" $ encode persons + csvData <- BL.readFile "salaries.csv" + case decode NoHeader csvData of + Left err -> putStrLn err + Right v -> V.forM_ v $ \ (Person name salary) -> + putStrLn $ name ++ " earns " ++ show salary ++ " dollars" diff --git a/examples/NamedBasedDecode.hs b/examples/NamedBasedDecode.hs new file mode 100644 --- /dev/null +++ b/examples/NamedBasedDecode.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE OverloadedStrings #-} + +import Control.Applicative +import qualified Data.ByteString.Lazy as BL +import Data.Csv +import qualified Data.Vector as V + +data Person = Person + { name :: String + , salary :: Int + } + +instance FromNamedRecord Person where + parseNamedRecord r = Person <$> r .: "name" <*> r .: "salary" + +main :: IO () +main = do + csvData <- BL.readFile "salaries.csv" + case decodeByName csvData of + Left err -> putStrLn err + Right (_, v) -> V.forM_ v $ \ p -> + putStrLn $ name p ++ " earns " ++ show (salary p) ++ " dollars" diff --git a/examples/NamedBasedGeneric.hs b/examples/NamedBasedGeneric.hs new file mode 100644 --- /dev/null +++ b/examples/NamedBasedGeneric.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE OverloadedStrings, DeriveGeneric #-} + +import qualified Data.ByteString.Lazy as BL +import Data.Csv +import Data.Text (Text) +import qualified Data.Vector as V +import GHC.Generics + +data Person = Person + { name :: !String + , salary :: !Int + } + deriving Generic + +instance FromNamedRecord Person +instance ToNamedRecord Person +instance DefaultOrdered Person + +persons :: [Person] +persons = [Person "John" 50000, Person "Jane" 60000] + +main :: IO () +main = do + BL.writeFile "salaries.csv" $ encodeDefaultOrderedByName persons + csvData <- BL.readFile "salaries.csv" + case decodeByName csvData of + Left err -> putStrLn err + Right (_, v) -> V.forM_ v $ \ p -> + putStrLn $ name p ++ " earns " ++ show (salary p) ++ " dollars" diff --git a/examples/StreamingIndexBasedDecode.hs b/examples/StreamingIndexBasedDecode.hs new file mode 100644 --- /dev/null +++ b/examples/StreamingIndexBasedDecode.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +import qualified Data.ByteString.Lazy as BL +import Data.Csv.Streaming +import Data.Foldable (for_) + +main :: IO () +main = do + csvData <- BL.readFile "salaries.csv" + -- N.B. The Foldable instance skips records that failed to + -- convert. + for_ (decode NoHeader csvData) $ \ (name, salary :: Int) -> + putStrLn $ name ++ " earns " ++ show salary ++ " dollars" diff --git a/tests/UnitTests.hs b/tests/UnitTests.hs new file mode 100644 --- /dev/null +++ b/tests/UnitTests.hs @@ -0,0 +1,454 @@ +{-# LANGUAGE CPP, DeriveGeneric, OverloadedStrings, ScopedTypeVariables #-} + +#if __GLASGOW_HASKELL__ >= 801 +{-# OPTIONS_GHC -Wno-orphans -Wno-unused-top-binds #-} +#else +{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-unused-binds #-} +#endif + +module Main + ( main + ) where + +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Lazy.Char8 as BL8 +import qualified Data.HashMap.Strict as HM +import Data.Int +import Data.Scientific (Scientific) +import qualified Data.Text as T +import qualified Data.Text.Lazy as LT +import qualified Data.Vector as V +import qualified Data.Foldable as F +import Data.Word +import Numeric.Natural +import GHC.Generics (Generic) +import Test.HUnit +import Test.Framework as TF +import Test.Framework.Providers.HUnit as TF +import Test.QuickCheck +import Test.QuickCheck.Instances () +import Test.Framework.Providers.QuickCheck2 as TF + +import Data.Csv hiding (record) +import qualified Data.Csv.Streaming as S + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>), (<*>)) +#endif + +------------------------------------------------------------------------ +-- Parse tests + +decodesAs :: BL.ByteString -> [[B.ByteString]] -> Assertion +decodesAs input expected = assertResult input expected $ decode NoHeader input + +decodesWithAs :: DecodeOptions -> BL.ByteString -> [[B.ByteString]] -> Assertion +decodesWithAs opts input expected = + assertResult input expected $ decodeWith opts NoHeader input + +assertResult :: BL.ByteString -> [[B.ByteString]] + -> Either String (V.Vector (V.Vector B.ByteString)) -> Assertion +assertResult input expected res = case res of + Right r -> V.fromList (map V.fromList expected) @=? r + Left err -> assertFailure $ + " input: " ++ show (BL8.unpack input) ++ "\n" ++ + "parse error: " ++ err + +encodesAs :: [[B.ByteString]] -> BL.ByteString -> Assertion +encodesAs input expected = + encode (map V.fromList input) @?= expected + +encodesWithAs :: EncodeOptions -> [[B.ByteString]] -> BL.ByteString -> Assertion +encodesWithAs opts input expected = + encodeWith opts (map V.fromList input) @?= expected + +namedEncodesAs :: [B.ByteString] -> [[(B.ByteString, B.ByteString)]] + -> BL.ByteString -> Assertion +namedEncodesAs hdr input expected = + encodeByName (V.fromList hdr) (map HM.fromList input) @?= expected + +namedEncodesWithAs :: EncodeOptions -> [B.ByteString] + -> [[(B.ByteString, B.ByteString)]] + -> BL.ByteString -> Assertion +namedEncodesWithAs opts hdr input expected = + encodeByNameWith opts (V.fromList hdr) (map HM.fromList input) @?= expected + +namedDecodesAs :: BL.ByteString -> [B.ByteString] + -> [[(B.ByteString, B.ByteString)]] -> Assertion +namedDecodesAs input ehdr expected = case decodeByName input of + Right r -> (V.fromList ehdr, expected') @=? r + Left err -> assertFailure $ + " input: " ++ show (BL8.unpack input) ++ "\n" ++ + "parse error: " ++ err + where + expected' = V.fromList $ map HM.fromList expected + +recordsToList :: S.Records a -> Either String [a] +recordsToList (S.Nil (Just err) _) = Left err +recordsToList (S.Nil Nothing _) = Right [] +recordsToList (S.Cons (Left err) _) = Left err +recordsToList (S.Cons (Right x) rs) = case recordsToList rs of + l@(Left _) -> l + (Right xs) -> Right (x : xs) + +decodesStreamingAs :: BL.ByteString -> [[B.ByteString]] -> Assertion +decodesStreamingAs input expected = + assertResult input expected $ fmap (V.fromList . map V.fromList) $ + recordsToList $ S.decode NoHeader input + +decodesWithStreamingAs :: DecodeOptions -> BL.ByteString -> [[B.ByteString]] + -> Assertion +decodesWithStreamingAs opts input expected = + assertResult input expected $ fmap (V.fromList . map V.fromList) $ + recordsToList $ S.decodeWith opts NoHeader input + +namedDecodesStreamingAs :: BL.ByteString -> [B.ByteString] + -> [[(B.ByteString, B.ByteString)]] -> Assertion +namedDecodesStreamingAs input ehdr expected = case S.decodeByName input of + Right (hdr, rs) -> case recordsToList rs of + Right xs -> (V.fromList ehdr, expected') @=? (hdr, xs) + Left err -> assertFailure $ + " input: " ++ show (BL8.unpack input) ++ "\n" ++ + "conversion error: " ++ err + Left err -> assertFailure $ + " input: " ++ show (BL8.unpack input) ++ "\n" ++ + "parse error: " ++ err + where + expected' = map HM.fromList expected + +positionalTests :: [TF.Test] +positionalTests = + [ testGroup "encode" $ map encodeTest + [ ("simple", [["abc"]], "abc\r\n") + , ("quoted", [["\"abc\""]], "\"\"\"abc\"\"\"\r\n") + , ("quote", [["a\"b"]], "\"a\"\"b\"\r\n") + , ("quotedQuote", [["\"a\"b\""]], "\"\"\"a\"\"b\"\"\"\r\n") + , ("leadingSpace", [[" abc"]], " abc\r\n") + , ("comma", [["abc,def"]], "\"abc,def\"\r\n") + , ("twoFields", [["abc","def"]], "abc,def\r\n") + , ("twoRecords", [["abc"], ["def"]], "abc\r\ndef\r\n") + , ("newline", [["abc\ndef"]], "\"abc\ndef\"\r\n") + ] + , testGroup "encode" $ map encodeTestUnqtd + [ ("simple", [["abc"]], "abc\r\n") + , ("quoted", [["\"abc\""]], "\"abc\"\r\n") + , ("quote", [["a\"b"]], "a\"b\r\n") + , ("quotedQuote", [["\"a\"b\""]], "\"a\"b\"\r\n") + , ("leadingSpace", [[" abc"]], " abc\r\n") + , ("comma", [["abc,def"]], "abc,def\r\n") + , ("twoFields", [["abc","def"]], "abc,def\r\n") + , ("twoRecords", [["abc"], ["def"]], "abc\r\ndef\r\n") + , ("newline", [["abc\ndef"]], "abc\ndef\r\n") + ] + , testGroup "encode" $ map encodeTestAllqtd + [ ("simple", [["abc"]], "\"abc\"\r\n") + , ("quoted", [["\"abc\""]], "\"\"\"abc\"\"\"\r\n") + , ("quote", [["a\"b"]], "\"a\"\"b\"\r\n") + , ("quotedQuote", [["\"a\"b\""]], "\"\"\"a\"\"b\"\"\"\r\n") + , ("leadingSpace", [[" abc"]], "\" abc\"\r\n") + , ("comma", [["abc,def"]], "\"abc,def\"\r\n") + , ("twoFields", [["abc","def"]], "\"abc\",\"def\"\r\n") + , ("twoRecords", [["abc"], ["def"]], "\"abc\"\r\n\"def\"\r\n") + , ("newline", [["abc\ndef"]], "\"abc\ndef\"\r\n") + ] + + , testGroup "encodeWith" + [ testCase "tab-delim" $ encodesWithAs (defEnc { encDelimiter = 9 }) + [["1", "2"]] "1\t2\r\n" + , testCase "newline" $ encodesWithAs (defEnc {encUseCrLf = False}) + [["1", "2"], ["3", "4"]] "1,2\n3,4\n" + ] + , testGroup "decode" $ map decodeTest decodeTests + , testGroup "decodeWith" $ map decodeWithTest decodeWithTests + , testGroup "streaming" + [ testGroup "decode" $ map streamingDecodeTest decodeTests + , testGroup "decodeWith" $ map streamingDecodeWithTest decodeWithTests + ] + ] + where + rfc4180Input = BL8.pack $ + "#field1,field2,field3\n" ++ + "\"aaa\",\"bb\n" ++ + "b\",\"ccc\"\n" ++ + "\"a,a\",\"b\"\"bb\",\"ccc\"\n" ++ + "zzz,yyy,xxx\n" + rfc4180Output = [["#field1", "field2", "field3"], + ["aaa", "bb\nb", "ccc"], + ["a,a", "b\"bb", "ccc"], + ["zzz", "yyy", "xxx"]] + decodeTests = + [ ("simple", "a,b,c\n", [["a", "b", "c"]]) + , ("crlf", "a,b\r\nc,d\r\n", [["a", "b"], ["c", "d"]]) + , ("noEol", "a,b,c", [["a", "b", "c"]]) + , ("blankLine", "a,b,c\n\nd,e,f\n\n", + [["a", "b", "c"], ["d", "e", "f"]]) + , ("leadingSpace", " a, b, c\n", [[" a", " b", " c"]]) + , ("rfc4180", rfc4180Input, rfc4180Output) + ] + decodeWithTests = + [ ("tab-delim", defDec { decDelimiter = 9 }, "1\t2", [["1", "2"]]) + ] + + encodeTest (name, input, expected) = + testCase name $ input `encodesAs` expected + encodeTestUnqtd (name, input, expected) = + testCase name $ encodesWithAs defEncNoneEnq input expected + encodeTestAllqtd (name, input, expected) = + testCase name $ encodesWithAs defEncAllEnq input expected + decodeTest (name, input, expected) = + testCase name $ input `decodesAs` expected + decodeWithTest (name, opts, input, expected) = + testCase name $ decodesWithAs opts input expected + streamingDecodeTest (name, input, expected) = + testCase name $ input `decodesStreamingAs` expected + streamingDecodeWithTest (name, opts, input, expected) = + testCase name $ decodesWithStreamingAs opts input expected + defEnc = defaultEncodeOptions + defEncNoneEnq = defaultEncodeOptions { encQuoting = QuoteNone } + defEncAllEnq = defaultEncodeOptions { encQuoting = QuoteAll } + defDec = defaultDecodeOptions + +nameBasedTests :: [TF.Test] +nameBasedTests = + [ testGroup "encode" $ map encodeTest + [ ("simple", ["field"], [[("field", "abc")]], "field\r\nabc\r\n") + , ("twoFields", ["field1", "field2"], + [[("field1", "abc"), ("field2", "def")]], + "field1,field2\r\nabc,def\r\n") + , ("twoRecords", ["field"], [[("field", "abc")], [("field", "def")]], + "field\r\nabc\r\ndef\r\n") + ] + , testGroup "encodeWith" $ map encodeWithTest + [ ("no header", defEnc {encIncludeHeader = False}, ["field"], + [[("field", "abc")]], "abc\r\n") + ] + , testGroup "decode" $ map decodeTest decodeTests + , testGroup "streaming" + [ testGroup "decode" $ map streamingDecodeTest decodeTests + ] + ] + where + decodeTests = + [ ("simple", "field\r\nabc\r\n", ["field"], [[("field", "abc")]]) + , ("twoFields", "field1,field2\r\nabc,def\r\n", ["field1", "field2"], + [[("field1", "abc"), ("field2", "def")]]) + , ("twoRecords", "field\r\nabc\r\ndef\r\n", ["field"], + [[("field", "abc")], [("field", "def")]]) + , ("cr header", "field\rabc", ["field"], [[("field", "abc")]]) + , ("cr trailing", "field\rabc\r", ["field"], [[("field", "abc")]]) + , ("cr separator", "field\rabc\rdef", ["field"], [[("field", "abc")],[("field","def")]]) + ] + + encodeTest (name, hdr, input, expected) = + testCase name $ namedEncodesAs hdr input expected + encodeWithTest (name, opts, hdr, input, expected) = + testCase name $ namedEncodesWithAs opts hdr input expected + decodeTest (name, input, hdr, expected) = + testCase name $ namedDecodesAs input hdr expected + streamingDecodeTest (name, input, hdr, expected) = + testCase name $ namedDecodesStreamingAs input hdr expected + defEnc = defaultEncodeOptions + +------------------------------------------------------------------------ +-- Conversion tests + +-- A single column with an empty string is indistinguishable from an +-- empty line (which we will ignore.) We therefore encode at least two +-- columns. +roundTrip :: (Eq a, FromField a, ToField a) => a -> Bool +roundTrip x = Right (V.fromList record) == decode NoHeader (encode record) + where record = [(x, dummy)] + dummy = 'a' + +roundTripUnicode :: T.Text -> Assertion +roundTripUnicode x = Right (V.fromList record) @=? + decode NoHeader (encode record) + where record = [(x, dummy)] + dummy = 'a' + +boundary :: forall a. (Bounded a, Eq a, FromField a, ToField a) => a -> Bool +boundary _dummy = roundTrip (minBound :: a) && roundTrip (maxBound :: a) + +partialDecode :: Parser a -> Assertion +partialDecode p = case runParser p of + Left _ -> return () + Right _ -> assertFailure "expected partial field decode" + +expect :: (Eq a, Show a) => Parser a -> a -> Assertion +expect p a0 = + case runParser p of + Right a -> a @=? a0 + Left e -> assertFailure e + +conversionTests :: [TF.Test] +conversionTests = + [ testGroup "roundTrip" + [ testProperty "Char" (roundTrip :: Char -> Bool) + , testProperty "ByteString" (roundTrip :: B.ByteString -> Bool) + , testProperty "Int" (roundTrip :: Int -> Bool) + , testProperty "Integer" (roundTrip :: Integer -> Bool) + , testProperty "Int8" (roundTrip :: Int8 -> Bool) + , testProperty "Int16" (roundTrip :: Int16 -> Bool) + , testProperty "Int32" (roundTrip :: Int32 -> Bool) + , testProperty "Int64" (roundTrip :: Int64 -> Bool) + , testProperty "Natural" (roundTrip :: Natural -> Bool) + , testProperty "Word" (roundTrip :: Word -> Bool) + , testProperty "Word8" (roundTrip :: Word8 -> Bool) + , testProperty "Word16" (roundTrip :: Word16 -> Bool) + , testProperty "Word32" (roundTrip :: Word32 -> Bool) + , testProperty "Word64" (roundTrip :: Word64 -> Bool) + , testProperty "Scientific" (roundTrip :: Scientific -> Bool) + , testProperty "lazy ByteString" + (roundTrip :: BL.ByteString -> Bool) + , testProperty "Text" (roundTrip :: T.Text -> Bool) + , testProperty "lazy Text" (roundTrip :: LT.Text -> Bool) + ] + , testGroup "boundary" + [ testProperty "Int" (boundary (undefined :: Int)) + , testProperty "Int8" (boundary (undefined :: Int8)) + , testProperty "Int16" (boundary (undefined :: Int16)) + , testProperty "Int32" (boundary (undefined :: Int32)) + , testProperty "Int64" (boundary (undefined :: Int64)) + , testProperty "Word" (boundary (undefined :: Word)) + , testProperty "Word8" (boundary (undefined :: Word8)) + , testProperty "Word16" (boundary (undefined :: Word16)) + , testProperty "Word32" (boundary (undefined :: Word32)) + , testProperty "Word64" (boundary (undefined :: Word64)) + ] + , testGroup "Unicode" + [ testCase "Chinese" (roundTripUnicode "我能吞下玻璃而不伤身体。") + , testCase "Icelandic" (roundTripUnicode + "Sævör grét áðan því úlpan var ónýt.") + , testCase "Turkish" (roundTripUnicode + "Cam yiyebilirim, bana zararı dokunmaz.") + ] + , testGroup "Partial Decodes" + [ testCase "Int" (partialDecode + (parseField "12.7" :: Parser Int)) + , testCase "Natural" (partialDecode + (parseField "12.7" :: Parser Natural)) + , testCase "Word" (partialDecode + (parseField "12.7" :: Parser Word)) + , testCase "Scientific" (partialDecode + (parseField "1.0+" :: Parser Scientific)) + , testCase "Double" (partialDecode + (parseField "1.0+" :: Parser Double)) + , testCase "Integer" (partialDecode + (parseField "1e6" :: Parser Integer)) + ] + , testGroup "Space trimming" + [ testCase "_Int" (expect (parseField " 12" :: Parser Int) 12) + , testCase "Int_" (expect (parseField "12 " :: Parser Int) 12) + , testCase "_Int_" (expect (parseField " 12 " :: Parser Int) 12) + , testCase "_Natural" (expect (parseField " 12" :: Parser Natural) 12) + , testCase "Natural_" (expect (parseField "12 " :: Parser Natural) 12) + , testCase "_Natural_" (expect (parseField " 12 " :: Parser Natural) 12) + , testCase "_Word" (expect (parseField " 12" :: Parser Word) 12) + , testCase "Word_" (expect (parseField "12 " :: Parser Word) 12) + , testCase "_Word_" (expect (parseField " 12 " :: Parser Word) 12) + , testCase "_Scientific" (expect (parseField " 1.2e1" :: Parser Scientific) 12) + , testCase "Scientific_" (expect (parseField "1.2e1 " :: Parser Scientific) 12) + , testCase "_Scientific_" (expect (parseField " 1.2e1 " :: Parser Scientific) 12) + , testCase "_Double" (expect (parseField " 1.2e1" :: Parser Double) 12) + , testCase "Double_" (expect (parseField "1.2e1 " :: Parser Double) 12) + , testCase "_Double_" (expect (parseField " 1.2e1 " :: Parser Double) 12) + ] + ] + +------------------------------------------------------------------------ +-- Custom options tests + +customDelim :: Word8 -> B.ByteString -> B.ByteString -> Property +customDelim delim f1 f2 = delim `notElem` [cr, nl, dquote] ==> + (decodeWith decOpts NoHeader (encodeWith encOpts [V.fromList [f1, f2]]) == + Right (V.fromList [V.fromList [f1, f2]])) + where + encOpts = defaultEncodeOptions { encDelimiter = delim } + decOpts = defaultDecodeOptions { decDelimiter = delim } + nl = 10 + cr = 13 + dquote = 34 + +customOptionsTests :: [TF.Test] +customOptionsTests = + [ testProperty "customDelim" customDelim + ] + +------------------------------------------------------------------------ +-- Instance tests + +instanceTests :: [TF.Test] +instanceTests = + [ + testGroup "Records instances" + [ testCase "foldr Foldable" (expected @=? F.foldr (:) [] input) + , testCase "foldl' Foldable" (expected @=? F.foldl' (flip (:)) [] input) + ] + ] + where + input = S.Cons (Left "empty") ( + S.Cons (Right ("a" :: String)) (S.Nil Nothing BL8.empty)) + expected = ["a" :: String] + +------------------------------------------------------------------------ +-- Custom conversion option tests + +genericConversionTests :: [TF.Test] +genericConversionTests = + [ testCase "headerOrder" (header ["column1", "column2", "column_3"] @=? hdrs) + , testCase "encode" (encodeDefaultOrderedByName sampleValues @?= sampleEncoding) + , testCase "decode" (Right (hdrs, V.fromList sampleValues) @=? decodeByName sampleEncoding) + , testProperty "roundTrip" rtProp + ] + where + hdrs = headerOrder (undefined :: SampleType) + + sampleValues = [ SampleType "" 1 Nothing + , SampleType "field" 99999 (Just 1.234) + ] + + sampleEncoding = "column1,column2,column_3\r\n,1,\r\nfield,99999,1.234\r\n" + + rtProp :: [SampleType] -> Bool + rtProp vs = Right (hdrs, V.fromList vs) + == decodeByName (encodeDefaultOrderedByName vs) + +data SampleType = SampleType + { _column1 :: !T.Text + , column2 :: !Int + , _column_3 :: !(Maybe Double) + } deriving (Eq, Show, Read, Generic) + +sampleOptions :: Options +sampleOptions = defaultOptions { fieldLabelModifier = rmUnderscore } + where + rmUnderscore ('_':str) = str + rmUnderscore str = str + +instance ToNamedRecord SampleType where + toNamedRecord = genericToNamedRecord sampleOptions + +instance FromNamedRecord SampleType where + parseNamedRecord = genericParseNamedRecord sampleOptions + +instance DefaultOrdered SampleType where + headerOrder = genericHeaderOrder sampleOptions + +instance Arbitrary SampleType where + arbitrary = SampleType <$> arbitrary <*> arbitrary <*> arbitrary + +------------------------------------------------------------------------ +-- Test harness + +allTests :: [TF.Test] +allTests = [ testGroup "positional" positionalTests + , testGroup "named" nameBasedTests + , testGroup "conversion" conversionTests + , testGroup "custom-options" customOptionsTests + , testGroup "instances" instanceTests + , testGroup "generic-conversions" genericConversionTests + ] + +main :: IO () +main = defaultMain allTests