cassava-0.5.2.0: src/Data/Csv/Conversion.hs
{-# 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, Const(..))
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.Functor.Identity
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 as Semi (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:
--
-- > <interactive>: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 #-}
-- | @since 0.5.2.0
instance FromField a => FromField (Identity a) where
parseField = fmap Identity . parseField
{-# INLINE parseField #-}
-- | @since 0.5.2.0
instance ToField a => ToField (Identity a) where
toField = toField . runIdentity
{-# INLINE toField #-}
-- | @since 0.5.2.0
instance FromField a => FromField (Const a b) where
parseField = fmap getConst . parseField
{-# INLINE parseField #-}
-- | @since 0.5.2.0
instance ToField a => ToField (Const a b) where
toField = toField . getConst
{-# INLINE toField #-}
-- | 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 #-}
#if !MIN_VERSION_base(4,13,0)
fail = Fail.fail
{-# INLINE fail #-}
#endif
-- | @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 Semi.Semigroup (Parser a) where
(<>) = mplus
{-# INLINE (<>) #-}
instance Monoid (Parser a) where
mempty = fail "mempty"
{-# INLINE mempty #-}
mappend = (Semi.<>)
{-# 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