#if __GLASGOW_HASKELL__ >= 800
#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
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
instance ToField a => ToField (Maybe a) where
toField = maybe B.empty 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
instance FromField () where
parseField _ = pure ()
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
instance ToField Char where
toField = toField . T.encodeUtf8 . T.singleton
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
instance ToField Scientific where
toField = scientific
instance FromField Double where
parseField = parseDouble
instance ToField Double where
toField = realFloat
instance FromField Float where
parseField s = double2Float <$> parseDouble s
instance ToField Float where
toField = realFloat
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
instance FromField Int where
parseField = parseSigned "Int"
instance ToField Int where
toField = decimal
instance FromField Integer where
parseField = parseSigned "Integer"
instance ToField Integer where
toField = decimal
instance FromField Int8 where
parseField = parseSigned "Int8"
instance ToField Int8 where
toField = decimal
instance FromField Int16 where
parseField = parseSigned "Int16"
instance ToField Int16 where
toField = decimal
instance FromField Int32 where
parseField = parseSigned "Int32"
instance ToField Int32 where
toField = decimal
instance FromField Int64 where
parseField = parseSigned "Int64"
instance ToField Int64 where
toField = decimal
instance FromField Word where
parseField = parseUnsigned "Word"
instance ToField Word where
toField = decimal
instance FromField Natural where
parseField = parseUnsigned "Natural"
instance ToField Natural where
toField = decimal
instance FromField Word8 where
parseField = parseUnsigned "Word8"
instance ToField Word8 where
toField = decimal
instance FromField Word16 where
parseField = parseUnsigned "Word16"
instance ToField Word16 where
toField = decimal
instance FromField Word32 where
parseField = parseUnsigned "Word32"
instance ToField Word32 where
toField = decimal
instance FromField Word64 where
parseField = parseUnsigned "Word64"
instance ToField Word64 where
toField = decimal
instance FromField B.ByteString where
parseField = pure
instance ToField B.ByteString where
toField = id
instance FromField L.ByteString where
parseField = pure . fromStrict
instance ToField L.ByteString where
toField = toStrict
#if MIN_VERSION_bytestring(0,10,4)
instance FromField SBS.ShortByteString where
parseField = pure . SBS.toShort
instance ToField SBS.ShortByteString where
toField = SBS.fromShort
#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
instance ToField T.S.ShortText where
toField = T.S.toByteString
#endif
instance FromField T.Text where
parseField = either (fail . show) pure . T.decodeUtf8'
instance ToField T.Text where
toField = toField . T.encodeUtf8
instance FromField LT.Text where
parseField = either (fail . show) (pure . LT.fromStrict) . T.decodeUtf8'
instance ToField LT.Text where
toField = toField . toStrict . LT.encodeUtf8
instance FromField [Char] where
parseField = fmap T.unpack . parseField
instance ToField [Char] where
toField = toField . T.pack
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
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
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))
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)
(.!) :: FromField a => Record -> Int -> Parser a
(.!) = index
infixl 9 .!
unsafeIndex :: FromField a => Record -> Int -> Parser a
unsafeIndex v idx = parseField (V.unsafeIndex v idx)
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)
(.:) :: FromField a => NamedRecord -> B.ByteString -> Parser a
(.:) = lookup
namedField :: ToField a => B.ByteString -> a -> (B.ByteString, B.ByteString)
namedField name val = (name, toField val)
(.=) :: ToField a => B.ByteString -> a -> (B.ByteString, B.ByteString)
(.=) = namedField
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'
(>>) = (*>)
return = pure
fail = Fail.fail
instance Fail.MonadFail Parser where
fail msg = Parser $ \kf _ks -> kf msg
instance Functor Parser where
fmap f m = Parser $ \kf ks -> let ks' a = ks (f a)
in unParser m kf ks'
instance Applicative Parser where
pure a = Parser $ \_kf ks -> ks a
(<*>) = apP
instance Alternative Parser where
empty = fail "empty"
(<|>) = mplus
instance MonadPlus Parser where
mzero = fail "mzero"
mplus a b = Parser $ \kf ks -> let kf' _ = unParser b kf ks
in unParser a kf' ks
instance Semigroup (Parser a) where
(<>) = mplus
instance Monoid (Parser a) where
mempty = fail "mempty"
mappend = (<>)
apP :: Parser (a -> b) -> Parser a -> Parser b
apP d e = do
b <- d
a <- e
pure (b a)
runParser :: Parser a -> Either String a
runParser p = unParser p left right
where
left !errMsg = Left errMsg
right !x = Right x
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