diff --git a/Data/Csv.hs b/Data/Csv.hs new file mode 100644 --- /dev/null +++ b/Data/Csv.hs @@ -0,0 +1,127 @@ +-- | This module implements encoding and decoding of CSV data. The +-- implementation 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). +module Data.Csv + ( + -- * Usage example + -- $example + + -- * Encoding and decoding + -- $encoding + decode + , decodeByName + , encode + , encodeByName + + -- ** Encoding and decoding options + -- $options + , DecodeOptions(..) + , defaultDecodeOptions + , decodeWith + , decodeByNameWith + , EncodeOptions(..) + , defaultEncodeOptions + , encodeWith + , encodeByNameWith + + -- * Core CSV types + , Csv + , Record + , Field + , Header + , Name + , NamedRecord + + -- * Type conversion + -- $typeconversion + + -- ** Index-based record conversion + -- $indexbased + , FromRecord(..) + , Parser + , (.!) + , ToRecord(..) + , record + , Only(..) + + -- ** Name-based record conversion + -- $namebased + , FromNamedRecord(..) + , (.:) + , ToNamedRecord(..) + , namedRecord + , (.=) + + -- ** Field conversion + , FromField(..) + , ToField(..) + ) where + +import Data.Csv.Conversion +import Data.Csv.Encoding +import Data.Csv.Types + +-- $example +-- +-- A short encoding usage example: +-- +-- @ >>> 'encode' $ fromList [(\"John\" :: Text, 27), (\"Jane\", 28)] +-- Chunk \"John,27\\r\\nJane,28\\r\\n\" Empty +-- @ +-- +-- Since string literals are overloaded we have to supply a type +-- signature as the compiler couldn't deduce which string type (i.e. +-- 'String' or 'Text') we want to use. In most cases type inference +-- will infer the type from the context and you can omit type +-- signatures. +-- +-- A short decoding usage example: +-- +-- @ >>> 'decode' \"John,27\\r\\nJane,28\\r\\n\" :: Either String (Vector (Text, Int)) +-- Right (fromList [(\"John\",27),(\"Jane\",28)]) +-- @ + +-- $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. 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,684 @@ +{-# LANGUAGE FlexibleInstances, OverloadedStrings, Rank2Types #-} +module Data.Csv.Conversion + ( + -- * Type conversion + Only(..) + , FromRecord(..) + , FromNamedRecord(..) + , ToNamedRecord(..) + , FromField(..) + , ToRecord(..) + , ToField(..) + + -- * Parser + , Result(..) + , Parser + , parse + + -- * Accessors + , (.!) + , (.:) + , (.=) + , record + , namedRecord + ) where + +import Control.Applicative +import Control.Monad +import Data.Attoparsec.Char8 (double, number, parseOnly) +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as B8 +import qualified Data.ByteString.Lazy as L +import qualified Data.HashMap.Lazy as HM +import Data.Int +import qualified Data.Map as M +import Data.Monoid +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 +import Data.Traversable +import Data.Vector (Vector, (!)) +import qualified Data.Vector as V +import Data.Word +import GHC.Float (double2Float) +import Prelude hiding (takeWhile) + +import Data.Csv.Conversion.Internal +import Data.Csv.Types + +------------------------------------------------------------------------ +-- Type conversion + +------------------------------------------------------------------------ +-- Index-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: +-- +-- > John,56 +-- > Jane,55 +-- +-- here's an example type and instance: +-- +-- @data Person = Person { name :: Text, age :: Int } +-- +-- instance FromRecord Person where +-- parseRecord v +-- | 'V.length' v == 2 = Person '<$>' +-- v '.!' 0 '<*>' +-- v '.!' 1 +-- | otherwise = mzero +-- @ +class FromRecord a where + parseRecord :: Record -> Parser a + +-- | Haskell lacks a single-element tuple type, so if you CSV data +-- with just one column you can use the 'Only' type to represent a +-- single-column result. +newtype Only a = Only { + fromOnly :: a + } deriving (Eq, Ord, Read, Show) + +-- | 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 + toRecord :: a -> Record + +instance FromField a => FromRecord (Only a) where + parseRecord v + | n == 1 = Only <$> parseField (V.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 = (,) <$> parseField (V.unsafeIndex v 0) + <*> parseField (V.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 = (,,) <$> parseField (V.unsafeIndex v 0) + <*> parseField (V.unsafeIndex v 1) + <*> parseField (V.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 = (,,,) <$> parseField (V.unsafeIndex v 0) + <*> parseField (V.unsafeIndex v 1) + <*> parseField (V.unsafeIndex v 2) + <*> parseField (V.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 = (,,,,) <$> parseField (V.unsafeIndex v 0) + <*> parseField (V.unsafeIndex v 1) + <*> parseField (V.unsafeIndex v 2) + <*> parseField (V.unsafeIndex v 3) + <*> parseField (V.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 = (,,,,,) <$> parseField (V.unsafeIndex v 0) + <*> parseField (V.unsafeIndex v 1) + <*> parseField (V.unsafeIndex v 2) + <*> parseField (V.unsafeIndex v 3) + <*> parseField (V.unsafeIndex v 4) + <*> parseField (V.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 = (,,,,,,) <$> parseField (V.unsafeIndex v 0) + <*> parseField (V.unsafeIndex v 1) + <*> parseField (V.unsafeIndex v 2) + <*> parseField (V.unsafeIndex v 3) + <*> parseField (V.unsafeIndex v 4) + <*> parseField (V.unsafeIndex v 5) + <*> parseField (V.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] + +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 + +------------------------------------------------------------------------ +-- 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 FromRecord 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 + +-- | 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 +-- toNamedRecord (Person name age) = 'namedRecord' [ +-- \"name\" '.=' name, \"age\" '.=' age] +-- @ +class ToNamedRecord a where + toNamedRecord :: a -> NamedRecord + +instance FromField a => FromNamedRecord (M.Map B.ByteString a) where + parseNamedRecord m = M.fromList <$> + (traverse parseSnd $ HM.toList m) + where parseSnd (name, s) = (,) <$> pure name <*> parseField s + +instance ToField a => ToNamedRecord (M.Map B.ByteString a) where + toNamedRecord = HM.fromList . map (\ (k, v) -> (k, toField v)) . M.toList + +instance FromField a => FromNamedRecord (HM.HashMap B.ByteString a) where + parseNamedRecord m = traverse (\ s -> parseField s) m + +instance ToField a => ToNamedRecord (HM.HashMap B.ByteString a) where + toNamedRecord = HM.map toField + +------------------------------------------------------------------------ +-- 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 + +instance FromField Char where + parseField s + | T.compareLength t 1 == EQ = pure (T.head t) + | otherwise = typeError "Char" s Nothing + where t = T.decodeUtf8 s + {-# INLINE parseField #-} + +instance ToField Char where + toField = toField . T.encodeUtf8 . T.singleton + {-# INLINE toField #-} + +instance FromField Double where + parseField = parseDouble + {-# INLINE parseField #-} + +instance ToField Double where + toField = realFloat + {-# INLINE toField #-} + +instance FromField Float where + parseField s = double2Float <$> parseDouble s + {-# INLINE parseField #-} + +instance ToField Float where + toField = realFloat + {-# INLINE toField #-} + +parseDouble :: B.ByteString -> Parser Double +parseDouble s = case parseOnly double s of + Left err -> typeError "Double" s (Just err) + Right n -> pure n +{-# INLINE parseDouble #-} + +instance FromField Int where + parseField = parseIntegral "Int" + {-# INLINE parseField #-} + +instance ToField Int where + toField = decimal + {-# INLINE toField #-} + +instance FromField Integer where + parseField = parseIntegral "Integer" + {-# INLINE parseField #-} + +instance ToField Integer where + toField = decimal + {-# INLINE toField #-} + +instance FromField Int8 where + parseField = parseIntegral "Int8" + {-# INLINE parseField #-} + +instance ToField Int8 where + toField = decimal + {-# INLINE toField #-} + +instance FromField Int16 where + parseField = parseIntegral "Int16" + {-# INLINE parseField #-} + +instance ToField Int16 where + toField = decimal + {-# INLINE toField #-} + +instance FromField Int32 where + parseField = parseIntegral "Int32" + {-# INLINE parseField #-} + +instance ToField Int32 where + toField = decimal + {-# INLINE toField #-} + +instance FromField Int64 where + parseField = parseIntegral "Int64" + {-# INLINE parseField #-} + +instance ToField Int64 where + toField = decimal + {-# INLINE toField #-} + +instance FromField Word where + parseField = parseIntegral "Word" + {-# INLINE parseField #-} + +instance ToField Word where + toField = decimal + {-# INLINE toField #-} + +instance FromField Word8 where + parseField = parseIntegral "Word8" + {-# INLINE parseField #-} + +instance ToField Word8 where + toField = decimal + {-# INLINE toField #-} + +instance FromField Word16 where + parseField = parseIntegral "Word16" + {-# INLINE parseField #-} + +instance ToField Word16 where + toField = decimal + {-# INLINE toField #-} + +instance FromField Word32 where + parseField = parseIntegral "Word32" + {-# INLINE parseField #-} + +instance ToField Word32 where + toField = decimal + {-# INLINE toField #-} + +instance FromField Word64 where + parseField = parseIntegral "Word64" + {-# INLINE parseField #-} + +instance ToField Word64 where + toField = decimal + {-# INLINE toField #-} + +-- TODO: Optimize +escape :: B.ByteString -> B.ByteString +escape s + | B.find (\ b -> b == dquote || b == comma || b == nl || b == cr || + b == sp) s == Nothing = s + | otherwise = + B.concat ["\"", + B.concatMap + (\ b -> if b == dquote then "\"\"" else B.singleton b) s, + "\""] + where + dquote = 34 + comma = 44 + nl = 10 + cr = 13 + sp = 32 + +instance FromField B.ByteString where + parseField = pure + {-# INLINE parseField #-} + +instance ToField B.ByteString where + toField = escape + {-# INLINE toField #-} + +instance FromField L.ByteString where + parseField s = pure (L.fromChunks [s]) + {-# INLINE parseField #-} + +instance ToField L.ByteString where + toField = toField . B.concat . L.toChunks + {-# INLINE toField #-} + +-- | Assumes UTF-8 encoding. +instance FromField T.Text where + parseField = pure . T.decodeUtf8 + {-# INLINE parseField #-} + +-- | Uses UTF-8 encoding. +instance ToField T.Text where + toField = toField . T.encodeUtf8 + {-# INLINE toField #-} + +-- | Assumes UTF-8 encoding. +instance FromField LT.Text where + parseField s = pure (LT.fromChunks [T.decodeUtf8 s]) + {-# INLINE parseField #-} + +-- | Uses UTF-8 encoding. +instance ToField LT.Text where + toField = toField . B.concat . L.toChunks . LT.encodeUtf8 + {-# INLINE toField #-} + +-- | Assumes UTF-8 encoding. +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 #-} + +parseIntegral :: Integral a => String -> B.ByteString -> Parser a +parseIntegral typ s = case parseOnly number s of + Left err -> typeError typ s (Just err) + Right n -> pure (floor n) +{-# INLINE parseIntegral #-} + +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. +(.!) :: FromField a => Record -> Int -> Parser a +v .! idx = parseField (v ! idx) +{-# INLINE (.!) #-} + +-- | 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. +(.:) :: FromField a => NamedRecord -> B.ByteString -> Parser a +m .: name = maybe (fail err) parseField $ HM.lookup name m + where err = "no field named " ++ show (B8.unpack name) +{-# INLINE (.:) #-} + +-- | Construct a pair from a name and a value. For use with +-- 'namedRecord'. +(.=) :: ToField a => B.ByteString -> a -> (B.ByteString, B.ByteString) +name .= val = (name, toField val) +{-# 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 + +------------------------------------------------------------------------ +-- Parser for converting records to data types + +-- | The result of running a 'Parser'. +data Result a = Error String + | Success a + deriving (Eq, Show) + +instance Functor Result where + fmap f (Success a) = Success (f a) + fmap _ (Error err) = Error err + {-# INLINE fmap #-} + +instance Monad Result where + return = Success + {-# INLINE return #-} + Success a >>= k = k a + Error err >>= _ = Error err + {-# INLINE (>>=) #-} + +instance Applicative Result where + pure = return + {-# INLINE pure #-} + (<*>) = ap + {-# INLINE (<*>) #-} + +instance MonadPlus Result where + mzero = fail "mzero" + {-# INLINE mzero #-} + mplus a@(Success _) _ = a + mplus _ b = b + {-# INLINE mplus #-} + +instance Alternative Result where + empty = mzero + {-# INLINE empty #-} + (<|>) = mplus + {-# INLINE (<|>) #-} + +instance Monoid (Result a) where + mempty = fail "mempty" + {-# INLINE mempty #-} + mappend = mplus + {-# INLINE mappend #-} + +-- | 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 { + runParser :: forall f r. + Failure f r + -> Success a f r + -> f r + } + +instance Monad Parser where + m >>= g = Parser $ \kf ks -> let ks' a = runParser (g a) kf ks + in runParser m kf ks' + {-# INLINE (>>=) #-} + return a = Parser $ \_kf ks -> ks a + {-# INLINE return #-} + 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 runParser m kf ks' + {-# INLINE fmap #-} + +instance Applicative Parser where + pure = return + {-# 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' _ = runParser b kf ks + in runParser a kf' ks + {-# INLINE mplus #-} + +instance Monoid (Parser a) where + mempty = fail "mempty" + {-# INLINE mempty #-} + mappend = mplus + {-# INLINE mappend #-} + +apP :: Parser (a -> b) -> Parser a -> Parser b +apP d e = do + b <- d + a <- e + return (b a) +{-# INLINE apP #-} + +-- | Run a 'Parser'. +parse :: Parser a -> Result a +parse p = runParser p Error Success +{-# INLINE parse #-} 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,283 @@ +module Data.Csv.Conversion.Internal + ( decimal + , realFloat + ) where + +import Blaze.ByteString.Builder +import Blaze.ByteString.Builder.Char8 +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.Word + +------------------------------------------------------------------------ +-- Integers + +decimal :: Integral a => a -> B.ByteString +decimal = toByteString . formatDecimal +{-# INLINE decimal #-} + +-- TODO: Add an optimized version for Integer. + +formatDecimal :: Integral a => a -> Builder +{-# SPECIALIZE formatDecimal :: Int8 -> Builder #-} +{-# RULES "formatDecimal/Int" formatDecimal = formatBoundedSigned + :: Int -> 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 #-} +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 = fromWord8 45 + +zero :: Word8 +zero = 48 + +digit :: Integral a => a -> Builder +digit n = fromWord8 $! i2w (fromIntegral n) +{-# INLINE digit #-} + +i2w :: Int -> Word8 +i2w i = zero + fromIntegral i +{-# INLINE i2w #-} + +------------------------------------------------------------------------ +-- Floating point numbers + +realFloat :: RealFloat a => a -> B.ByteString +{-# SPECIALIZE realFloat :: Float -> B.ByteString #-} +{-# SPECIALIZE realFloat :: Double -> B.ByteString #-} +realFloat = toByteString . 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 = fromString "NaN" + | isInfinite x = if x < 0 + then fromString "-Infinity" + else fromString "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] -> fromString "0.0e0" + [d] -> fromWord8 d <> fromString ".0e" <> show_e' + (d:ds') -> fromWord8 d <> fromChar '.' <> fromWord8s ds' <> + fromChar 'e' <> show_e' + [] -> error "formatRealFloat/doFmt/Exponent: []" + Fixed + | e <= 0 -> fromString "0." <> + fromByteString (B.replicate (-e) zero) <> + fromWord8s ds + | otherwise -> + let + f 0 s rs = mk0 (reverse s) <> fromChar '.' <> 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 { [] -> fromWord8 zero ; _ -> fromWord8s 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) 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,182 @@ +{-# LANGUAGE BangPatterns, OverloadedStrings #-} + +-- 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 + decode + , decodeByName + , encode + , encodeByName + + -- ** Encoding and decoding options + , DecodeOptions(..) + , defaultDecodeOptions + , decodeWith + , decodeByNameWith + , EncodeOptions(..) + , defaultEncodeOptions + , encodeWith + , encodeByNameWith + ) where + +import Blaze.ByteString.Builder +import Blaze.ByteString.Builder.Char8 +import Control.Applicative +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.Monoid +import Data.Traversable +import Data.Vector (Vector) +import qualified Data.Vector as V +import Data.Word (Word8) +import Prelude hiding (unlines) + +import Data.Csv.Conversion +import Data.Csv.Parser +import Data.Csv.Types + +-- 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 => L.ByteString -> 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 + -> Either String (Header, Vector a) +decodeByName = decodeByNameWith defaultDecodeOptions +{-# INLINE decodeByName #-} + +-- | Efficiently serialize CVS records as a lazy 'L.ByteString'. +encode :: ToRecord a => V.Vector a -> L.ByteString +encode = encodeWith defaultEncodeOptions + +-- | Efficiently serialize CVS records as a lazy 'L.ByteString'. The +-- header is written before any records and dictates the field order. +encodeByName :: ToNamedRecord a => Header -> V.Vector a -> L.ByteString +encodeByName = encodeByNameWith defaultEncodeOptions + +------------------------------------------------------------------------ +-- ** Encoding and decoding options + +-- | Like 'decode', but lets you customize how the CSV data is parsed. +decodeWith :: FromRecord a => DecodeOptions -> L.ByteString + -> Either String (Vector a) +decodeWith !opts = decodeWithP (csv opts) (parse . traverse parseRecord) +{-# INLINE [1] decodeWith #-} + +{-# RULES + "idDecodeWith" decodeWith = idDecodeWith + #-} + +-- | Same as 'decodeWith', but more efficient as no type +-- conversion is performed. +idDecodeWith :: DecodeOptions -> L.ByteString + -> Either String (Vector (Vector B.ByteString)) +idDecodeWith !opts = decodeWithP (csv opts) pure + +-- | Like 'decodeByName', but lets you customize how the CSV data is +-- parsed. +decodeByNameWith :: FromNamedRecord a => DecodeOptions -> L.ByteString + -> Either String (Header, Vector a) +decodeByNameWith !opts = + decodeWithP (csvWithHeader opts) + (\ (hdr, vs) -> (,) <$> pure hdr <*> (parse $ traverse parseNamedRecord vs)) + +-- | 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. +data EncodeOptions = EncodeOptions + { -- | Field delimiter. + encDelimiter :: {-# UNPACK #-} !Word8 + } + +-- | Encoding options for CSV files. +defaultEncodeOptions :: EncodeOptions +defaultEncodeOptions = EncodeOptions + { encDelimiter = 44 -- comma + } + +-- | Like 'encode', but lets you customize how the CSV data is +-- encoded. +encodeWith :: ToRecord a => EncodeOptions -> V.Vector a -> L.ByteString +encodeWith opts = toLazyByteString + . unlines + . map (encodeRecord (encDelimiter opts) . toRecord) + . V.toList + +encodeRecord :: Word8 -> Record -> Builder +encodeRecord delim = mconcat . intersperse (fromWord8 delim) + . map fromByteString . V.toList +{-# INLINE encodeRecord #-} + +-- | Like 'encodeByName', but lets you customize how the CSV data is +-- encoded. +encodeByNameWith :: ToNamedRecord a => EncodeOptions -> Header -> V.Vector a + -> L.ByteString +encodeByNameWith opts hdr v = + toLazyByteString ((encodeRecord (encDelimiter opts) hdr) <> + fromByteString "\r\n" <> records) + where + records = unlines + . map (encodeRecord (encDelimiter opts) + . namedRecordToRecord hdr . toNamedRecord) + . V.toList $ v + + +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 #-} + +unlines :: [Builder] -> Builder +unlines [] = mempty +unlines (b:bs) = b <> fromString "\r\n" <> unlines 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 -> (a -> Result b) -> L.ByteString -> Either String b +decodeWithP p to s = + case AL.parse p s of + AL.Done _ v -> case to v of + Success a -> Right a + Error msg -> Left $ "conversion error: " ++ msg + AL.Fail left _ msg -> Left $ "parse error (" ++ msg ++ ") at " ++ + show (BL8.unpack left) +{-# INLINE decodeWithP #-} 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,158 @@ +{-# LANGUAGE BangPatterns #-} + +-- | 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 Blaze.ByteString.Builder (fromByteString, toByteString) +import Blaze.ByteString.Builder.Char.Utf8 (fromChar) +import Control.Applicative +import Data.Attoparsec.Char8 hiding (Parser, Result, parse) +import qualified Data.Attoparsec 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.HashMap.Strict as HM +import Data.Monoid +import qualified Data.Vector as V +import Data.Word + +import Data.Csv.Types + +-- | Options that controls how data is decoded. These options can be +-- used to e.g. decode tab-separated data instead of comma-separated +-- data. +data DecodeOptions = DecodeOptions + { -- | Field delimiter. + decDelimiter :: {-# UNPACK #-} !Word8 + } + +-- | 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 <- record (decDelimiter opts) `sepBy1` endOfLine + _ <- optional endOfLine + endOfInput + let nonEmpty = removeBlankLines vals + return (V.fromList nonEmpty) +{-# INLINE csv #-} + +-- | 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 <$> + (record (decDelimiter opts)) `sepBy1` endOfLine + _ <- optional endOfLine + endOfInput + return (hdr, V.fromList vals) + +toNamedRecord :: V.Vector S.ByteString -> Record -> NamedRecord +toNamedRecord hdr v = HM.fromList . V.toList $ V.zip hdr v + +-- | Parse a header, including the terminating line separator. +header :: Word8 -- ^ Field delimiter + -> AL.Parser Header +header delim = V.fromList <$> name `sepBy1` (A.word8 delim) <* endOfLine + +-- | Parse a header name. Header names have the same format as regular +-- 'field's. +name :: AL.Parser Field -- TODO: Create Name type alias +name = field + +removeBlankLines :: [Record] -> [Record] +removeBlankLines = filter (not . blankLine) + where blankLine v = V.length v == 1 && (S.null (V.head v)) + +-- | 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 `sepBy1` (A.word8 delim) +{-# INLINE record #-} + +-- | Parse a field. The field may be in either the escaped or +-- non-escaped format. The return value is unescaped. +field :: AL.Parser Field +field = 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 + +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 :: AL.Parser S.ByteString +unescapedField = A.takeWhile (\ c -> c /= doubleQuote && + c /= newline && + c /= commaB && + c /= cr) + +dquote :: AL.Parser Char +dquote = char '"' + +unescape :: Z.Parser S.ByteString +unescape = toByteString <$> 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` fromByteString h `mappend` fromChar '"') + else fail "invalid CSV escape sequence" + done <- Z.atEnd + if done + then return (acc `mappend` fromByteString h) + else rest + +doubleQuote, newline, commaB, cr :: Word8 +doubleQuote = 34 +newline = 10 +commaB = 44 +cr = 13 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,36 @@ +module Data.Csv.Types + ( + -- * Core CSV types + Csv + , Record + , Header + , Name + , NamedRecord + , Field + ) where + +import qualified Data.ByteString as S +import qualified Data.HashMap.Strict as HM +import Data.Vector (Vector) + +-- | 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 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/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/benchmarks/Benchmarks.hs b/benchmarks/Benchmarks.hs new file mode 100644 --- /dev/null +++ b/benchmarks/Benchmarks.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE BangPatterns, FlexibleInstances, OverloadedStrings, + TypeSynonymInstances #-} +module Main ( main ) where + +import Control.Applicative +import Criterion.Main +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import qualified Data.HashMap.Strict as HM +import Data.Text (Text) +import Data.Vector (Vector) + +import Data.Csv + +type President = (Int, Text, ByteString, ByteString, ByteString, Text, Text) + +instance FromNamedRecord President where + parseNamedRecord m = (,,,,,,) <$> + m .: "Presidency" <*> + m .: "President" <*> + m .: "Wikipedia Entry" <*> + m .: "Took office" <*> + m .: "Left office" <*> + m .: "Party" <*> + m .: "Home State" + +instance ToNamedRecord President where + toNamedRecord (presidency, president, wikipediaEntry, tookOffice, + leftOffice, party, homeState) = namedRecord + [ "Presidency" .= presidency + , "President" .= president + , "Wikipedia Entry" .= wikipediaEntry + , "Took office" .= tookOffice + , "Left office" .= leftOffice + , "Party" .= party + , "Home State" .= homeState + ] + + +fromStrict s = BL.fromChunks [s] + +type BSHashMap a = HM.HashMap B.ByteString a + +main :: IO () +main = do + !csvData <- fromStrict `fmap` B.readFile "benchmarks/presidents.csv" + !csvDataN <- fromStrict `fmap` B.readFile + "benchmarks/presidents_with_header.csv" + let (Right !presidents) = decodePresidents csvData + (Right (!hdr, !presidentsN)) = decodePresidentsN csvDataN + defaultMain [ + bgroup "positional" + [ bgroup "decode" + [ bench "presidents/without conversion" $ whnf idDecode csvData + , bench "presidents/with conversion" $ whnf decodePresidents csvData + ] + , bgroup "encode" + [ bench "presidents/with conversion" $ whnf encode presidents + ] + ] + , bgroup "named" + [ bgroup "decode" + [ bench "presidents/without conversion" $ whnf idDecodeN csvDataN + , bench "presidents/with conversion" $ whnf decodePresidentsN csvDataN + ] + , bgroup "encode" + [ bench "presidents/with conversion" $ whnf (encodeByName hdr) presidentsN + ] + ] + ] + where + decodePresidents :: BL.ByteString -> Either String (Vector President) + decodePresidents = decode + + decodePresidentsN :: BL.ByteString -> Either String (Header, Vector President) + decodePresidentsN = decodeByName + + idDecode :: BL.ByteString -> Either String (Vector (Vector B.ByteString)) + idDecode = decode + + idDecodeN :: BL.ByteString -> Either String (Header, Vector (BSHashMap B.ByteString)) + idDecodeN = decodeByName diff --git a/cassava.cabal b/cassava.cabal new file mode 100644 --- /dev/null +++ b/cassava.cabal @@ -0,0 +1,75 @@ +Name: cassava +Version: 0.1.0.0 +Synopsis: A CSV parsing and encoding library +Description: + A CSV parsing and encoding library optimized for ease of use and high + performance. +Homepage: https://github.com/tibbe/sea +License: BSD3 +License-file: LICENSE +Bug-reports: https://github.com/tibbe/cassava/issues +Copyright: (c) 2012 Johan Tibell + (c) 2012 Bryan O'Sullivan + (c) 2011 MailRank, Inc. +Author: Johan Tibell +Maintainer: johan.tibell@gmail.com +Category: Text, Web, CSV +Build-type: Simple +Cabal-version: >=1.8 + + +Library + Exposed-modules: Data.Csv + Data.Csv.Parser + + Other-modules: Data.Csv.Conversion + Data.Csv.Conversion.Internal + Data.Csv.Encoding + Data.Csv.Types + + Build-depends: array, + attoparsec >= 0.10.2, + base < 5, + blaze-builder, + bytestring, + containers, + text, + unordered-containers, + vector + + ghc-options: -Wall -O2 + +Test-suite unit-tests + Type: exitcode-stdio-1.0 + Main-is: UnitTests.hs + Build-depends: attoparsec, + base, + bytestring, + cassava, + HUnit, + QuickCheck >= 2.0, + test-framework, + test-framework-hunit, + test-framework-quickcheck2, + text, + unordered-containers, + vector + + hs-source-dirs: tests + ghc-options: -Wall + +Benchmark benchmarks + Type: exitcode-stdio-1.0 + Main-is: Benchmarks.hs + Build-depends: base, + bytestring, + cassava, + criterion, + text, + unordered-containers, + vector + hs-source-dirs: benchmarks + +source-repository head + type: git + location: https://github.com/tibbe/cassava.git diff --git a/tests/UnitTests.hs b/tests/UnitTests.hs new file mode 100644 --- /dev/null +++ b/tests/UnitTests.hs @@ -0,0 +1,196 @@ +{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +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 qualified Data.Text as T +import qualified Data.Text.Lazy as LT +import Data.Vector ((!)) +import qualified Data.Vector as V +import Data.Word +import Test.HUnit +import Test.Framework as TF +import Test.Framework.Providers.HUnit as TF +import Test.QuickCheck +import Test.Framework.Providers.QuickCheck2 as TF + +import Data.Csv + +------------------------------------------------------------------------ +-- Parse tests + +decodesAs :: BL.ByteString -> [[B.ByteString]] -> Assertion +decodesAs input expected = case decode input 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 (V.fromList (map V.fromList input)) @?= expected + +namedEncodesAs :: [B.ByteString] -> [[(B.ByteString, B.ByteString)]] + -> BL.ByteString -> Assertion +namedEncodesAs hdr input expected = + encodeByName (V.fromList hdr) + (V.fromList $ 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 + +testRfc4180 :: Assertion +testRfc4180 = (BL8.pack $ + "#field1,field2,field3\n" ++ + "\"aaa\",\"bb\n" ++ + "b\",\"ccc\"\n" ++ + "\"a,a\",\"b\"\"bb\",\"ccc\"\n" ++ + "zzz,yyy,xxx\n") + `decodesAs` + [["#field1", "field2", "field3"], + ["aaa", "bb\nb", "ccc"], + ["a,a", "b\"bb", "ccc"], + ["zzz", "yyy", "xxx"]] + +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 "decode" $ map decodeTest + [ ("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"]]) + ] ++ [testCase "rfc4180" testRfc4180] + ] + where + encodeTest (name, input, expected) = + testCase name $ input `encodesAs` expected + decodeTest (name, input, expected) = + testCase name $ input `decodesAs` expected + +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 "decode" $ map decodeTest + [("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")]]) + ] + ] + where + encodeTest (name, hdr, input, expected) = + testCase name $ namedEncodesAs hdr input expected + decodeTest (name, input, hdr, expected) = + testCase name $ namedDecodesAs input hdr expected + +------------------------------------------------------------------------ +-- Conversion tests + +instance Arbitrary B.ByteString where + arbitrary = B.pack `fmap` arbitrary + +instance Arbitrary BL.ByteString where + arbitrary = BL.fromChunks `fmap` arbitrary + +instance Arbitrary T.Text where + arbitrary = T.pack `fmap` arbitrary + +instance Arbitrary LT.Text where + arbitrary = LT.fromChunks `fmap` arbitrary + +-- 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 = case decode (encode (V.singleton (x, dummy))) of + Right v | V.length v == 1 -> let (y, _ :: Char) = v ! 0 in x == y + _ -> False + where dummy = 'a' + +boundary :: forall a. (Bounded a, Eq a, FromField a, ToField a) => a -> Bool +boundary _dummy = roundTrip (minBound :: a) && roundTrip (maxBound :: a) + +-- TODO: Right now we only encode ASCII properly. Should we support +-- UTF-8? Arbitrary byte strings? + +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 "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 "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)) + ] + ] + +------------------------------------------------------------------------ +-- Test harness + +allTests :: [TF.Test] +allTests = [ testGroup "positional" positionalTests + , testGroup "named" nameBasedTests + , testGroup "conversion" conversionTests + ] + +main :: IO () +main = defaultMain allTests