{-# 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
(
Only(..)
, FromRecord(..)
, FromNamedRecord(..)
, ToNamedRecord(..)
, DefaultOrdered(..)
, FromField(..)
, ToRecord(..)
, ToField(..)
, genericParseRecord
, genericToRecord
, genericParseNamedRecord
, genericToNamedRecord
, genericHeaderOrder
, Options
, defaultOptions
, fieldLabelModifier
, GFromRecord
, GToRecord
, GFromNamedRecord
, GToNamedRecordHeader
, Parser
, runParser
, index
, (.!)
, unsafeIndex
, lookup
, (.:)
, namedField
, (.=)
, record
, namedRecord
, header
) where
import Control.Applicative (Alternative, (<|>), empty)
import Control.Monad (MonadPlus, mplus, mzero)
import qualified Control.Monad.Fail as Fail
import Data.Attoparsec.ByteString.Char8 (double)
import qualified Data.Attoparsec.ByteString.Char8 as A8
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as B8
import qualified Data.ByteString.Lazy as L
#if MIN_VERSION_bytestring(0,10,4)
import qualified Data.ByteString.Short as SBS
#endif
import Data.List (intercalate)
import Data.Hashable (Hashable)
import qualified Data.HashMap.Lazy as HM
import Data.Int (Int8, Int16, Int32, Int64)
import qualified Data.IntMap as IM
import qualified Data.Map as M
import Data.Scientific (Scientific)
import Data.Semigroup (Semigroup, (<>))
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.Lazy as LT
import qualified Data.Text.Lazy.Encoding as LT
#if MIN_VERSION_text_short(0,1,0)
import qualified Data.Text.Short as T.S
#endif
import Data.Tuple.Only (Only(..))
import Data.Vector (Vector, (!))
import qualified Data.Vector as V
import qualified Data.Vector.Unboxed as U
import Data.Word (Word8, Word16, Word32, Word64)
import GHC.Float (double2Float)
import GHC.Generics
import Numeric.Natural
import Prelude hiding (lookup, takeWhile)
import Data.Csv.Conversion.Internal
import Data.Csv.Types
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative (Applicative, (<$>), (<*>), (<*), (*>), pure)
import Data.Monoid (Monoid, mappend, mempty)
import Data.Traversable (traverse)
import Data.Word (Word)
#endif
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 #-}
newtype Options = Options
{ fieldLabelModifier :: String -> String
}
instance Show Options where
show (Options fld) =
"Options {"
++ intercalate ","
[ "fieldLabelModifier =~ " ++ show sampleField ++ " -> " ++ show (fld sampleField)
]
++ "}"
where
sampleField = "_column_A"
defaultOptions :: Options
defaultOptions = Options
{ fieldLabelModifier = id
}
class FromRecord a where
parseRecord :: Record -> Parser a
default parseRecord :: (Generic a, GFromRecord (Rep a)) => Record -> Parser a
parseRecord = genericParseRecord defaultOptions
genericParseRecord :: (Generic a, GFromRecord (Rep a)) => Options -> Record -> Parser a
genericParseRecord opts r = to <$> gparseRecord opts r
class ToRecord a where
toRecord :: a -> Record
default toRecord :: (Generic a, GToRecord (Rep a) Field) => a -> Record
toRecord = genericToRecord defaultOptions
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
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
class FromNamedRecord a where
parseNamedRecord :: NamedRecord -> Parser a
default parseNamedRecord :: (Generic a, GFromNamedRecord (Rep a)) => NamedRecord -> Parser a
parseNamedRecord = genericParseNamedRecord defaultOptions
genericParseNamedRecord :: (Generic a, GFromNamedRecord (Rep a)) => Options -> NamedRecord -> Parser a
genericParseNamedRecord opts r = to <$> gparseNamedRecord opts r
class ToNamedRecord a where
toNamedRecord :: a -> NamedRecord
default toNamedRecord ::
(Generic a, GToRecord (Rep a) (B.ByteString, B.ByteString)) =>
a -> NamedRecord
toNamedRecord = genericToNamedRecord defaultOptions
genericToNamedRecord :: (Generic a, GToRecord (Rep a) (B.ByteString, B.ByteString))
=> Options -> a -> NamedRecord
genericToNamedRecord opts = namedRecord . gtoRecord opts . from
class DefaultOrdered a where
headerOrder :: a -> Header
default headerOrder ::
(Generic a, GToNamedRecordHeader (Rep a)) =>
a -> Header
headerOrder = genericHeaderOrder defaultOptions
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
class FromField a where
parseField :: Field -> Parser a
class ToField a where
toField :: a -> Field
instance FromField a => FromField (Maybe a) where
parseField s
| B.null s = pure Nothing
| otherwise = Just <$> parseField s
{-# INLINE parseField #-}
instance ToField a => ToField (Maybe a) where
toField = maybe B.empty toField
{-# INLINE toField #-}
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 #-}
instance FromField () where
parseField _ = pure ()
{-# INLINE parseField #-}
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 #-}
instance ToField Char where
toField = toField . T.encodeUtf8 . T.singleton
{-# INLINE toField #-}
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 #-}
instance ToField Scientific where
toField = scientific
{-# 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 (ws *> double <* ws) s of
Left err -> typeError "Double" s (Just err)
Right n -> pure n
{-# INLINE parseDouble #-}
instance FromField Int where
parseField = parseSigned "Int"
{-# INLINE parseField #-}
instance ToField Int where
toField = decimal
{-# INLINE toField #-}
instance FromField Integer where
parseField = parseSigned "Integer"
{-# INLINE parseField #-}
instance ToField Integer where
toField = decimal
{-# INLINE toField #-}
instance FromField Int8 where
parseField = parseSigned "Int8"
{-# INLINE parseField #-}
instance ToField Int8 where
toField = decimal
{-# INLINE toField #-}
instance FromField Int16 where
parseField = parseSigned "Int16"
{-# INLINE parseField #-}
instance ToField Int16 where
toField = decimal
{-# INLINE toField #-}
instance FromField Int32 where
parseField = parseSigned "Int32"
{-# INLINE parseField #-}
instance ToField Int32 where
toField = decimal
{-# INLINE toField #-}
instance FromField Int64 where
parseField = parseSigned "Int64"
{-# INLINE parseField #-}
instance ToField Int64 where
toField = decimal
{-# INLINE toField #-}
instance FromField Word where
parseField = parseUnsigned "Word"
{-# INLINE parseField #-}
instance ToField Word where
toField = decimal
{-# INLINE toField #-}
instance FromField Natural where
parseField = parseUnsigned "Natural"
{-# INLINE parseField #-}
instance ToField Natural where
toField = decimal
{-# INLINE toField #-}
instance FromField Word8 where
parseField = parseUnsigned "Word8"
{-# INLINE parseField #-}
instance ToField Word8 where
toField = decimal
{-# INLINE toField #-}
instance FromField Word16 where
parseField = parseUnsigned "Word16"
{-# INLINE parseField #-}
instance ToField Word16 where
toField = decimal
{-# INLINE toField #-}
instance FromField Word32 where
parseField = parseUnsigned "Word32"
{-# INLINE parseField #-}
instance ToField Word32 where
toField = decimal
{-# INLINE toField #-}
instance FromField Word64 where
parseField = parseUnsigned "Word64"
{-# INLINE parseField #-}
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)
instance FromField T.S.ShortText where
parseField = maybe (fail "Invalid UTF-8 stream") pure . T.S.fromByteString
{-# INLINE parseField #-}
instance ToField T.S.ShortText where
toField = T.S.toByteString
{-# INLINE toField #-}
#endif
instance FromField T.Text where
parseField = either (fail . show) pure . T.decodeUtf8'
{-# INLINE parseField #-}
instance ToField T.Text where
toField = toField . T.encodeUtf8
{-# INLINE toField #-}
instance FromField LT.Text where
parseField = either (fail . show) (pure . LT.fromStrict) . T.decodeUtf8'
{-# INLINE parseField #-}
instance ToField LT.Text where
toField = toField . toStrict . LT.encodeUtf8
{-# INLINE toField #-}
instance FromField [Char] where
parseField = fmap T.unpack . parseField
{-# INLINE parseField #-}
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')
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 -> ""
index :: FromField a => Record -> Int -> Parser a
index v idx = parseField (v ! idx)
{-# INLINE index #-}
(.!) :: FromField a => Record -> Int -> Parser a
(.!) = index
{-# INLINE (.!) #-}
infixl 9 .!
unsafeIndex :: FromField a => Record -> Int -> Parser a
unsafeIndex v idx = parseField (V.unsafeIndex v idx)
{-# INLINE unsafeIndex #-}
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 #-}
(.:) :: FromField a => NamedRecord -> B.ByteString -> Parser a
(.:) = lookup
{-# INLINE (.:) #-}
namedField :: ToField a => B.ByteString -> a -> (B.ByteString, B.ByteString)
namedField name val = (name, toField val)
{-# INLINE namedField #-}
(.=) :: ToField a => B.ByteString -> a -> (B.ByteString, B.ByteString)
(.=) = namedField
{-# INLINE (.=) #-}
record :: [B.ByteString] -> Record
record = V.fromList
namedRecord :: [(B.ByteString, B.ByteString)] -> NamedRecord
namedRecord = HM.fromList
header :: [B.ByteString] -> Header
header = V.fromList
type Failure f r = String -> f r
type Success a f r = a -> f r
newtype Parser a = Parser {
unParser :: forall (f :: * -> *) (r :: *).
Failure f r
-> Success a f r
-> f r
}
instance Monad Parser where
m >>= g = Parser $ \kf ks -> let ks' a = unParser (g a) kf ks
in unParser m kf ks'
{-# INLINE (>>=) #-}
(>>) = (*>)
{-# INLINE (>>) #-}
return = pure
{-# INLINE return #-}
fail = Fail.fail
{-# INLINE fail #-}
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 #-}
instance Semigroup (Parser a) where
(<>) = mplus
{-# INLINE (<>) #-}
instance Monoid (Parser a) where
mempty = fail "mempty"
{-# INLINE mempty #-}
mappend = (<>)
{-# INLINE mappend #-}
apP :: Parser (a -> b) -> Parser a -> Parser b
apP d e = do
b <- d
a <- e
pure (b a)
{-# INLINE apP #-}
runParser :: Parser a -> Either String a
runParser p = unParser p left right
where
left !errMsg = Left errMsg
right !x = Right x
{-# INLINE runParser #-}
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)))
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)
#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