{-# LANGUAGE UndecidableInstances #-}

-- |
--
-- = Encoding and decoding fields and rows
--
-- This module contains a collection of functions, classes, and instances that can
-- help you build encoders and decoders for your Haskell types.
--
-- Here's an example:
--
-- > data Person = Person { name :: Text, born :: Day, heightMeters :: Double }
-- >   deriving stock Generic
-- >   deriving anyclass FromPgRow
-- >
-- > persons :: [Person] <- query conn "SELECT * FROM persons"
--
-- Note that Hpgsql's `RowDecoder` does not have a `Monad` instance because that allows it to
-- type check query results and field counts even when queries return zero rows. If you need
-- to write a row decoder that is monadic (because decoding can change depending on the values
-- of fields), check "Hpgsql.Encoding.RowDecoderMonadic".
module Hpgsql.Encoding
  ( -- * Decoding
    FromPgField (..),
    FieldDecoder (..), -- TODO: Can we export ctor?
    FieldInfo (..),
    FromPgRow (..),
    RowDecoder (..), -- TODO: Can we export ctor?
    singleField,
    nullableField,
    genericFromPgRow,

    -- * Encoding

    -- | Keep in mind that Haskell's `Int` is an `Int64` on most
    -- hardware, which is a mismatch for the commonly used 32-bit
    -- `integer` PostgreSQL type.
    -- This is not a problem when decoding because Hpgsql can decode
    -- `integer` into Haskell's `Int`, but when encoding PostgreSQL
    -- will understandably not accept a larger type.
    ToPgField (..),
    FieldEncoder (..),
    ToPgRow (..),
    RowEncoder (..),
    EncodingContext (..),
    genericToPgRow,

    -- * PostgreSQL enums
    LowerCasedPgEnum (..),
    genericEnumFieldDecoder,
    genericEnumFieldEncoder,

    -- * PostgreSQL composite types
    compositeTypeDecoder,
    compositeTypeEncoder,

    -- * Driving PostgreSQL type inference
    typeFieldDecoder,
    typeFieldEncoder,
    typeOidWithName,
    typeMustBeNamed,

    -- * Others
    rawBytesFieldDecoder,
    untypedFieldEncoder,
    toPgVectorField,
    arrayField,
  )
where

import Control.Monad (replicateM, unless, when)
import qualified Data.Aeson as Aeson
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC
import qualified Data.ByteString.Lazy as LBS
import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI
import Data.Fixed (divMod')
import Data.Functor.Contravariant (Contravariant (..))
import Data.Int (Int16, Int32, Int64)
import qualified Data.List as List
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe (fromMaybe)
import Data.Monoid (Sum (..))
import Data.Proxy (Proxy (..))
import Data.Ratio (Ratio)
import Data.Scientific (Scientific (..), floatingOrInteger, scientific)
import qualified Data.Serialize as Cereal
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import qualified Data.Text.Lazy as LT
import qualified Data.Text.Lazy.Encoding as LT
import Data.Time (CalendarDiffDays (..), CalendarDiffTime (..), Day, LocalTime (..), NominalDiffTime, TimeOfDay, UTCTime (..), ZonedTime, diffDays, diffTimeToPicoseconds, fromGregorian, picosecondsToDiffTime, secondsToNominalDiffTime, timeOfDayToTime, timeToTimeOfDay, utc, utcToZonedTime, zonedTimeToUTC)
import Data.Time.Calendar.Julian (addJulianDurationClip, fromJulian)
import Data.Tuple.Only (Only (..))
import Data.UUID.Types (UUID)
import qualified Data.UUID.Types as UUID
import Data.Vector (Vector)
import qualified Data.Vector as Vector
import Data.Word (Word32, Word64)
import GHC.Float (castDoubleToWord64, castFloatToWord32, castWord32ToFloat, castWord64ToDouble, expt, float2Double)
import GHC.Generics (C, D, Generic (..), K1 (..), M1 (..), Meta (MetaCons), U1 (..), (:*:) (..), (:+:) (..))
import GHC.TypeLits (KnownSymbol, TypeError, symbolVal)
import qualified GHC.TypeLits as TypeLits
import Hpgsql.Builder (BinaryField (..))
import qualified Hpgsql.Builder as Builder
import qualified Hpgsql.SimpleParser as Parser
import Hpgsql.Time (Unbounded (..))
import Hpgsql.TypeInfo (EncodingContext (..), Oid (..), TypeDetails (..), TypeInfo (..), boolOid, byteaOid, charOid, dateOid, float4Oid, float8Oid, int2Oid, int4Oid, int8Oid, intervalOid, jsonOid, jsonbOid, lookupTypeByName, lookupTypeByOid, nameOid, numericOid, oidOid, textOid, timeOid, timestampOid, timestamptzOid, uuidOid, varcharOid, voidOid)

data FieldInfo = FieldInfo
  { FieldInfo -> Oid
fieldTypeOid :: !Oid,
    -- | The column name from the query's result, if available.
    FieldInfo -> Maybe Text
fieldName :: !(Maybe Text),
    -- | The EncodingContext as of the moment the query ran.
    FieldInfo -> EncodingContext
encodingContext :: !EncodingContext
  }

-- | A decoder for a single field/column.
data FieldDecoder a = FieldDecoder
  { forall a.
FieldDecoder a -> FieldInfo -> Maybe ByteString -> Either String a
fieldValueDecoder :: FieldInfo -> Maybe ByteString -> Either String a,
    forall a. FieldDecoder a -> FieldInfo -> Bool
allowedPgTypes :: FieldInfo -> Bool
  }
  deriving stock ((forall a b. (a -> b) -> FieldDecoder a -> FieldDecoder b)
-> (forall a b. a -> FieldDecoder b -> FieldDecoder a)
-> Functor FieldDecoder
forall a b. a -> FieldDecoder b -> FieldDecoder a
forall a b. (a -> b) -> FieldDecoder a -> FieldDecoder b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> FieldDecoder a -> FieldDecoder b
fmap :: forall a b. (a -> b) -> FieldDecoder a -> FieldDecoder b
$c<$ :: forall a b. a -> FieldDecoder b -> FieldDecoder a
<$ :: forall a b. a -> FieldDecoder b -> FieldDecoder a
Functor)

-- | `f1 <> f2` produces a `FieldDecoder` that tries `f1` first, and if that fails it tries `f2`.
instance Semigroup (FieldDecoder a) where
  FieldDecoder a
dec1 <> :: FieldDecoder a -> FieldDecoder a -> FieldDecoder a
<> FieldDecoder a
dec2 =
    FieldDecoder
      { fieldValueDecoder :: FieldInfo -> Maybe ByteString -> Either String a
fieldValueDecoder = \FieldInfo
cInfo ->
          let f1 :: Maybe ByteString -> Either String a
f1 = FieldDecoder a
dec1.fieldValueDecoder FieldInfo
cInfo
              f2 :: Maybe ByteString -> Either String a
f2 = FieldDecoder a
dec2.fieldValueDecoder FieldInfo
cInfo
           in \Maybe ByteString
mbs ->
                let cand1 :: Either String a
cand1 = if FieldDecoder a
dec1.allowedPgTypes FieldInfo
cInfo then Maybe ByteString -> Either String a
f1 Maybe ByteString
mbs else String -> Either String a
forall a b. a -> Either a b
Left String
"Not first parser"
                    cand2 :: Either String a
cand2 = if FieldDecoder a
dec2.allowedPgTypes FieldInfo
cInfo then Maybe ByteString -> Either String a
f2 Maybe ByteString
mbs else String -> Either String a
forall a b. a -> Either a b
Left String
"Not second parser"
                 in Either String a
cand1 Either String a -> Either String a -> Either String a
forall a. Semigroup a => a -> a -> a
<> Either String a
cand2,
        allowedPgTypes :: FieldInfo -> Bool
allowedPgTypes = \FieldInfo
cInfo -> FieldDecoder a
dec1.allowedPgTypes FieldInfo
cInfo Bool -> Bool -> Bool
|| FieldDecoder a
dec2.allowedPgTypes FieldInfo
cInfo
      }

data RowDecoder a = RowDecoder
  { forall a. RowDecoder a -> [FieldInfo] -> Parser a
fullRowDecoder :: [FieldInfo] -> Parser.Parser a,
    -- | Returns the same colInfos with a boolean indicating if
    -- the expected types match for each colInfo.
    forall a. RowDecoder a -> [FieldInfo] -> [(FieldInfo, Bool)]
rowColumnsTypeCheck :: [FieldInfo] -> [(FieldInfo, Bool)],
    forall a. RowDecoder a -> Int
numExpectedColumns :: !Int
  }
  deriving stock ((forall a b. (a -> b) -> RowDecoder a -> RowDecoder b)
-> (forall a b. a -> RowDecoder b -> RowDecoder a)
-> Functor RowDecoder
forall a b. a -> RowDecoder b -> RowDecoder a
forall a b. (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> RowDecoder a -> RowDecoder b
fmap :: forall a b. (a -> b) -> RowDecoder a -> RowDecoder b
$c<$ :: forall a b. a -> RowDecoder b -> RowDecoder a
<$ :: forall a b. a -> RowDecoder b -> RowDecoder a
Functor, (forall x. RowDecoder a -> Rep (RowDecoder a) x)
-> (forall x. Rep (RowDecoder a) x -> RowDecoder a)
-> Generic (RowDecoder a)
forall x. Rep (RowDecoder a) x -> RowDecoder a
forall x. RowDecoder a -> Rep (RowDecoder a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (RowDecoder a) x -> RowDecoder a
forall a x. RowDecoder a -> Rep (RowDecoder a) x
$cfrom :: forall a x. RowDecoder a -> Rep (RowDecoder a) x
from :: forall x. RowDecoder a -> Rep (RowDecoder a) x
$cto :: forall a x. Rep (RowDecoder a) x -> RowDecoder a
to :: forall x. Rep (RowDecoder a) x -> RowDecoder a
Generic)

instance Applicative RowDecoder where
  pure :: forall a. a -> RowDecoder a
pure a
v = ([FieldInfo] -> Parser a)
-> ([FieldInfo] -> [(FieldInfo, Bool)]) -> Int -> RowDecoder a
forall a.
([FieldInfo] -> Parser a)
-> ([FieldInfo] -> [(FieldInfo, Bool)]) -> Int -> RowDecoder a
RowDecoder (Parser a -> [FieldInfo] -> Parser a
forall a b. a -> b -> a
const (Parser a -> [FieldInfo] -> Parser a)
-> Parser a -> [FieldInfo] -> Parser a
forall a b. (a -> b) -> a -> b
$ a -> Parser a
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
v) ((FieldInfo -> (FieldInfo, Bool))
-> [FieldInfo] -> [(FieldInfo, Bool)]
forall a b. (a -> b) -> [a] -> [b]
map (,Bool
True)) Int
0
  RowDecoder [FieldInfo] -> Parser (a -> b)
p1 [FieldInfo] -> [(FieldInfo, Bool)]
tc1 Int
nc1 <*> :: forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
<*> RowDecoder [FieldInfo] -> Parser a
p2 [FieldInfo] -> [(FieldInfo, Bool)]
tc2 Int
nc2 = ([FieldInfo] -> Parser b)
-> ([FieldInfo] -> [(FieldInfo, Bool)]) -> Int -> RowDecoder b
forall a.
([FieldInfo] -> Parser a)
-> ([FieldInfo] -> [(FieldInfo, Bool)]) -> Int -> RowDecoder a
RowDecoder (\[FieldInfo]
colTypes -> let ([FieldInfo]
cols1, [FieldInfo]
cols2) = Int -> [FieldInfo] -> ([FieldInfo], [FieldInfo])
forall a. Int -> [a] -> ([a], [a])
List.splitAt Int
nc1 [FieldInfo]
colTypes in [FieldInfo] -> Parser (a -> b)
p1 [FieldInfo]
cols1 Parser (a -> b) -> Parser a -> Parser b
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [FieldInfo] -> Parser a
p2 [FieldInfo]
cols2) (\[FieldInfo]
colTypes -> let ([FieldInfo]
cols1, [FieldInfo]
cols2) = Int -> [FieldInfo] -> ([FieldInfo], [FieldInfo])
forall a. Int -> [a] -> ([a], [a])
List.splitAt Int
nc1 [FieldInfo]
colTypes in [FieldInfo] -> [(FieldInfo, Bool)]
tc1 [FieldInfo]
cols1 [(FieldInfo, Bool)] -> [(FieldInfo, Bool)] -> [(FieldInfo, Bool)]
forall a. [a] -> [a] -> [a]
++ [FieldInfo] -> [(FieldInfo, Bool)]
tc2 [FieldInfo]
cols2) (Int
nc1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
nc2)

instance (TypeError (TypeLits.Text "RowDecoder does not have a Monad instance in Hpgsql because Hpgsql type-checks the result types of queries before having access to even the first data row. Use the Applicative class to write your instances or use the Monadic decoding variants.")) => Monad RowDecoder where
  >>= :: forall a b. RowDecoder a -> (a -> RowDecoder b) -> RowDecoder b
(>>=) = String -> RowDecoder a -> (a -> RowDecoder b) -> RowDecoder b
forall a. HasCallStack => String -> a
error String
"inaccessible bind in Monad RowDecoder instance"

singleField :: FieldDecoder a -> RowDecoder a
singleField :: forall a. FieldDecoder a -> RowDecoder a
singleField (FieldDecoder {FieldInfo -> Bool
FieldInfo -> Maybe ByteString -> Either String a
fieldValueDecoder :: forall a.
FieldDecoder a -> FieldInfo -> Maybe ByteString -> Either String a
allowedPgTypes :: forall a. FieldDecoder a -> FieldInfo -> Bool
fieldValueDecoder :: FieldInfo -> Maybe ByteString -> Either String a
allowedPgTypes :: FieldInfo -> Bool
..}) =
  RowDecoder
    { fullRowDecoder :: [FieldInfo] -> Parser a
fullRowDecoder = \case
        [FieldInfo
singleColInfo] ->
          let decode :: Maybe ByteString -> Either String a
decode = FieldInfo -> Maybe ByteString -> Either String a
fieldValueDecoder FieldInfo
singleColInfo
           in do
                lenNextCol <- Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int32 -> Int) -> Parser Int32 -> Parser Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Int32
int32Parser
                nextColBs <-
                  if lenNextCol >= 0
                    then
                      Just <$> Parser.take lenNextCol
                    else pure Nothing
                case decode nextColBs of
                  Right a
v -> a -> Parser a
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
v
                  Left String
err -> String -> Parser a
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err
        [FieldInfo]
_ -> String -> Parser a
forall a. HasCallStack => String -> a
error String
"singleField expected a single column OID but got 0 or >1",
      rowColumnsTypeCheck :: [FieldInfo] -> [(FieldInfo, Bool)]
rowColumnsTypeCheck = \case
        [FieldInfo
singleColInfo] -> [(FieldInfo
singleColInfo, FieldInfo -> Bool
allowedPgTypes FieldInfo
singleColInfo)]
        [FieldInfo]
_ -> String -> [(FieldInfo, Bool)]
forall a. HasCallStack => String -> a
error String
"singleField's rowColumnsTypeCheck expected a single column OID but got 0 or >1",
      numExpectedColumns :: Int
numExpectedColumns = Int
1
    }

int32Parser :: Parser.Parser Int32
int32Parser :: Parser Int32
int32Parser = (String -> Parser Int32)
-> (Int32 -> Parser Int32) -> Either String Int32 -> Parser Int32
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Parser Int32
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail Int32 -> Parser Int32
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String Int32 -> Parser Int32)
-> (ByteString -> Either String Int32)
-> ByteString
-> Parser Int32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Serialize a => ByteString -> Either String a
Cereal.decode @Int32 (ByteString -> Parser Int32) -> Parser ByteString -> Parser Int32
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Int -> Parser ByteString
Parser.take Int
4

class FromPgField a where
  fieldDecoder :: FieldDecoder a

class FromPgRow a where
  rowDecoder :: RowDecoder a
  default rowDecoder :: (Generic a, ProductTypeDecoder (Rep a)) => RowDecoder a
  rowDecoder = RowDecoder a
forall a. (Generic a, ProductTypeDecoder (Rep a)) => RowDecoder a
genericFromPgRow

-- | Allows you to create a @FieldDecoder@ for composite types.
-- For a type such as:
--
-- > CREATE TYPE int_and_bool AS (numfield INT, boolfield BOOL);
--
-- You can define a Haskell type as such:
--
-- > data IntAndBool = IntAndBool Int Bool
-- >
-- > instance FromPgField IntAndBool where
-- >   fieldDecoder = compositeTypeDecoder rowDecoder <&> \(i, b) -> IntAndBool i b
compositeTypeDecoder :: forall a. RowDecoder a -> FieldDecoder a
compositeTypeDecoder :: forall a. RowDecoder a -> FieldDecoder a
compositeTypeDecoder (RowDecoder {Int
[FieldInfo] -> [(FieldInfo, Bool)]
[FieldInfo] -> Parser a
fullRowDecoder :: forall a. RowDecoder a -> [FieldInfo] -> Parser a
rowColumnsTypeCheck :: forall a. RowDecoder a -> [FieldInfo] -> [(FieldInfo, Bool)]
numExpectedColumns :: forall a. RowDecoder a -> Int
fullRowDecoder :: [FieldInfo] -> Parser a
rowColumnsTypeCheck :: [FieldInfo] -> [(FieldInfo, Bool)]
numExpectedColumns :: Int
..}) =
  FieldDecoder
    { fieldValueDecoder :: FieldInfo -> Maybe ByteString -> Either String a
fieldValueDecoder = \FieldInfo
compositeTypeOid -> \case
        Maybe ByteString
Nothing -> String -> Either String a
forall a b. a -> Either a b
Left String
"Got NULL in composite type but it was not allowed"
        Just ByteString
bs -> case Parser a -> ByteString -> ParseResult a
forall a. Parser a -> ByteString -> ParseResult a
Parser.parseOnly (EncodingContext -> Parser a
parserForRecord FieldInfo
compositeTypeOid.encodingContext Parser a -> Parser () -> Parser a
forall a b. Parser a -> Parser b -> Parser a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
Parser.endOfInput) ByteString
bs of
          Parser.ParseOk a
v -> a -> Either String a
forall a b. b -> Either a b
Right a
v
          Parser.ParseFail String
err -> String -> Either String a
forall a b. a -> Either a b
Left String
err,
      allowedPgTypes :: FieldInfo -> Bool
allowedPgTypes = Bool -> FieldInfo -> Bool
forall a b. a -> b -> a
const Bool
True -- There's no way to enforce a custom type's OID. We only check if it's structurally the same in the parser (same subtypes in same order)
    }
  where
    parserForRecord :: EncodingContext -> Parser.Parser a
    parserForRecord :: EncodingContext -> Parser a
parserForRecord EncodingContext
encodingContext = do
      -- From https://github.com/postgres/postgres/blob/50ba65e73325cf55fedb3e1f14673d816726923b/src/backend/utils/adt/rowtypes.c#L687
      -- we can see a composite type's binary representation consists of: number of columns (Int32) + for_each_column { OID (Int32) + size_or_minus_1 (Int32) + Bytes }
      numCols <- Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int32 -> Int) -> Parser Int32 -> Parser Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Int32
int32Parser
      unless (numCols == numExpectedColumns) $ fail $ "Composite type has " ++ show numCols ++ " attributes but parser expected " ++ show numExpectedColumns
      let mkColInfo Oid
oid = Oid -> Maybe Text -> EncodingContext -> FieldInfo
FieldInfo Oid
oid Maybe Text
forall a. Maybe a
Nothing EncodingContext
encodingContext
      cols <- replicateM numCols $ do
        !oid <- Oid . fromIntegral <$> int32Parser
        (sizeBs, !size) <- Parser.match $ fromIntegral <$> int32Parser
        !bs <- Parser.take (max 0 size)
        pure (oid, sizeBs <> bs)
      let typecheckedCols = [FieldInfo] -> [(FieldInfo, Bool)]
rowColumnsTypeCheck (((Oid, ByteString) -> FieldInfo)
-> [(Oid, ByteString)] -> [FieldInfo]
forall a b. (a -> b) -> [a] -> [b]
map (Oid -> FieldInfo
mkColInfo (Oid -> FieldInfo)
-> ((Oid, ByteString) -> Oid) -> (Oid, ByteString) -> FieldInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Oid, ByteString) -> Oid
forall a b. (a, b) -> a
fst) [(Oid, ByteString)]
cols)
      unless (all snd typecheckedCols) $ fail $ "Parser for composite found type OIDs " ++ show (map fst cols) ++ " but expected different"
      case Parser.parseOnly (fullRowDecoder (map (mkColInfo . fst) cols) <* Parser.endOfInput) (mconcat $ map snd cols) of
        Parser.ParseOk a
v -> a -> Parser a
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
v
        Parser.ParseFail String
err -> String -> Parser a
forall a. HasCallStack => String -> a
error (String -> Parser a) -> String -> Parser a
forall a b. (a -> b) -> a -> b
$ String
"Error decoding composite type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
err

-- | Allows you to create a @FieldEncoder@ for composite types.
-- For a type such as:
--
-- > CREATE TYPE int_and_bool AS (numfield INT, boolfield BOOL);
--
-- You can define a Haskell type as such:
--
-- > data IntAndBool = IntAndBool Int Bool
-- >
-- > instance ToPgField IntAndBool where
-- >   fieldEncoder = typeFieldEncoder (typeOidWithName "int_and_bool")
-- >     $ compositeTypeEncoder $ contramap (\(IntAndBool i b) -> (fromIntegral i :: Int32, b)) rowEncoder
compositeTypeEncoder :: forall a. RowEncoder a -> FieldEncoder a
compositeTypeEncoder :: forall a. RowEncoder a -> FieldEncoder a
compositeTypeEncoder RowEncoder a
rowEnc =
  FieldEncoder
    { toTypeOid :: EncodingContext -> Maybe Oid
toTypeOid = \EncodingContext
_ -> Maybe Oid
forall a. Maybe a
Nothing,
      toPgField :: EncodingContext -> a -> BinaryField
toPgField = \EncodingContext
encCtx -> \a
a ->
        let fields :: [(Maybe Oid, BinaryField)]
fields = ((EncodingContext -> (Maybe Oid, BinaryField))
 -> (Maybe Oid, BinaryField))
-> [EncodingContext -> (Maybe Oid, BinaryField)]
-> [(Maybe Oid, BinaryField)]
forall a b. (a -> b) -> [a] -> [b]
map (\EncodingContext -> (Maybe Oid, BinaryField)
f -> EncodingContext -> (Maybe Oid, BinaryField)
f EncodingContext
encCtx) (RowEncoder a
rowEnc.toPgParams a
a)
            numCols :: LengthAwareBuilder
numCols = Int32 -> LengthAwareBuilder
Builder.int32BE (Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int32) -> Int -> Int32
forall a b. (a -> b) -> a -> b
$ [(Maybe Oid, BinaryField)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Maybe Oid, BinaryField)]
fields)
            encodeField :: (Maybe Oid, BinaryField) -> LengthAwareBuilder
encodeField (Maybe Oid
mOid, BinaryField
bf) =
              let Oid Int32
oid = Oid -> Maybe Oid -> Oid
forall a. a -> Maybe a -> a
fromMaybe (Int32 -> Oid
Oid Int32
0) Maybe Oid
mOid
               in Int32 -> LengthAwareBuilder
Builder.int32BE Int32
oid LengthAwareBuilder -> LengthAwareBuilder -> LengthAwareBuilder
forall a. Semigroup a => a -> a -> a
<> BinaryField -> LengthAwareBuilder
Builder.binaryField BinaryField
bf
         in ByteString -> BinaryField
NotNull (LengthAwareBuilder -> ByteString
Builder.toStrictByteString (LengthAwareBuilder
numCols LengthAwareBuilder -> LengthAwareBuilder -> LengthAwareBuilder
forall a. Semigroup a => a -> a -> a
<> ((Maybe Oid, BinaryField) -> LengthAwareBuilder)
-> [(Maybe Oid, BinaryField)] -> LengthAwareBuilder
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Maybe Oid, BinaryField) -> LengthAwareBuilder
encodeField [(Maybe Oid, BinaryField)]
fields))
    }

instance (FromPgField a) => FromPgRow (Only a) where
  rowDecoder :: RowDecoder (Only a)
rowDecoder = a -> Only a
forall a. a -> Only a
Only (a -> Only a) -> RowDecoder a -> RowDecoder (Only a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FieldDecoder a -> RowDecoder a
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder a
forall a. FromPgField a => FieldDecoder a
fieldDecoder

instance (FromPgField a, FromPgField b) => FromPgRow (a, b) where
  rowDecoder :: RowDecoder (a, b)
rowDecoder = (,) (a -> b -> (a, b)) -> RowDecoder a -> RowDecoder (b -> (a, b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FieldDecoder a -> RowDecoder a
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder a
forall a. FromPgField a => FieldDecoder a
fieldDecoder RowDecoder (b -> (a, b)) -> RowDecoder b -> RowDecoder (a, b)
forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldDecoder b -> RowDecoder b
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder b
forall a. FromPgField a => FieldDecoder a
fieldDecoder

instance (FromPgField a, FromPgField b, FromPgField c) => FromPgRow (a, b, c) where
  rowDecoder :: RowDecoder (a, b, c)
rowDecoder = (,,) (a -> b -> c -> (a, b, c))
-> RowDecoder a -> RowDecoder (b -> c -> (a, b, c))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FieldDecoder a -> RowDecoder a
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder a
forall a. FromPgField a => FieldDecoder a
fieldDecoder RowDecoder (b -> c -> (a, b, c))
-> RowDecoder b -> RowDecoder (c -> (a, b, c))
forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldDecoder b -> RowDecoder b
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder b
forall a. FromPgField a => FieldDecoder a
fieldDecoder RowDecoder (c -> (a, b, c)) -> RowDecoder c -> RowDecoder (a, b, c)
forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldDecoder c -> RowDecoder c
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder c
forall a. FromPgField a => FieldDecoder a
fieldDecoder

instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d) => FromPgRow (a, b, c, d) where
  rowDecoder :: RowDecoder (a, b, c, d)
rowDecoder = (,,,) (a -> b -> c -> d -> (a, b, c, d))
-> RowDecoder a -> RowDecoder (b -> c -> d -> (a, b, c, d))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FieldDecoder a -> RowDecoder a
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder a
forall a. FromPgField a => FieldDecoder a
fieldDecoder RowDecoder (b -> c -> d -> (a, b, c, d))
-> RowDecoder b -> RowDecoder (c -> d -> (a, b, c, d))
forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldDecoder b -> RowDecoder b
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder b
forall a. FromPgField a => FieldDecoder a
fieldDecoder RowDecoder (c -> d -> (a, b, c, d))
-> RowDecoder c -> RowDecoder (d -> (a, b, c, d))
forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldDecoder c -> RowDecoder c
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder c
forall a. FromPgField a => FieldDecoder a
fieldDecoder RowDecoder (d -> (a, b, c, d))
-> RowDecoder d -> RowDecoder (a, b, c, d)
forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldDecoder d -> RowDecoder d
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder d
forall a. FromPgField a => FieldDecoder a
fieldDecoder

instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e) => FromPgRow (a, b, c, d, e) where
  rowDecoder :: RowDecoder (a, b, c, d, e)
rowDecoder = (,,,,) (a -> b -> c -> d -> e -> (a, b, c, d, e))
-> RowDecoder a -> RowDecoder (b -> c -> d -> e -> (a, b, c, d, e))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FieldDecoder a -> RowDecoder a
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder a
forall a. FromPgField a => FieldDecoder a
fieldDecoder RowDecoder (b -> c -> d -> e -> (a, b, c, d, e))
-> RowDecoder b -> RowDecoder (c -> d -> e -> (a, b, c, d, e))
forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldDecoder b -> RowDecoder b
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder b
forall a. FromPgField a => FieldDecoder a
fieldDecoder RowDecoder (c -> d -> e -> (a, b, c, d, e))
-> RowDecoder c -> RowDecoder (d -> e -> (a, b, c, d, e))
forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldDecoder c -> RowDecoder c
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder c
forall a. FromPgField a => FieldDecoder a
fieldDecoder RowDecoder (d -> e -> (a, b, c, d, e))
-> RowDecoder d -> RowDecoder (e -> (a, b, c, d, e))
forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldDecoder d -> RowDecoder d
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder d
forall a. FromPgField a => FieldDecoder a
fieldDecoder RowDecoder (e -> (a, b, c, d, e))
-> RowDecoder e -> RowDecoder (a, b, c, d, e)
forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldDecoder e -> RowDecoder e
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder e
forall a. FromPgField a => FieldDecoder a
fieldDecoder

instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e, FromPgField f) => FromPgRow (a, b, c, d, e, f) where
  rowDecoder :: RowDecoder (a, b, c, d, e, f)
rowDecoder = (,,,,,) (a -> b -> c -> d -> e -> f -> (a, b, c, d, e, f))
-> RowDecoder a
-> RowDecoder (b -> c -> d -> e -> f -> (a, b, c, d, e, f))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FieldDecoder a -> RowDecoder a
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder a
forall a. FromPgField a => FieldDecoder a
fieldDecoder RowDecoder (b -> c -> d -> e -> f -> (a, b, c, d, e, f))
-> RowDecoder b
-> RowDecoder (c -> d -> e -> f -> (a, b, c, d, e, f))
forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldDecoder b -> RowDecoder b
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder b
forall a. FromPgField a => FieldDecoder a
fieldDecoder RowDecoder (c -> d -> e -> f -> (a, b, c, d, e, f))
-> RowDecoder c -> RowDecoder (d -> e -> f -> (a, b, c, d, e, f))
forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldDecoder c -> RowDecoder c
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder c
forall a. FromPgField a => FieldDecoder a
fieldDecoder RowDecoder (d -> e -> f -> (a, b, c, d, e, f))
-> RowDecoder d -> RowDecoder (e -> f -> (a, b, c, d, e, f))
forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldDecoder d -> RowDecoder d
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder d
forall a. FromPgField a => FieldDecoder a
fieldDecoder RowDecoder (e -> f -> (a, b, c, d, e, f))
-> RowDecoder e -> RowDecoder (f -> (a, b, c, d, e, f))
forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldDecoder e -> RowDecoder e
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder e
forall a. FromPgField a => FieldDecoder a
fieldDecoder RowDecoder (f -> (a, b, c, d, e, f))
-> RowDecoder f -> RowDecoder (a, b, c, d, e, f)
forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldDecoder f -> RowDecoder f
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder f
forall a. FromPgField a => FieldDecoder a
fieldDecoder

instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e, FromPgField f, FromPgField g) => FromPgRow (a, b, c, d, e, f, g) where
  rowDecoder :: RowDecoder (a, b, c, d, e, f, g)
rowDecoder = (,,,,,,) (a -> b -> c -> d -> e -> f -> g -> (a, b, c, d, e, f, g))
-> RowDecoder a
-> RowDecoder (b -> c -> d -> e -> f -> g -> (a, b, c, d, e, f, g))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FieldDecoder a -> RowDecoder a
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder a
forall a. FromPgField a => FieldDecoder a
fieldDecoder RowDecoder (b -> c -> d -> e -> f -> g -> (a, b, c, d, e, f, g))
-> RowDecoder b
-> RowDecoder (c -> d -> e -> f -> g -> (a, b, c, d, e, f, g))
forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldDecoder b -> RowDecoder b
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder b
forall a. FromPgField a => FieldDecoder a
fieldDecoder RowDecoder (c -> d -> e -> f -> g -> (a, b, c, d, e, f, g))
-> RowDecoder c
-> RowDecoder (d -> e -> f -> g -> (a, b, c, d, e, f, g))
forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldDecoder c -> RowDecoder c
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder c
forall a. FromPgField a => FieldDecoder a
fieldDecoder RowDecoder (d -> e -> f -> g -> (a, b, c, d, e, f, g))
-> RowDecoder d
-> RowDecoder (e -> f -> g -> (a, b, c, d, e, f, g))
forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldDecoder d -> RowDecoder d
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder d
forall a. FromPgField a => FieldDecoder a
fieldDecoder RowDecoder (e -> f -> g -> (a, b, c, d, e, f, g))
-> RowDecoder e -> RowDecoder (f -> g -> (a, b, c, d, e, f, g))
forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldDecoder e -> RowDecoder e
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder e
forall a. FromPgField a => FieldDecoder a
fieldDecoder RowDecoder (f -> g -> (a, b, c, d, e, f, g))
-> RowDecoder f -> RowDecoder (g -> (a, b, c, d, e, f, g))
forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldDecoder f -> RowDecoder f
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder f
forall a. FromPgField a => FieldDecoder a
fieldDecoder RowDecoder (g -> (a, b, c, d, e, f, g))
-> RowDecoder g -> RowDecoder (a, b, c, d, e, f, g)
forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldDecoder g -> RowDecoder g
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder g
forall a. FromPgField a => FieldDecoder a
fieldDecoder

instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e, FromPgField f, FromPgField g, FromPgField h) => FromPgRow (a, b, c, d, e, f, g, h) where
  rowDecoder :: RowDecoder (a, b, c, d, e, f, g, h)
rowDecoder = (,,,,,,,) (a -> b -> c -> d -> e -> f -> g -> h -> (a, b, c, d, e, f, g, h))
-> RowDecoder a
-> RowDecoder
     (b -> c -> d -> e -> f -> g -> h -> (a, b, c, d, e, f, g, h))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FieldDecoder a -> RowDecoder a
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder a
forall a. FromPgField a => FieldDecoder a
fieldDecoder RowDecoder
  (b -> c -> d -> e -> f -> g -> h -> (a, b, c, d, e, f, g, h))
-> RowDecoder b
-> RowDecoder
     (c -> d -> e -> f -> g -> h -> (a, b, c, d, e, f, g, h))
forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldDecoder b -> RowDecoder b
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder b
forall a. FromPgField a => FieldDecoder a
fieldDecoder RowDecoder (c -> d -> e -> f -> g -> h -> (a, b, c, d, e, f, g, h))
-> RowDecoder c
-> RowDecoder (d -> e -> f -> g -> h -> (a, b, c, d, e, f, g, h))
forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldDecoder c -> RowDecoder c
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder c
forall a. FromPgField a => FieldDecoder a
fieldDecoder RowDecoder (d -> e -> f -> g -> h -> (a, b, c, d, e, f, g, h))
-> RowDecoder d
-> RowDecoder (e -> f -> g -> h -> (a, b, c, d, e, f, g, h))
forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldDecoder d -> RowDecoder d
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder d
forall a. FromPgField a => FieldDecoder a
fieldDecoder RowDecoder (e -> f -> g -> h -> (a, b, c, d, e, f, g, h))
-> RowDecoder e
-> RowDecoder (f -> g -> h -> (a, b, c, d, e, f, g, h))
forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldDecoder e -> RowDecoder e
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder e
forall a. FromPgField a => FieldDecoder a
fieldDecoder RowDecoder (f -> g -> h -> (a, b, c, d, e, f, g, h))
-> RowDecoder f -> RowDecoder (g -> h -> (a, b, c, d, e, f, g, h))
forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldDecoder f -> RowDecoder f
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder f
forall a. FromPgField a => FieldDecoder a
fieldDecoder RowDecoder (g -> h -> (a, b, c, d, e, f, g, h))
-> RowDecoder g -> RowDecoder (h -> (a, b, c, d, e, f, g, h))
forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldDecoder g -> RowDecoder g
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder g
forall a. FromPgField a => FieldDecoder a
fieldDecoder RowDecoder (h -> (a, b, c, d, e, f, g, h))
-> RowDecoder h -> RowDecoder (a, b, c, d, e, f, g, h)
forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldDecoder h -> RowDecoder h
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder h
forall a. FromPgField a => FieldDecoder a
fieldDecoder

instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e, FromPgField f, FromPgField g, FromPgField h, FromPgField i) => FromPgRow (a, b, c, d, e, f, g, h, i) where
  rowDecoder :: RowDecoder (a, b, c, d, e, f, g, h, i)
rowDecoder = (,,,,,,,,) (a
 -> b
 -> c
 -> d
 -> e
 -> f
 -> g
 -> h
 -> i
 -> (a, b, c, d, e, f, g, h, i))
-> RowDecoder a
-> RowDecoder
     (b
      -> c -> d -> e -> f -> g -> h -> i -> (a, b, c, d, e, f, g, h, i))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FieldDecoder a -> RowDecoder a
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder a
forall a. FromPgField a => FieldDecoder a
fieldDecoder RowDecoder
  (b
   -> c -> d -> e -> f -> g -> h -> i -> (a, b, c, d, e, f, g, h, i))
-> RowDecoder b
-> RowDecoder
     (c -> d -> e -> f -> g -> h -> i -> (a, b, c, d, e, f, g, h, i))
forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldDecoder b -> RowDecoder b
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder b
forall a. FromPgField a => FieldDecoder a
fieldDecoder RowDecoder
  (c -> d -> e -> f -> g -> h -> i -> (a, b, c, d, e, f, g, h, i))
-> RowDecoder c
-> RowDecoder
     (d -> e -> f -> g -> h -> i -> (a, b, c, d, e, f, g, h, i))
forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldDecoder c -> RowDecoder c
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder c
forall a. FromPgField a => FieldDecoder a
fieldDecoder RowDecoder
  (d -> e -> f -> g -> h -> i -> (a, b, c, d, e, f, g, h, i))
-> RowDecoder d
-> RowDecoder
     (e -> f -> g -> h -> i -> (a, b, c, d, e, f, g, h, i))
forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldDecoder d -> RowDecoder d
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder d
forall a. FromPgField a => FieldDecoder a
fieldDecoder RowDecoder (e -> f -> g -> h -> i -> (a, b, c, d, e, f, g, h, i))
-> RowDecoder e
-> RowDecoder (f -> g -> h -> i -> (a, b, c, d, e, f, g, h, i))
forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldDecoder e -> RowDecoder e
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder e
forall a. FromPgField a => FieldDecoder a
fieldDecoder RowDecoder (f -> g -> h -> i -> (a, b, c, d, e, f, g, h, i))
-> RowDecoder f
-> RowDecoder (g -> h -> i -> (a, b, c, d, e, f, g, h, i))
forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldDecoder f -> RowDecoder f
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder f
forall a. FromPgField a => FieldDecoder a
fieldDecoder RowDecoder (g -> h -> i -> (a, b, c, d, e, f, g, h, i))
-> RowDecoder g
-> RowDecoder (h -> i -> (a, b, c, d, e, f, g, h, i))
forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldDecoder g -> RowDecoder g
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder g
forall a. FromPgField a => FieldDecoder a
fieldDecoder RowDecoder (h -> i -> (a, b, c, d, e, f, g, h, i))
-> RowDecoder h -> RowDecoder (i -> (a, b, c, d, e, f, g, h, i))
forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldDecoder h -> RowDecoder h
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder h
forall a. FromPgField a => FieldDecoder a
fieldDecoder RowDecoder (i -> (a, b, c, d, e, f, g, h, i))
-> RowDecoder i -> RowDecoder (a, b, c, d, e, f, g, h, i)
forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldDecoder i -> RowDecoder i
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder i
forall a. FromPgField a => FieldDecoder a
fieldDecoder

instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e, FromPgField f, FromPgField g, FromPgField h, FromPgField i, FromPgField j) => FromPgRow (a, b, c, d, e, f, g, h, i, j) where
  rowDecoder :: RowDecoder (a, b, c, d, e, f, g, h, i, j)
rowDecoder = (,,,,,,,,,) (a
 -> b
 -> c
 -> d
 -> e
 -> f
 -> g
 -> h
 -> i
 -> j
 -> (a, b, c, d, e, f, g, h, i, j))
-> RowDecoder a
-> RowDecoder
     (b
      -> c
      -> d
      -> e
      -> f
      -> g
      -> h
      -> i
      -> j
      -> (a, b, c, d, e, f, g, h, i, j))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FieldDecoder a -> RowDecoder a
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder a
forall a. FromPgField a => FieldDecoder a
fieldDecoder RowDecoder
  (b
   -> c
   -> d
   -> e
   -> f
   -> g
   -> h
   -> i
   -> j
   -> (a, b, c, d, e, f, g, h, i, j))
-> RowDecoder b
-> RowDecoder
     (c
      -> d
      -> e
      -> f
      -> g
      -> h
      -> i
      -> j
      -> (a, b, c, d, e, f, g, h, i, j))
forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldDecoder b -> RowDecoder b
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder b
forall a. FromPgField a => FieldDecoder a
fieldDecoder RowDecoder
  (c
   -> d
   -> e
   -> f
   -> g
   -> h
   -> i
   -> j
   -> (a, b, c, d, e, f, g, h, i, j))
-> RowDecoder c
-> RowDecoder
     (d -> e -> f -> g -> h -> i -> j -> (a, b, c, d, e, f, g, h, i, j))
forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldDecoder c -> RowDecoder c
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder c
forall a. FromPgField a => FieldDecoder a
fieldDecoder RowDecoder
  (d -> e -> f -> g -> h -> i -> j -> (a, b, c, d, e, f, g, h, i, j))
-> RowDecoder d
-> RowDecoder
     (e -> f -> g -> h -> i -> j -> (a, b, c, d, e, f, g, h, i, j))
forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldDecoder d -> RowDecoder d
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder d
forall a. FromPgField a => FieldDecoder a
fieldDecoder RowDecoder
  (e -> f -> g -> h -> i -> j -> (a, b, c, d, e, f, g, h, i, j))
-> RowDecoder e
-> RowDecoder
     (f -> g -> h -> i -> j -> (a, b, c, d, e, f, g, h, i, j))
forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldDecoder e -> RowDecoder e
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder e
forall a. FromPgField a => FieldDecoder a
fieldDecoder RowDecoder
  (f -> g -> h -> i -> j -> (a, b, c, d, e, f, g, h, i, j))
-> RowDecoder f
-> RowDecoder (g -> h -> i -> j -> (a, b, c, d, e, f, g, h, i, j))
forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldDecoder f -> RowDecoder f
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder f
forall a. FromPgField a => FieldDecoder a
fieldDecoder RowDecoder (g -> h -> i -> j -> (a, b, c, d, e, f, g, h, i, j))
-> RowDecoder g
-> RowDecoder (h -> i -> j -> (a, b, c, d, e, f, g, h, i, j))
forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldDecoder g -> RowDecoder g
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder g
forall a. FromPgField a => FieldDecoder a
fieldDecoder RowDecoder (h -> i -> j -> (a, b, c, d, e, f, g, h, i, j))
-> RowDecoder h
-> RowDecoder (i -> j -> (a, b, c, d, e, f, g, h, i, j))
forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldDecoder h -> RowDecoder h
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder h
forall a. FromPgField a => FieldDecoder a
fieldDecoder RowDecoder (i -> j -> (a, b, c, d, e, f, g, h, i, j))
-> RowDecoder i -> RowDecoder (j -> (a, b, c, d, e, f, g, h, i, j))
forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldDecoder i -> RowDecoder i
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder i
forall a. FromPgField a => FieldDecoder a
fieldDecoder RowDecoder (j -> (a, b, c, d, e, f, g, h, i, j))
-> RowDecoder j -> RowDecoder (a, b, c, d, e, f, g, h, i, j)
forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldDecoder j -> RowDecoder j
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder j
forall a. FromPgField a => FieldDecoder a
fieldDecoder

instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e, FromPgField f, FromPgField g, FromPgField h, FromPgField i, FromPgField j, FromPgField k) => FromPgRow (a, b, c, d, e, f, g, h, i, j, k) where
  rowDecoder :: RowDecoder (a, b, c, d, e, f, g, h, i, j, k)
rowDecoder = (,,,,,,,,,,) (a
 -> b
 -> c
 -> d
 -> e
 -> f
 -> g
 -> h
 -> i
 -> j
 -> k
 -> (a, b, c, d, e, f, g, h, i, j, k))
-> RowDecoder a
-> RowDecoder
     (b
      -> c
      -> d
      -> e
      -> f
      -> g
      -> h
      -> i
      -> j
      -> k
      -> (a, b, c, d, e, f, g, h, i, j, k))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FieldDecoder a -> RowDecoder a
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder a
forall a. FromPgField a => FieldDecoder a
fieldDecoder RowDecoder
  (b
   -> c
   -> d
   -> e
   -> f
   -> g
   -> h
   -> i
   -> j
   -> k
   -> (a, b, c, d, e, f, g, h, i, j, k))
-> RowDecoder b
-> RowDecoder
     (c
      -> d
      -> e
      -> f
      -> g
      -> h
      -> i
      -> j
      -> k
      -> (a, b, c, d, e, f, g, h, i, j, k))
forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldDecoder b -> RowDecoder b
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder b
forall a. FromPgField a => FieldDecoder a
fieldDecoder RowDecoder
  (c
   -> d
   -> e
   -> f
   -> g
   -> h
   -> i
   -> j
   -> k
   -> (a, b, c, d, e, f, g, h, i, j, k))
-> RowDecoder c
-> RowDecoder
     (d
      -> e
      -> f
      -> g
      -> h
      -> i
      -> j
      -> k
      -> (a, b, c, d, e, f, g, h, i, j, k))
forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldDecoder c -> RowDecoder c
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder c
forall a. FromPgField a => FieldDecoder a
fieldDecoder RowDecoder
  (d
   -> e
   -> f
   -> g
   -> h
   -> i
   -> j
   -> k
   -> (a, b, c, d, e, f, g, h, i, j, k))
-> RowDecoder d
-> RowDecoder
     (e
      -> f -> g -> h -> i -> j -> k -> (a, b, c, d, e, f, g, h, i, j, k))
forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldDecoder d -> RowDecoder d
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder d
forall a. FromPgField a => FieldDecoder a
fieldDecoder RowDecoder
  (e
   -> f -> g -> h -> i -> j -> k -> (a, b, c, d, e, f, g, h, i, j, k))
-> RowDecoder e
-> RowDecoder
     (f -> g -> h -> i -> j -> k -> (a, b, c, d, e, f, g, h, i, j, k))
forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldDecoder e -> RowDecoder e
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder e
forall a. FromPgField a => FieldDecoder a
fieldDecoder RowDecoder
  (f -> g -> h -> i -> j -> k -> (a, b, c, d, e, f, g, h, i, j, k))
-> RowDecoder f
-> RowDecoder
     (g -> h -> i -> j -> k -> (a, b, c, d, e, f, g, h, i, j, k))
forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldDecoder f -> RowDecoder f
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder f
forall a. FromPgField a => FieldDecoder a
fieldDecoder RowDecoder
  (g -> h -> i -> j -> k -> (a, b, c, d, e, f, g, h, i, j, k))
-> RowDecoder g
-> RowDecoder
     (h -> i -> j -> k -> (a, b, c, d, e, f, g, h, i, j, k))
forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldDecoder g -> RowDecoder g
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder g
forall a. FromPgField a => FieldDecoder a
fieldDecoder RowDecoder (h -> i -> j -> k -> (a, b, c, d, e, f, g, h, i, j, k))
-> RowDecoder h
-> RowDecoder (i -> j -> k -> (a, b, c, d, e, f, g, h, i, j, k))
forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldDecoder h -> RowDecoder h
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder h
forall a. FromPgField a => FieldDecoder a
fieldDecoder RowDecoder (i -> j -> k -> (a, b, c, d, e, f, g, h, i, j, k))
-> RowDecoder i
-> RowDecoder (j -> k -> (a, b, c, d, e, f, g, h, i, j, k))
forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldDecoder i -> RowDecoder i
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder i
forall a. FromPgField a => FieldDecoder a
fieldDecoder RowDecoder (j -> k -> (a, b, c, d, e, f, g, h, i, j, k))
-> RowDecoder j
-> RowDecoder (k -> (a, b, c, d, e, f, g, h, i, j, k))
forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldDecoder j -> RowDecoder j
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder j
forall a. FromPgField a => FieldDecoder a
fieldDecoder RowDecoder (k -> (a, b, c, d, e, f, g, h, i, j, k))
-> RowDecoder k -> RowDecoder (a, b, c, d, e, f, g, h, i, j, k)
forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldDecoder k -> RowDecoder k
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder k
forall a. FromPgField a => FieldDecoder a
fieldDecoder

instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e, FromPgField f, FromPgField g, FromPgField h, FromPgField i, FromPgField j, FromPgField k, FromPgField l) => FromPgRow (a, b, c, d, e, f, g, h, i, j, k, l) where
  rowDecoder :: RowDecoder (a, b, c, d, e, f, g, h, i, j, k, l)
rowDecoder = (,,,,,,,,,,,) (a
 -> b
 -> c
 -> d
 -> e
 -> f
 -> g
 -> h
 -> i
 -> j
 -> k
 -> l
 -> (a, b, c, d, e, f, g, h, i, j, k, l))
-> RowDecoder a
-> RowDecoder
     (b
      -> c
      -> d
      -> e
      -> f
      -> g
      -> h
      -> i
      -> j
      -> k
      -> l
      -> (a, b, c, d, e, f, g, h, i, j, k, l))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FieldDecoder a -> RowDecoder a
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder a
forall a. FromPgField a => FieldDecoder a
fieldDecoder RowDecoder
  (b
   -> c
   -> d
   -> e
   -> f
   -> g
   -> h
   -> i
   -> j
   -> k
   -> l
   -> (a, b, c, d, e, f, g, h, i, j, k, l))
-> RowDecoder b
-> RowDecoder
     (c
      -> d
      -> e
      -> f
      -> g
      -> h
      -> i
      -> j
      -> k
      -> l
      -> (a, b, c, d, e, f, g, h, i, j, k, l))
forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldDecoder b -> RowDecoder b
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder b
forall a. FromPgField a => FieldDecoder a
fieldDecoder RowDecoder
  (c
   -> d
   -> e
   -> f
   -> g
   -> h
   -> i
   -> j
   -> k
   -> l
   -> (a, b, c, d, e, f, g, h, i, j, k, l))
-> RowDecoder c
-> RowDecoder
     (d
      -> e
      -> f
      -> g
      -> h
      -> i
      -> j
      -> k
      -> l
      -> (a, b, c, d, e, f, g, h, i, j, k, l))
forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldDecoder c -> RowDecoder c
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder c
forall a. FromPgField a => FieldDecoder a
fieldDecoder RowDecoder
  (d
   -> e
   -> f
   -> g
   -> h
   -> i
   -> j
   -> k
   -> l
   -> (a, b, c, d, e, f, g, h, i, j, k, l))
-> RowDecoder d
-> RowDecoder
     (e
      -> f
      -> g
      -> h
      -> i
      -> j
      -> k
      -> l
      -> (a, b, c, d, e, f, g, h, i, j, k, l))
forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldDecoder d -> RowDecoder d
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder d
forall a. FromPgField a => FieldDecoder a
fieldDecoder RowDecoder
  (e
   -> f
   -> g
   -> h
   -> i
   -> j
   -> k
   -> l
   -> (a, b, c, d, e, f, g, h, i, j, k, l))
-> RowDecoder e
-> RowDecoder
     (f
      -> g
      -> h
      -> i
      -> j
      -> k
      -> l
      -> (a, b, c, d, e, f, g, h, i, j, k, l))
forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldDecoder e -> RowDecoder e
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder e
forall a. FromPgField a => FieldDecoder a
fieldDecoder RowDecoder
  (f
   -> g
   -> h
   -> i
   -> j
   -> k
   -> l
   -> (a, b, c, d, e, f, g, h, i, j, k, l))
-> RowDecoder f
-> RowDecoder
     (g
      -> h -> i -> j -> k -> l -> (a, b, c, d, e, f, g, h, i, j, k, l))
forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldDecoder f -> RowDecoder f
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder f
forall a. FromPgField a => FieldDecoder a
fieldDecoder RowDecoder
  (g
   -> h -> i -> j -> k -> l -> (a, b, c, d, e, f, g, h, i, j, k, l))
-> RowDecoder g
-> RowDecoder
     (h -> i -> j -> k -> l -> (a, b, c, d, e, f, g, h, i, j, k, l))
forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldDecoder g -> RowDecoder g
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder g
forall a. FromPgField a => FieldDecoder a
fieldDecoder RowDecoder
  (h -> i -> j -> k -> l -> (a, b, c, d, e, f, g, h, i, j, k, l))
-> RowDecoder h
-> RowDecoder
     (i -> j -> k -> l -> (a, b, c, d, e, f, g, h, i, j, k, l))
forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldDecoder h -> RowDecoder h
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder h
forall a. FromPgField a => FieldDecoder a
fieldDecoder RowDecoder
  (i -> j -> k -> l -> (a, b, c, d, e, f, g, h, i, j, k, l))
-> RowDecoder i
-> RowDecoder (j -> k -> l -> (a, b, c, d, e, f, g, h, i, j, k, l))
forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldDecoder i -> RowDecoder i
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder i
forall a. FromPgField a => FieldDecoder a
fieldDecoder RowDecoder (j -> k -> l -> (a, b, c, d, e, f, g, h, i, j, k, l))
-> RowDecoder j
-> RowDecoder (k -> l -> (a, b, c, d, e, f, g, h, i, j, k, l))
forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldDecoder j -> RowDecoder j
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder j
forall a. FromPgField a => FieldDecoder a
fieldDecoder RowDecoder (k -> l -> (a, b, c, d, e, f, g, h, i, j, k, l))
-> RowDecoder k
-> RowDecoder (l -> (a, b, c, d, e, f, g, h, i, j, k, l))
forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldDecoder k -> RowDecoder k
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder k
forall a. FromPgField a => FieldDecoder a
fieldDecoder RowDecoder (l -> (a, b, c, d, e, f, g, h, i, j, k, l))
-> RowDecoder l -> RowDecoder (a, b, c, d, e, f, g, h, i, j, k, l)
forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldDecoder l -> RowDecoder l
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder l
forall a. FromPgField a => FieldDecoder a
fieldDecoder

instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e, FromPgField f, FromPgField g, FromPgField h, FromPgField i, FromPgField j, FromPgField k, FromPgField l, FromPgField m) => FromPgRow (a, b, c, d, e, f, g, h, i, j, k, l, m) where
  rowDecoder :: RowDecoder (a, b, c, d, e, f, g, h, i, j, k, l, m)
rowDecoder = (,,,,,,,,,,,,) (a
 -> b
 -> c
 -> d
 -> e
 -> f
 -> g
 -> h
 -> i
 -> j
 -> k
 -> l
 -> m
 -> (a, b, c, d, e, f, g, h, i, j, k, l, m))
-> RowDecoder a
-> RowDecoder
     (b
      -> c
      -> d
      -> e
      -> f
      -> g
      -> h
      -> i
      -> j
      -> k
      -> l
      -> m
      -> (a, b, c, d, e, f, g, h, i, j, k, l, m))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FieldDecoder a -> RowDecoder a
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder a
forall a. FromPgField a => FieldDecoder a
fieldDecoder RowDecoder
  (b
   -> c
   -> d
   -> e
   -> f
   -> g
   -> h
   -> i
   -> j
   -> k
   -> l
   -> m
   -> (a, b, c, d, e, f, g, h, i, j, k, l, m))
-> RowDecoder b
-> RowDecoder
     (c
      -> d
      -> e
      -> f
      -> g
      -> h
      -> i
      -> j
      -> k
      -> l
      -> m
      -> (a, b, c, d, e, f, g, h, i, j, k, l, m))
forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldDecoder b -> RowDecoder b
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder b
forall a. FromPgField a => FieldDecoder a
fieldDecoder RowDecoder
  (c
   -> d
   -> e
   -> f
   -> g
   -> h
   -> i
   -> j
   -> k
   -> l
   -> m
   -> (a, b, c, d, e, f, g, h, i, j, k, l, m))
-> RowDecoder c
-> RowDecoder
     (d
      -> e
      -> f
      -> g
      -> h
      -> i
      -> j
      -> k
      -> l
      -> m
      -> (a, b, c, d, e, f, g, h, i, j, k, l, m))
forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldDecoder c -> RowDecoder c
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder c
forall a. FromPgField a => FieldDecoder a
fieldDecoder RowDecoder
  (d
   -> e
   -> f
   -> g
   -> h
   -> i
   -> j
   -> k
   -> l
   -> m
   -> (a, b, c, d, e, f, g, h, i, j, k, l, m))
-> RowDecoder d
-> RowDecoder
     (e
      -> f
      -> g
      -> h
      -> i
      -> j
      -> k
      -> l
      -> m
      -> (a, b, c, d, e, f, g, h, i, j, k, l, m))
forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldDecoder d -> RowDecoder d
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder d
forall a. FromPgField a => FieldDecoder a
fieldDecoder RowDecoder
  (e
   -> f
   -> g
   -> h
   -> i
   -> j
   -> k
   -> l
   -> m
   -> (a, b, c, d, e, f, g, h, i, j, k, l, m))
-> RowDecoder e
-> RowDecoder
     (f
      -> g
      -> h
      -> i
      -> j
      -> k
      -> l
      -> m
      -> (a, b, c, d, e, f, g, h, i, j, k, l, m))
forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldDecoder e -> RowDecoder e
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder e
forall a. FromPgField a => FieldDecoder a
fieldDecoder RowDecoder
  (f
   -> g
   -> h
   -> i
   -> j
   -> k
   -> l
   -> m
   -> (a, b, c, d, e, f, g, h, i, j, k, l, m))
-> RowDecoder f
-> RowDecoder
     (g
      -> h
      -> i
      -> j
      -> k
      -> l
      -> m
      -> (a, b, c, d, e, f, g, h, i, j, k, l, m))
forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldDecoder f -> RowDecoder f
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder f
forall a. FromPgField a => FieldDecoder a
fieldDecoder RowDecoder
  (g
   -> h
   -> i
   -> j
   -> k
   -> l
   -> m
   -> (a, b, c, d, e, f, g, h, i, j, k, l, m))
-> RowDecoder g
-> RowDecoder
     (h
      -> i
      -> j
      -> k
      -> l
      -> m
      -> (a, b, c, d, e, f, g, h, i, j, k, l, m))
forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldDecoder g -> RowDecoder g
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder g
forall a. FromPgField a => FieldDecoder a
fieldDecoder RowDecoder
  (h
   -> i
   -> j
   -> k
   -> l
   -> m
   -> (a, b, c, d, e, f, g, h, i, j, k, l, m))
-> RowDecoder h
-> RowDecoder
     (i -> j -> k -> l -> m -> (a, b, c, d, e, f, g, h, i, j, k, l, m))
forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldDecoder h -> RowDecoder h
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder h
forall a. FromPgField a => FieldDecoder a
fieldDecoder RowDecoder
  (i -> j -> k -> l -> m -> (a, b, c, d, e, f, g, h, i, j, k, l, m))
-> RowDecoder i
-> RowDecoder
     (j -> k -> l -> m -> (a, b, c, d, e, f, g, h, i, j, k, l, m))
forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldDecoder i -> RowDecoder i
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder i
forall a. FromPgField a => FieldDecoder a
fieldDecoder RowDecoder
  (j -> k -> l -> m -> (a, b, c, d, e, f, g, h, i, j, k, l, m))
-> RowDecoder j
-> RowDecoder
     (k -> l -> m -> (a, b, c, d, e, f, g, h, i, j, k, l, m))
forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldDecoder j -> RowDecoder j
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder j
forall a. FromPgField a => FieldDecoder a
fieldDecoder RowDecoder (k -> l -> m -> (a, b, c, d, e, f, g, h, i, j, k, l, m))
-> RowDecoder k
-> RowDecoder (l -> m -> (a, b, c, d, e, f, g, h, i, j, k, l, m))
forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldDecoder k -> RowDecoder k
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder k
forall a. FromPgField a => FieldDecoder a
fieldDecoder RowDecoder (l -> m -> (a, b, c, d, e, f, g, h, i, j, k, l, m))
-> RowDecoder l
-> RowDecoder (m -> (a, b, c, d, e, f, g, h, i, j, k, l, m))
forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldDecoder l -> RowDecoder l
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder l
forall a. FromPgField a => FieldDecoder a
fieldDecoder RowDecoder (m -> (a, b, c, d, e, f, g, h, i, j, k, l, m))
-> RowDecoder m
-> RowDecoder (a, b, c, d, e, f, g, h, i, j, k, l, m)
forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldDecoder m -> RowDecoder m
forall a. FieldDecoder a -> RowDecoder a
singleField FieldDecoder m
forall a. FromPgField a => FieldDecoder a
fieldDecoder

data FieldEncoder a = FieldEncoder
  { forall a. FieldEncoder a -> EncodingContext -> Maybe Oid
toTypeOid :: !(EncodingContext -> Maybe Oid),
    forall a. FieldEncoder a -> EncodingContext -> a -> BinaryField
toPgField :: !(EncodingContext -> a -> BinaryField)
  }

instance Contravariant FieldEncoder where
  contramap :: forall a' a. (a' -> a) -> FieldEncoder a -> FieldEncoder a'
contramap a' -> a
f FieldEncoder a
fEnc = FieldEncoder {toTypeOid :: EncodingContext -> Maybe Oid
toTypeOid = FieldEncoder a
fEnc.toTypeOid, toPgField :: EncodingContext -> a' -> BinaryField
toPgField = \EncodingContext
encCtx -> let toF :: a -> BinaryField
toF = FieldEncoder a
fEnc.toPgField EncodingContext
encCtx in \a'
v -> a -> BinaryField
toF (a' -> a
f a'
v)}

class ToPgField a where
  fieldEncoder :: FieldEncoder a

-- | Allows you to specify a type for a FieldEncoder. This can be useful to avoid
-- letting postgres infer types itself, which can cause errors. For example:
--
-- > data MyEnum = Val1 | Val2 | Val3
-- > myEnumFieldDecoderWithTypeInfoCheck :: FieldEncoder MyEnum
-- > myEnumFieldDecoderWithTypeInfoCheck =
-- >   let convert = \case
-- >         Val1 -> "val1" :: Text
-- >         Val2 -> "val2"
-- >         Val3 -> "val3"
-- >    in typeFieldEncoder
-- >         (typeOidWithName "my_enum")
-- >         $ contramap convert fieldEncoder
--
-- This will work unless you use non-default flags in your connection options.
typeFieldEncoder :: (EncodingContext -> Maybe Oid) -> FieldEncoder a -> FieldEncoder a
typeFieldEncoder :: forall a.
(EncodingContext -> Maybe Oid) -> FieldEncoder a -> FieldEncoder a
typeFieldEncoder EncodingContext -> Maybe Oid
ttoid FieldEncoder a
enc = FieldEncoder a
enc {toTypeOid = ttoid}

typeOidWithName :: Text -> (EncodingContext -> Maybe Oid)
typeOidWithName :: Text -> EncodingContext -> Maybe Oid
typeOidWithName Text
typName = \EncodingContext
encCtx -> TypeInfo -> Oid
typeOid (TypeInfo -> Oid) -> Maybe TypeInfo -> Maybe Oid
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> TypeInfoCache -> Maybe TypeInfo
lookupTypeByName Text
typName EncodingContext
encCtx.typeInfoCache

instance ToPgField Int where
  fieldEncoder :: FieldEncoder Int
fieldEncoder =
    FieldEncoder
      { toTypeOid :: EncodingContext -> Maybe Oid
toTypeOid = \EncodingContext
_ -> Oid -> Maybe Oid
forall a. a -> Maybe a
Just Oid
haskellIntOid,
        toPgField :: EncodingContext -> Int -> BinaryField
toPgField = \EncodingContext
_ -> Int -> BinaryField
binaryIntEncoder
      }

instance ToPgField Int16 where
  fieldEncoder :: FieldEncoder Int16
fieldEncoder =
    FieldEncoder
      { toTypeOid :: EncodingContext -> Maybe Oid
toTypeOid = \EncodingContext
_ -> Oid -> Maybe Oid
forall a. a -> Maybe a
Just Oid
int2Oid,
        toPgField :: EncodingContext -> Int16 -> BinaryField
toPgField = \EncodingContext
_ -> \Int16
n -> ByteString -> BinaryField
NotNull (ByteString -> BinaryField) -> ByteString -> BinaryField
forall a b. (a -> b) -> a -> b
$ Int16 -> ByteString
forall a. Serialize a => a -> ByteString
Cereal.encode Int16
n
      }

instance ToPgField Int32 where
  fieldEncoder :: FieldEncoder Int32
fieldEncoder =
    FieldEncoder
      { toTypeOid :: EncodingContext -> Maybe Oid
toTypeOid = \EncodingContext
_ -> Oid -> Maybe Oid
forall a. a -> Maybe a
Just Oid
int4Oid,
        toPgField :: EncodingContext -> Int32 -> BinaryField
toPgField = \EncodingContext
_ -> \Int32
n -> ByteString -> BinaryField
NotNull (ByteString -> BinaryField) -> ByteString -> BinaryField
forall a b. (a -> b) -> a -> b
$ Int32 -> ByteString
forall a. Serialize a => a -> ByteString
Cereal.encode Int32
n
      }

instance ToPgField Int64 where
  fieldEncoder :: FieldEncoder Int64
fieldEncoder =
    FieldEncoder
      { toTypeOid :: EncodingContext -> Maybe Oid
toTypeOid = \EncodingContext
_ -> Oid -> Maybe Oid
forall a. a -> Maybe a
Just Oid
int8Oid,
        toPgField :: EncodingContext -> Int64 -> BinaryField
toPgField = \EncodingContext
_ -> \Int64
n -> ByteString -> BinaryField
NotNull (ByteString -> BinaryField) -> ByteString -> BinaryField
forall a b. (a -> b) -> a -> b
$ Int64 -> ByteString
forall a. Serialize a => a -> ByteString
Cereal.encode Int64
n
      }

instance ToPgField Integer where
  fieldEncoder :: FieldEncoder Integer
fieldEncoder =
    let fe :: FieldEncoder Scientific
fe = forall a. ToPgField a => FieldEncoder a
fieldEncoder @Scientific
     in FieldEncoder
          { toTypeOid :: EncodingContext -> Maybe Oid
toTypeOid = \EncodingContext
_ -> Oid -> Maybe Oid
forall a. a -> Maybe a
Just Oid
numericOid,
            toPgField :: EncodingContext -> Integer -> BinaryField
toPgField = \EncodingContext
encCtx -> \Integer
n -> FieldEncoder Scientific
fe.toPgField EncodingContext
encCtx (Integer -> Scientific
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
n)
          }

instance ToPgField (Ratio Integer) where
  fieldEncoder :: FieldEncoder (Ratio Integer)
fieldEncoder =
    let fe :: FieldEncoder Scientific
fe = forall a. ToPgField a => FieldEncoder a
fieldEncoder @Scientific
     in FieldEncoder
          { toTypeOid :: EncodingContext -> Maybe Oid
toTypeOid = \EncodingContext
_ -> Oid -> Maybe Oid
forall a. a -> Maybe a
Just Oid
numericOid,
            toPgField :: EncodingContext -> Ratio Integer -> BinaryField
toPgField = \EncodingContext
encCtx -> \Ratio Integer
r -> FieldEncoder Scientific
fe.toPgField EncodingContext
encCtx (Ratio Integer -> Scientific
forall a. Fractional a => Ratio Integer -> a
fromRational Ratio Integer
r)
          }

instance ToPgField Oid where
  fieldEncoder :: FieldEncoder Oid
fieldEncoder =
    FieldEncoder
      { toTypeOid :: EncodingContext -> Maybe Oid
toTypeOid = \EncodingContext
_ -> Oid -> Maybe Oid
forall a. a -> Maybe a
Just Oid
oidOid,
        toPgField :: EncodingContext -> Oid -> BinaryField
toPgField = \EncodingContext
_ -> \Oid
n -> ByteString -> BinaryField
NotNull (ByteString -> BinaryField) -> ByteString -> BinaryField
forall a b. (a -> b) -> a -> b
$ forall a. Serialize a => a -> ByteString
Cereal.encode @Int32 (Int32 -> ByteString) -> Int32 -> ByteString
forall a b. (a -> b) -> a -> b
$ Oid -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Oid
n
      }

instance ToPgField Scientific where
  fieldEncoder :: FieldEncoder Scientific
fieldEncoder =
    FieldEncoder
      { toTypeOid :: EncodingContext -> Maybe Oid
toTypeOid = \EncodingContext
_ -> Oid -> Maybe Oid
forall a. a -> Maybe a
Just Oid
numericOid,
        toPgField :: EncodingContext -> Scientific -> BinaryField
toPgField = \EncodingContext
_ -> \Scientific
n ->
          let sign :: ByteString
sign = forall a. Serialize a => a -> ByteString
Cereal.encode @Int16 (Int16 -> ByteString) -> Int16 -> ByteString
forall a b. (a -> b) -> a -> b
$ if Scientific
n Scientific -> Scientific -> Bool
forall a. Ord a => a -> a -> Bool
>= Scientific
0 then Int16
0 else Int16
0x4000
              -- The number is coeff * 10^exp, but we want it in base-10000 so we convert it to
              -- new_coeff * 10^new_exp with new_exp a multiple of 4
              base10000Expon :: Int
base10000Expon = Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Scientific -> Int
base10Exponent Scientific
n Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
4)
              base10000Coeff :: Integer
base10000Coeff = Scientific -> Integer
coefficient Scientific
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer -> Int -> Integer
expt Integer
10 (Scientific -> Int
base10Exponent Scientific
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
base10000Expon)
              ndigits, weight :: Int16
              digits :: ByteString
              (Int16
ndigits, Int16
weight, ByteString
digits) = Int16
-> Int16 -> Integer -> ByteString -> (Int16, Int16, ByteString)
calculateDigits Int16
0 Int16
0 (Integer -> Integer
forall a. Num a => a -> a
abs Integer
base10000Coeff) ByteString
""
              dscale :: ByteString
dscale = forall a. Serialize a => a -> ByteString
Cereal.encode @Int16 (Int16 -> Int16
forall a. Num a => a -> a
abs (Int16 -> Int16) -> Int16 -> Int16
forall a b. (a -> b) -> a -> b
$ Int -> Int16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
base10000Expon) -- More than necessary, but safe?
           in ByteString -> BinaryField
NotNull (ByteString -> BinaryField) -> ByteString -> BinaryField
forall a b. (a -> b) -> a -> b
$ Int16 -> ByteString
forall a. Serialize a => a -> ByteString
Cereal.encode Int16
ndigits ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Int16 -> ByteString
forall a. Serialize a => a -> ByteString
Cereal.encode (Int16
weight Int16 -> Int16 -> Int16
forall a. Num a => a -> a -> a
- Int16
1 Int16 -> Int16 -> Int16
forall a. Num a => a -> a -> a
+ Int -> Int16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
base10000Expon Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
4)) ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
sign ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
dscale ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
digits
      }
    where
      calculateDigits :: Int16 -> Int16 -> Integer -> BS.ByteString -> (Int16, Int16, BS.ByteString)
      calculateDigits :: Int16
-> Int16 -> Integer -> ByteString -> (Int16, Int16, ByteString)
calculateDigits !Int16
ndigitsSoFar !Int16
weightSoFar Integer
0 !ByteString
encodedDigits = (Int16
ndigitsSoFar, Int16
weightSoFar, ByteString
encodedDigits)
      calculateDigits !Int16
ndigitsSoFar !Int16
weightSoFar !Integer
val !ByteString
encodedDigits =
        let (Integer
quotient, Integer -> Int16
forall a b. (Integral a, Num b) => a -> b
fromIntegral -> Int16
rest :: Int16) = Integer
val Integer -> Integer -> (Integer, Integer)
forall a. Integral a => a -> a -> (a, a)
`divMod` Integer
10000
         in Int16
-> Int16 -> Integer -> ByteString -> (Int16, Int16, ByteString)
calculateDigits
              (Int16
ndigitsSoFar Int16 -> Int16 -> Int16
forall a. Num a => a -> a -> a
+ Int16
1)
              (Int16
weightSoFar Int16 -> Int16 -> Int16
forall a. Num a => a -> a -> a
+ Int16
1)
              Integer
quotient
              (forall a. Serialize a => a -> ByteString
Cereal.encode @Int16 Int16
rest ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
encodedDigits)

instance ToPgField Float where
  fieldEncoder :: FieldEncoder Float
fieldEncoder =
    FieldEncoder
      { toTypeOid :: EncodingContext -> Maybe Oid
toTypeOid = \EncodingContext
_ -> Oid -> Maybe Oid
forall a. a -> Maybe a
Just Oid
float4Oid,
        toPgField :: EncodingContext -> Float -> BinaryField
toPgField = \EncodingContext
_ -> \Float
n -> ByteString -> BinaryField
NotNull (ByteString -> BinaryField) -> ByteString -> BinaryField
forall a b. (a -> b) -> a -> b
$ forall a. Serialize a => a -> ByteString
Cereal.encode @Word32 (Word32 -> ByteString) -> Word32 -> ByteString
forall a b. (a -> b) -> a -> b
$ Float -> Word32
castFloatToWord32 Float
n
      }

instance ToPgField Double where
  fieldEncoder :: FieldEncoder Double
fieldEncoder =
    FieldEncoder
      { toTypeOid :: EncodingContext -> Maybe Oid
toTypeOid = \EncodingContext
_ -> Oid -> Maybe Oid
forall a. a -> Maybe a
Just Oid
float8Oid,
        toPgField :: EncodingContext -> Double -> BinaryField
toPgField = \EncodingContext
_ -> \Double
n -> ByteString -> BinaryField
NotNull (ByteString -> BinaryField) -> ByteString -> BinaryField
forall a b. (a -> b) -> a -> b
$ forall a. Serialize a => a -> ByteString
Cereal.encode @Word64 (Word64 -> ByteString) -> Word64 -> ByteString
forall a b. (a -> b) -> a -> b
$ Double -> Word64
castDoubleToWord64 Double
n
      }

instance ToPgField Bool where
  -- TODO: Cereal.encode seems to work, but reference the documentation that shows how bools are encoded
  fieldEncoder :: FieldEncoder Bool
fieldEncoder =
    FieldEncoder
      { toTypeOid :: EncodingContext -> Maybe Oid
toTypeOid = \EncodingContext
_ -> Oid -> Maybe Oid
forall a. a -> Maybe a
Just Oid
boolOid,
        toPgField :: EncodingContext -> Bool -> BinaryField
toPgField = \EncodingContext
_ Bool
n -> ByteString -> BinaryField
NotNull (ByteString -> BinaryField) -> ByteString -> BinaryField
forall a b. (a -> b) -> a -> b
$ forall a. Serialize a => a -> ByteString
Cereal.encode @Bool (Bool -> ByteString) -> Bool -> ByteString
forall a b. (a -> b) -> a -> b
$ Bool
n
      }

instance ToPgField Day where
  -- PG Dates are Int32 number of days relative to 2000-01-01
  -- https://github.com/postgres/postgres/blob/master/src/include/datatype/timestamp.h#L235
  fieldEncoder :: FieldEncoder Day
fieldEncoder =
    FieldEncoder
      { toTypeOid :: EncodingContext -> Maybe Oid
toTypeOid = \EncodingContext
_ -> Oid -> Maybe Oid
forall a. a -> Maybe a
Just Oid
dateOid,
        -- TODO: Catch integer overflow and do what?
        toPgField :: EncodingContext -> Day -> BinaryField
toPgField = \EncodingContext
_ Day
d -> ByteString -> BinaryField
NotNull (ByteString -> BinaryField) -> ByteString -> BinaryField
forall a b. (a -> b) -> a -> b
$ forall a. Serialize a => a -> ByteString
Cereal.encode @Int32 (Int32 -> ByteString) -> Int32 -> ByteString
forall a b. (a -> b) -> a -> b
$ Integer -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Int32) -> Integer -> Int32
forall a b. (a -> b) -> a -> b
$ Day -> Day -> Integer
diffDays Day
d (Integer -> Int -> Int -> Day
fromGregorian Integer
2000 Int
1 Int
1)
      }

instance ToPgField (Unbounded Day) where
  fieldEncoder :: FieldEncoder (Unbounded Day)
fieldEncoder =
    let fe :: FieldEncoder Day
fe = forall a. ToPgField a => FieldEncoder a
fieldEncoder @Day
     in FieldEncoder
          { toTypeOid :: EncodingContext -> Maybe Oid
toTypeOid = FieldEncoder Day
fe.toTypeOid,
            toPgField :: EncodingContext -> Unbounded Day -> BinaryField
toPgField = \EncodingContext
encCtx -> \case
              Unbounded Day
NegInfinity -> ByteString -> BinaryField
NotNull (ByteString -> BinaryField) -> ByteString -> BinaryField
forall a b. (a -> b) -> a -> b
$ forall a. Serialize a => a -> ByteString
Cereal.encode @Int32 Int32
forall a. Bounded a => a
minBound
              Finite Day
v -> FieldEncoder Day
fe.toPgField EncodingContext
encCtx Day
v
              Unbounded Day
PosInfinity -> ByteString -> BinaryField
NotNull (ByteString -> BinaryField) -> ByteString -> BinaryField
forall a b. (a -> b) -> a -> b
$ forall a. Serialize a => a -> ByteString
Cereal.encode @Int32 Int32
forall a. Bounded a => a
maxBound
          }

instance ToPgField CalendarDiffTime where
  fieldEncoder :: FieldEncoder CalendarDiffTime
fieldEncoder =
    FieldEncoder
      { toTypeOid :: EncodingContext -> Maybe Oid
toTypeOid = \EncodingContext
_ -> Oid -> Maybe Oid
forall a. a -> Maybe a
Just Oid
intervalOid,
        toPgField :: EncodingContext -> CalendarDiffTime -> BinaryField
toPgField = \EncodingContext
_ CalendarDiffTime {Integer
NominalDiffTime
ctMonths :: Integer
ctTime :: NominalDiffTime
ctTime :: CalendarDiffTime -> NominalDiffTime
ctMonths :: CalendarDiffTime -> Integer
..} ->
          let (Int32
days :: Int32, NominalDiffTime
timeUnderOneDay) = NominalDiffTime
ctTime NominalDiffTime -> NominalDiffTime -> (Int32, NominalDiffTime)
forall a b. (Real a, Integral b) => a -> a -> (b, a)
`divMod'` NominalDiffTime
86_400
           in ByteString -> BinaryField
NotNull (ByteString -> BinaryField) -> ByteString -> BinaryField
forall a b. (a -> b) -> a -> b
$ forall a. Serialize a => a -> ByteString
Cereal.encode @(Int64, Int32, Int32) (NominalDiffTime -> Int64
forall b. Integral b => NominalDiffTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (NominalDiffTime -> Int64) -> NominalDiffTime -> Int64
forall a b. (a -> b) -> a -> b
$ NominalDiffTime
timeUnderOneDay NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
1_000_000, Int32
days, Integer -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
ctMonths)
      }

instance ToPgField NominalDiffTime where
  fieldEncoder :: FieldEncoder NominalDiffTime
fieldEncoder =
    FieldEncoder
      { toTypeOid :: EncodingContext -> Maybe Oid
toTypeOid = \EncodingContext
_ -> Oid -> Maybe Oid
forall a. a -> Maybe a
Just Oid
intervalOid,
        toPgField :: EncodingContext -> NominalDiffTime -> BinaryField
toPgField = \EncodingContext
_ NominalDiffTime
ndt ->
          ByteString -> BinaryField
NotNull (ByteString -> BinaryField) -> ByteString -> BinaryField
forall a b. (a -> b) -> a -> b
$ forall a. Serialize a => a -> ByteString
Cereal.encode @(Int64, Int32, Int32) (NominalDiffTime -> Int64
forall b. Integral b => NominalDiffTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (NominalDiffTime -> Int64) -> NominalDiffTime -> Int64
forall a b. (a -> b) -> a -> b
$ NominalDiffTime
ndt NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
1_000_000, Int32
0, Int32
0)
      }

instance ToPgField UTCTime where
  fieldEncoder :: FieldEncoder UTCTime
fieldEncoder =
    FieldEncoder
      { toTypeOid :: EncodingContext -> Maybe Oid
toTypeOid = \EncodingContext
_ -> Oid -> Maybe Oid
forall a. a -> Maybe a
Just Oid
timestamptzOid,
        -- TODO: Catch integer overflow and do what?
        toPgField :: EncodingContext -> UTCTime -> BinaryField
toPgField = \EncodingContext
_ (UTCTime Day
parsedDate DiffTime
timeinday) ->
          let Int64
day :: Int64 = Integer -> Int64
forall a. Num a => Integer -> a
fromInteger (Integer -> Int64) -> Integer -> Int64
forall a b. (a -> b) -> a -> b
$ Day
parsedDate Day -> Day -> Integer
`diffDays` Integer -> Int -> Int -> Day
fromJulian Integer
1999 Int
12 Int
19
              Int64
totalusecs :: Int64 = Int64
86_400_000_000 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
* Int64
day Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Integer -> Int64
forall a. Num a => Integer -> a
fromInteger (DiffTime -> Integer
diffTimeToPicoseconds DiffTime
timeinday Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
1_000_000)
           in ByteString -> BinaryField
NotNull (ByteString -> BinaryField) -> ByteString -> BinaryField
forall a b. (a -> b) -> a -> b
$ forall a. Serialize a => a -> ByteString
Cereal.encode @Int64 Int64
totalusecs
      }

instance ToPgField (Unbounded UTCTime) where
  fieldEncoder :: FieldEncoder (Unbounded UTCTime)
fieldEncoder =
    let fe :: FieldEncoder UTCTime
fe = forall a. ToPgField a => FieldEncoder a
fieldEncoder @UTCTime
     in FieldEncoder
          { toTypeOid :: EncodingContext -> Maybe Oid
toTypeOid = FieldEncoder UTCTime
fe.toTypeOid,
            toPgField :: EncodingContext -> Unbounded UTCTime -> BinaryField
toPgField = \EncodingContext
encCtx -> \case
              Unbounded UTCTime
NegInfinity -> ByteString -> BinaryField
NotNull (ByteString -> BinaryField) -> ByteString -> BinaryField
forall a b. (a -> b) -> a -> b
$ forall a. Serialize a => a -> ByteString
Cereal.encode @Int64 Int64
forall a. Bounded a => a
minBound
              Finite UTCTime
v -> FieldEncoder UTCTime
fe.toPgField EncodingContext
encCtx UTCTime
v
              Unbounded UTCTime
PosInfinity -> ByteString -> BinaryField
NotNull (ByteString -> BinaryField) -> ByteString -> BinaryField
forall a b. (a -> b) -> a -> b
$ forall a. Serialize a => a -> ByteString
Cereal.encode @Int64 Int64
forall a. Bounded a => a
maxBound
          }

instance ToPgField ZonedTime where
  fieldEncoder :: FieldEncoder ZonedTime
fieldEncoder =
    let fe :: FieldEncoder UTCTime
fe = forall a. ToPgField a => FieldEncoder a
fieldEncoder @UTCTime
     in FieldEncoder
          { toTypeOid :: EncodingContext -> Maybe Oid
toTypeOid = \EncodingContext
_ -> Oid -> Maybe Oid
forall a. a -> Maybe a
Just Oid
timestamptzOid,
            toPgField :: EncodingContext -> ZonedTime -> BinaryField
toPgField = \EncodingContext
encCtx -> FieldEncoder UTCTime
fe.toPgField EncodingContext
encCtx (UTCTime -> BinaryField)
-> (ZonedTime -> UTCTime) -> ZonedTime -> BinaryField
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ZonedTime -> UTCTime
zonedTimeToUTC
          }

instance ToPgField (Unbounded ZonedTime) where
  fieldEncoder :: FieldEncoder (Unbounded ZonedTime)
fieldEncoder =
    let fe :: FieldEncoder ZonedTime
fe = forall a. ToPgField a => FieldEncoder a
fieldEncoder @ZonedTime
     in FieldEncoder
          { toTypeOid :: EncodingContext -> Maybe Oid
toTypeOid = FieldEncoder ZonedTime
fe.toTypeOid,
            toPgField :: EncodingContext -> Unbounded ZonedTime -> BinaryField
toPgField = \EncodingContext
encCtx -> \case
              Unbounded ZonedTime
NegInfinity -> ByteString -> BinaryField
NotNull (ByteString -> BinaryField) -> ByteString -> BinaryField
forall a b. (a -> b) -> a -> b
$ forall a. Serialize a => a -> ByteString
Cereal.encode @Int64 Int64
forall a. Bounded a => a
minBound
              Finite ZonedTime
v -> FieldEncoder ZonedTime
fe.toPgField EncodingContext
encCtx ZonedTime
v
              Unbounded ZonedTime
PosInfinity -> ByteString -> BinaryField
NotNull (ByteString -> BinaryField) -> ByteString -> BinaryField
forall a b. (a -> b) -> a -> b
$ forall a. Serialize a => a -> ByteString
Cereal.encode @Int64 Int64
forall a. Bounded a => a
maxBound
          }

instance ToPgField LocalTime where
  fieldEncoder :: FieldEncoder LocalTime
fieldEncoder =
    FieldEncoder
      { toTypeOid :: EncodingContext -> Maybe Oid
toTypeOid = \EncodingContext
_ -> Oid -> Maybe Oid
forall a. a -> Maybe a
Just Oid
timestampOid,
        toPgField :: EncodingContext -> LocalTime -> BinaryField
toPgField = \EncodingContext
_ (LocalTime Day
localDay TimeOfDay
localTimeOfDay) ->
          let Int64
day :: Int64 = Integer -> Int64
forall a. Num a => Integer -> a
fromInteger (Integer -> Int64) -> Integer -> Int64
forall a b. (a -> b) -> a -> b
$ Day
localDay Day -> Day -> Integer
`diffDays` Integer -> Int -> Int -> Day
fromJulian Integer
1999 Int
12 Int
19
              Int64
totalusecs :: Int64 = Int64
86_400_000_000 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
* Int64
day Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Integer -> Int64
forall a. Num a => Integer -> a
fromInteger (DiffTime -> Integer
diffTimeToPicoseconds (TimeOfDay -> DiffTime
timeOfDayToTime TimeOfDay
localTimeOfDay) Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
1_000_000)
           in ByteString -> BinaryField
NotNull (ByteString -> BinaryField) -> ByteString -> BinaryField
forall a b. (a -> b) -> a -> b
$ forall a. Serialize a => a -> ByteString
Cereal.encode @Int64 Int64
totalusecs
      }

instance ToPgField TimeOfDay where
  fieldEncoder :: FieldEncoder TimeOfDay
fieldEncoder =
    FieldEncoder
      { toTypeOid :: EncodingContext -> Maybe Oid
toTypeOid = \EncodingContext
_ -> Oid -> Maybe Oid
forall a. a -> Maybe a
Just Oid
timeOid,
        toPgField :: EncodingContext -> TimeOfDay -> BinaryField
toPgField = \EncodingContext
_ TimeOfDay
tod ->
          let Int64
usecs :: Int64 = Integer -> Int64
forall a. Num a => Integer -> a
fromInteger (Integer -> Int64) -> Integer -> Int64
forall a b. (a -> b) -> a -> b
$ DiffTime -> Integer
diffTimeToPicoseconds (TimeOfDay -> DiffTime
timeOfDayToTime TimeOfDay
tod) Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
1_000_000
           in ByteString -> BinaryField
NotNull (ByteString -> BinaryField) -> ByteString -> BinaryField
forall a b. (a -> b) -> a -> b
$ forall a. Serialize a => a -> ByteString
Cereal.encode @Int64 Int64
usecs
      }

instance ToPgField Char where
  fieldEncoder :: FieldEncoder Char
fieldEncoder =
    let fe :: FieldEncoder Text
fe = forall a. ToPgField a => FieldEncoder a
fieldEncoder @Text
     in FieldEncoder
          { toTypeOid :: EncodingContext -> Maybe Oid
toTypeOid = \EncodingContext
_ -> Oid -> Maybe Oid
forall a. a -> Maybe a
Just Oid
textOid,
            toPgField :: EncodingContext -> Char -> BinaryField
toPgField = \EncodingContext
encCtx -> let !toTextField :: Text -> BinaryField
toTextField = FieldEncoder Text
fe.toPgField EncodingContext
encCtx in \Char
t -> Text -> BinaryField
toTextField (Text -> BinaryField) -> Text -> BinaryField
forall a b. (a -> b) -> a -> b
$ Char -> Text
Text.singleton Char
t
          }

instance ToPgField ByteString where
  fieldEncoder :: FieldEncoder ByteString
fieldEncoder =
    FieldEncoder
      { toTypeOid :: EncodingContext -> Maybe Oid
toTypeOid = \EncodingContext
_ -> Oid -> Maybe Oid
forall a. a -> Maybe a
Just Oid
byteaOid,
        toPgField :: EncodingContext -> ByteString -> BinaryField
toPgField = \EncodingContext
_ -> \ByteString
bs -> ByteString -> BinaryField
NotNull ByteString
bs
      }

instance ToPgField LBS.ByteString where
  fieldEncoder :: FieldEncoder ByteString
fieldEncoder =
    let fe :: FieldEncoder ByteString
fe = forall a. ToPgField a => FieldEncoder a
fieldEncoder @ByteString
     in FieldEncoder
          { toTypeOid :: EncodingContext -> Maybe Oid
toTypeOid = \EncodingContext
_ -> Oid -> Maybe Oid
forall a. a -> Maybe a
Just Oid
byteaOid,
            toPgField :: EncodingContext -> ByteString -> BinaryField
toPgField = \EncodingContext
encCtx -> FieldEncoder ByteString
fe.toPgField EncodingContext
encCtx (ByteString -> BinaryField)
-> (ByteString -> ByteString) -> ByteString -> BinaryField
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
LBS.toStrict
          }

instance ToPgField Text where
  fieldEncoder :: FieldEncoder Text
fieldEncoder =
    FieldEncoder
      { toTypeOid :: EncodingContext -> Maybe Oid
toTypeOid = \EncodingContext
_ -> Oid -> Maybe Oid
forall a. a -> Maybe a
Just Oid
textOid,
        toPgField :: EncodingContext -> Text -> BinaryField
toPgField = \EncodingContext
_ -> \Text
t ->
          let bs :: ByteString
bs = Text -> ByteString
encodeUtf8 Text
t
           in ByteString -> BinaryField
NotNull ByteString
bs
      }

instance ToPgField LT.Text where
  fieldEncoder :: FieldEncoder Text
fieldEncoder =
    FieldEncoder
      { toTypeOid :: EncodingContext -> Maybe Oid
toTypeOid = \EncodingContext
_ -> Oid -> Maybe Oid
forall a. a -> Maybe a
Just Oid
textOid,
        toPgField :: EncodingContext -> Text -> BinaryField
toPgField = \EncodingContext
_ -> \Text
t ->
          let bs :: ByteString
bs = ByteString -> ByteString
LBS.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
LT.encodeUtf8 Text
t
           in ByteString -> BinaryField
NotNull ByteString
bs
      }

instance ToPgField String where
  fieldEncoder :: FieldEncoder String
fieldEncoder =
    let fe :: FieldEncoder Text
fe = forall a. ToPgField a => FieldEncoder a
fieldEncoder @Text
     in FieldEncoder
          { toTypeOid :: EncodingContext -> Maybe Oid
toTypeOid = \EncodingContext
_ -> Oid -> Maybe Oid
forall a. a -> Maybe a
Just Oid
textOid,
            toPgField :: EncodingContext -> String -> BinaryField
toPgField = \EncodingContext
encCtx -> FieldEncoder Text
fe.toPgField EncodingContext
encCtx (Text -> BinaryField) -> (String -> Text) -> String -> BinaryField
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack
          }

-- From https://hackage.haskell.org/package/case-insensitive-1.2.1.0/docs/Data-CaseInsensitive.html,
-- "Note that the FoldCase instance for ByteStrings is only guaranteed to be correct for ISO-8859-1 encoded strings!".
-- So we don't have those instances.

-- | This instance does not work if you have fillTypeInfoCache disabled (that would be a non-default
-- connection option).
instance ToPgField (CI Text) where
  fieldEncoder :: FieldEncoder (CI Text)
fieldEncoder = (EncodingContext -> Maybe Oid)
-> FieldEncoder (CI Text) -> FieldEncoder (CI Text)
forall a.
(EncodingContext -> Maybe Oid) -> FieldEncoder a -> FieldEncoder a
typeFieldEncoder (Text -> EncodingContext -> Maybe Oid
typeOidWithName Text
"citext") (FieldEncoder (CI Text) -> FieldEncoder (CI Text))
-> FieldEncoder (CI Text) -> FieldEncoder (CI Text)
forall a b. (a -> b) -> a -> b
$ (CI Text -> Text) -> FieldEncoder Text -> FieldEncoder (CI Text)
forall a' a. (a' -> a) -> FieldEncoder a -> FieldEncoder a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap CI Text -> Text
forall s. CI s -> s
CI.original FieldEncoder Text
forall a. ToPgField a => FieldEncoder a
fieldEncoder

-- | This instance does not work if you have fillTypeInfoCache disabled (that would be a non-default
-- connection option).
instance ToPgField (CI LT.Text) where
  fieldEncoder :: FieldEncoder (CI Text)
fieldEncoder = (EncodingContext -> Maybe Oid)
-> FieldEncoder (CI Text) -> FieldEncoder (CI Text)
forall a.
(EncodingContext -> Maybe Oid) -> FieldEncoder a -> FieldEncoder a
typeFieldEncoder (Text -> EncodingContext -> Maybe Oid
typeOidWithName Text
"citext") (FieldEncoder (CI Text) -> FieldEncoder (CI Text))
-> FieldEncoder (CI Text) -> FieldEncoder (CI Text)
forall a b. (a -> b) -> a -> b
$ (CI Text -> Text) -> FieldEncoder Text -> FieldEncoder (CI Text)
forall a' a. (a' -> a) -> FieldEncoder a -> FieldEncoder a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap CI Text -> Text
forall s. CI s -> s
CI.original FieldEncoder Text
forall a. ToPgField a => FieldEncoder a
fieldEncoder

-- | This instance does not work if you have fillTypeInfoCache disabled (that would be a non-default
-- connection option).
instance ToPgField (CI String) where
  fieldEncoder :: FieldEncoder (CI String)
fieldEncoder = (EncodingContext -> Maybe Oid)
-> FieldEncoder (CI String) -> FieldEncoder (CI String)
forall a.
(EncodingContext -> Maybe Oid) -> FieldEncoder a -> FieldEncoder a
typeFieldEncoder (Text -> EncodingContext -> Maybe Oid
typeOidWithName Text
"citext") (FieldEncoder (CI String) -> FieldEncoder (CI String))
-> FieldEncoder (CI String) -> FieldEncoder (CI String)
forall a b. (a -> b) -> a -> b
$ (CI String -> String)
-> FieldEncoder String -> FieldEncoder (CI String)
forall a' a. (a' -> a) -> FieldEncoder a -> FieldEncoder a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap CI String -> String
forall s. CI s -> s
CI.original FieldEncoder String
forall a. ToPgField a => FieldEncoder a
fieldEncoder

instance ToPgField UUID where
  fieldEncoder :: FieldEncoder UUID
fieldEncoder =
    FieldEncoder
      { toTypeOid :: EncodingContext -> Maybe Oid
toTypeOid = \EncodingContext
_ -> Oid -> Maybe Oid
forall a. a -> Maybe a
Just Oid
uuidOid,
        toPgField :: EncodingContext -> UUID -> BinaryField
toPgField = \EncodingContext
_ -> ByteString -> BinaryField
NotNull (ByteString -> BinaryField)
-> (UUID -> ByteString) -> UUID -> BinaryField
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
LBS.toStrict (ByteString -> ByteString)
-> (UUID -> ByteString) -> UUID -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UUID -> ByteString
UUID.toByteString
      }

instance ToPgField Aeson.Value where
  fieldEncoder :: FieldEncoder Value
fieldEncoder =
    FieldEncoder
      { toTypeOid :: EncodingContext -> Maybe Oid
toTypeOid = \EncodingContext
_ -> Oid -> Maybe Oid
forall a. a -> Maybe a
Just Oid
jsonbOid,
        toPgField :: EncodingContext -> Value -> BinaryField
toPgField = \EncodingContext
_ -> \Value
v ->
          let bs :: ByteString
bs = Word8 -> ByteString -> ByteString
BS.cons Word8
1 (ByteString -> ByteString
LBS.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Value -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode Value
v)
           in ByteString -> BinaryField
NotNull ByteString
bs
      }

instance (ToPgField a) => ToPgField (Maybe a) where
  fieldEncoder :: FieldEncoder (Maybe a)
fieldEncoder =
    let fe :: FieldEncoder a
fe = forall a. ToPgField a => FieldEncoder a
fieldEncoder @a
     in FieldEncoder
          { toTypeOid :: EncodingContext -> Maybe Oid
toTypeOid = FieldEncoder a
fe.toTypeOid,
            toPgField :: EncodingContext -> Maybe a -> BinaryField
toPgField = \EncodingContext
encCtx -> \case
              Maybe a
Nothing -> BinaryField
SqlNull
              Just a
n -> FieldEncoder a
fe.toPgField EncodingContext
encCtx a
n
          }

instance (ToPgField a) => ToPgField (Vector a) where
  fieldEncoder :: FieldEncoder (Vector a)
fieldEncoder =
    let fe :: FieldEncoder a
fe = forall a. ToPgField a => FieldEncoder a
fieldEncoder @a
     in FieldEncoder
          { toTypeOid :: EncodingContext -> Maybe Oid
toTypeOid = \EncodingContext
encodingContext -> do
              -- Maybe monad
              elOid <- FieldEncoder a
fe.toTypeOid EncodingContext
encodingContext
              arrayTypInfo <- lookupTypeByOid elOid encodingContext.typeInfoCache
              arrayTypInfo.oidOfArrayType,
            toPgField :: EncodingContext -> Vector a -> BinaryField
toPgField = EncodingContext -> Vector a -> BinaryField
forall (f :: * -> *) a.
(Foldable f, ToPgField a) =>
EncodingContext -> f a -> BinaryField
toPgVectorField
          }

data RowEncoder a = RowEncoder
  { forall a.
RowEncoder a -> a -> [EncodingContext -> (Maybe Oid, BinaryField)]
toPgParams :: !(a -> [EncodingContext -> (Maybe Oid, BinaryField)]),
    forall a. RowEncoder a -> Proxy a -> [EncodingContext -> Maybe Oid]
toTypeOids :: !(Proxy a -> [EncodingContext -> Maybe Oid]),
    -- | This produces bytes for Binary COPY FROM STDIN rows, which can increase performance
    -- and reduce memory usage comparing to deriving these bytes from `toPgParams`.
    -- The produced bytes should not contain the total number of fields in the
    -- beginning.
    forall a.
RowEncoder a -> EncodingContext -> a -> LengthAwareBuilder
toBinaryCopyBytes :: !(EncodingContext -> a -> Builder.Builder)
  }

instance Contravariant RowEncoder where
  contramap :: forall a' a. (a' -> a) -> RowEncoder a -> RowEncoder a'
contramap a' -> a
f RowEncoder a
rec = (a' -> [EncodingContext -> (Maybe Oid, BinaryField)])
-> (Proxy a' -> [EncodingContext -> Maybe Oid])
-> (EncodingContext -> a' -> LengthAwareBuilder)
-> RowEncoder a'
forall a.
(a -> [EncodingContext -> (Maybe Oid, BinaryField)])
-> (Proxy a -> [EncodingContext -> Maybe Oid])
-> (EncodingContext -> a -> LengthAwareBuilder)
-> RowEncoder a
RowEncoder (\a'
v -> RowEncoder a
rec.toPgParams (a' -> a
f a'
v)) (\Proxy a'
_ -> RowEncoder a
rec.toTypeOids Proxy a
forall {k} (t :: k). Proxy t
Proxy) (\EncodingContext
encCtx -> let !toBytes :: a -> LengthAwareBuilder
toBytes = RowEncoder a
rec.toBinaryCopyBytes EncodingContext
encCtx in \a'
v -> a -> LengthAwareBuilder
toBytes (a' -> a
f a'
v))

-- | These are from `Divisible`, but we don't currently pull in the extra dependency that has that.
divide :: (a -> (b, c)) -> RowEncoder b -> RowEncoder c -> RowEncoder a
divide :: forall a b c.
(a -> (b, c)) -> RowEncoder b -> RowEncoder c -> RowEncoder a
divide a -> (b, c)
d RowEncoder b
re1 RowEncoder c
re2 =
  RowEncoder
    { toPgParams :: a -> [EncodingContext -> (Maybe Oid, BinaryField)]
toPgParams = \a
a -> let (b
b, c
c) = a -> (b, c)
d a
a in RowEncoder b
re1.toPgParams b
b [EncodingContext -> (Maybe Oid, BinaryField)]
-> [EncodingContext -> (Maybe Oid, BinaryField)]
-> [EncodingContext -> (Maybe Oid, BinaryField)]
forall a. [a] -> [a] -> [a]
++ RowEncoder c
re2.toPgParams c
c,
      toTypeOids :: Proxy a -> [EncodingContext -> Maybe Oid]
toTypeOids = \Proxy a
_ -> RowEncoder b
re1.toTypeOids Proxy b
forall {k} (t :: k). Proxy t
Proxy [EncodingContext -> Maybe Oid]
-> [EncodingContext -> Maybe Oid] -> [EncodingContext -> Maybe Oid]
forall a. [a] -> [a] -> [a]
++ RowEncoder c
re2.toTypeOids Proxy c
forall {k} (t :: k). Proxy t
Proxy,
      toBinaryCopyBytes :: EncodingContext -> a -> LengthAwareBuilder
toBinaryCopyBytes = \EncodingContext
encCtx ->
        let !toBytes1 :: b -> LengthAwareBuilder
toBytes1 = RowEncoder b
re1.toBinaryCopyBytes EncodingContext
encCtx
            !toBytes2 :: c -> LengthAwareBuilder
toBytes2 = RowEncoder c
re2.toBinaryCopyBytes EncodingContext
encCtx
         in \a
a -> let (b
b, c
c) = a -> (b, c)
d a
a in b -> LengthAwareBuilder
toBytes1 b
b LengthAwareBuilder -> LengthAwareBuilder -> LengthAwareBuilder
forall a. Semigroup a => a -> a -> a
<> c -> LengthAwareBuilder
toBytes2 c
c
    }

class ToPgRow a where
  rowEncoder :: RowEncoder a
  default rowEncoder :: (Generic a, ProductTypeEncoder (Rep a)) => RowEncoder a
  rowEncoder = RowEncoder a
forall a. (Generic a, ProductTypeEncoder (Rep a)) => RowEncoder a
genericToPgRow

instance ToPgRow () where
  rowEncoder :: RowEncoder ()
rowEncoder = (() -> [EncodingContext -> (Maybe Oid, BinaryField)])
-> (Proxy () -> [EncodingContext -> Maybe Oid])
-> (EncodingContext -> () -> LengthAwareBuilder)
-> RowEncoder ()
forall a.
(a -> [EncodingContext -> (Maybe Oid, BinaryField)])
-> (Proxy a -> [EncodingContext -> Maybe Oid])
-> (EncodingContext -> a -> LengthAwareBuilder)
-> RowEncoder a
RowEncoder (\()
_ -> []) (\Proxy ()
_ -> []) (\EncodingContext
_ -> \()
_ -> LengthAwareBuilder
forall a. Monoid a => a
mempty)

singleFieldRowEncoder :: forall a. (ToPgField a) => RowEncoder a
singleFieldRowEncoder :: forall a. ToPgField a => RowEncoder a
singleFieldRowEncoder =
  let fe :: FieldEncoder a
fe = forall a. ToPgField a => FieldEncoder a
fieldEncoder @a
   in RowEncoder
        { toPgParams :: a -> [EncodingContext -> (Maybe Oid, BinaryField)]
toPgParams = \a
a -> [\EncodingContext
encodingContext -> (FieldEncoder a
fe.toTypeOid EncodingContext
encodingContext, FieldEncoder a
fe.toPgField EncodingContext
encodingContext a
a)],
          toTypeOids :: Proxy a -> [EncodingContext -> Maybe Oid]
toTypeOids = \Proxy a
_ -> [FieldEncoder a
fe.toTypeOid],
          toBinaryCopyBytes :: EncodingContext -> a -> LengthAwareBuilder
toBinaryCopyBytes = \EncodingContext
encCtx -> let !enc :: a -> BinaryField
enc = FieldEncoder a
fe.toPgField EncodingContext
encCtx in \a
a -> BinaryField -> LengthAwareBuilder
Builder.binaryField (BinaryField -> LengthAwareBuilder)
-> BinaryField -> LengthAwareBuilder
forall a b. (a -> b) -> a -> b
$ a -> BinaryField
enc a
a
        }

instance (ToPgField a) => ToPgRow (Only a) where
  rowEncoder :: RowEncoder (Only a)
rowEncoder = (Only a -> a) -> RowEncoder a -> RowEncoder (Only a)
forall a' a. (a' -> a) -> RowEncoder a -> RowEncoder a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap Only a -> a
forall a. Only a -> a
fromOnly RowEncoder a
forall a. ToPgField a => RowEncoder a
singleFieldRowEncoder

instance (ToPgField a, ToPgField b) => ToPgRow (a, b) where
  rowEncoder :: RowEncoder (a, b)
rowEncoder = ((a, b) -> (a, b))
-> RowEncoder a -> RowEncoder b -> RowEncoder (a, b)
forall a b c.
(a -> (b, c)) -> RowEncoder b -> RowEncoder c -> RowEncoder a
divide (a, b) -> (a, b)
forall a. a -> a
id RowEncoder a
forall a. ToPgField a => RowEncoder a
singleFieldRowEncoder RowEncoder b
forall a. ToPgField a => RowEncoder a
singleFieldRowEncoder

instance (ToPgField a, ToPgField b, ToPgField c) => ToPgRow (a, b, c) where
  rowEncoder :: RowEncoder (a, b, c)
rowEncoder = ((a, b, c) -> ((a, b), c))
-> RowEncoder (a, b) -> RowEncoder c -> RowEncoder (a, b, c)
forall a b c.
(a -> (b, c)) -> RowEncoder b -> RowEncoder c -> RowEncoder a
divide (\(a
a, b
b, c
c) -> ((a
a, b
b), c
c)) RowEncoder (a, b)
forall a. ToPgRow a => RowEncoder a
rowEncoder RowEncoder c
forall a. ToPgField a => RowEncoder a
singleFieldRowEncoder

instance (ToPgField a, ToPgField b, ToPgField c, ToPgField d) => ToPgRow (a, b, c, d) where
  rowEncoder :: RowEncoder (a, b, c, d)
rowEncoder = ((a, b, c, d) -> ((a, b), (c, d)))
-> RowEncoder (a, b)
-> RowEncoder (c, d)
-> RowEncoder (a, b, c, d)
forall a b c.
(a -> (b, c)) -> RowEncoder b -> RowEncoder c -> RowEncoder a
divide (\(a
a, b
b, c
c, d
d) -> ((a
a, b
b), (c
c, d
d))) RowEncoder (a, b)
forall a. ToPgRow a => RowEncoder a
rowEncoder RowEncoder (c, d)
forall a. ToPgRow a => RowEncoder a
rowEncoder

-- This instance implements toBinaryCopyBytes as well because we did this
-- to test if this method can help improve performance of COPY in our
-- benchmarks. We found that it can, but we didn't bother yet implementing
-- this for other types.
-- toBinaryCopyBytes encCtx = \(a, b, c, d) -> Builder.int16BE 4 <> toPgFieldWithSize a <> toPgFieldWithSize b <> toPgFieldWithSize c <> toPgFieldWithSize d
--   where
--     toPgFieldWithSize :: (ToPgField x) => x -> Builder.Builder
--     toPgFieldWithSize v = Builder.binaryField $ toPgField encCtx v

instance (ToPgField a, ToPgField b, ToPgField c, ToPgField d, ToPgField e) => ToPgRow (a, b, c, d, e) where
  rowEncoder :: RowEncoder (a, b, c, d, e)
rowEncoder = ((a, b, c, d, e) -> ((a, b, c), (d, e)))
-> RowEncoder (a, b, c)
-> RowEncoder (d, e)
-> RowEncoder (a, b, c, d, e)
forall a b c.
(a -> (b, c)) -> RowEncoder b -> RowEncoder c -> RowEncoder a
divide (\(a
a, b
b, c
c, d
d, e
e) -> ((a
a, b
b, c
c), (d
d, e
e))) RowEncoder (a, b, c)
forall a. ToPgRow a => RowEncoder a
rowEncoder RowEncoder (d, e)
forall a. ToPgRow a => RowEncoder a
rowEncoder

instance (ToPgField a, ToPgField b, ToPgField c, ToPgField d, ToPgField e, ToPgField f) => ToPgRow (a, b, c, d, e, f) where
  rowEncoder :: RowEncoder (a, b, c, d, e, f)
rowEncoder = ((a, b, c, d, e, f) -> ((a, b, c), (d, e, f)))
-> RowEncoder (a, b, c)
-> RowEncoder (d, e, f)
-> RowEncoder (a, b, c, d, e, f)
forall a b c.
(a -> (b, c)) -> RowEncoder b -> RowEncoder c -> RowEncoder a
divide (\(a
a, b
b, c
c, d
d, e
e, f
f) -> ((a
a, b
b, c
c), (d
d, e
e, f
f))) RowEncoder (a, b, c)
forall a. ToPgRow a => RowEncoder a
rowEncoder RowEncoder (d, e, f)
forall a. ToPgRow a => RowEncoder a
rowEncoder

instance (ToPgField a, ToPgField b, ToPgField c, ToPgField d, ToPgField e, ToPgField f, ToPgField g) => ToPgRow (a, b, c, d, e, f, g) where
  rowEncoder :: RowEncoder (a, b, c, d, e, f, g)
rowEncoder = ((a, b, c, d, e, f, g) -> ((a, b, c), (d, e, f, g)))
-> RowEncoder (a, b, c)
-> RowEncoder (d, e, f, g)
-> RowEncoder (a, b, c, d, e, f, g)
forall a b c.
(a -> (b, c)) -> RowEncoder b -> RowEncoder c -> RowEncoder a
divide (\(a
a, b
b, c
c, d
d, e
e, f
f, g
g) -> ((a
a, b
b, c
c), (d
d, e
e, f
f, g
g))) RowEncoder (a, b, c)
forall a. ToPgRow a => RowEncoder a
rowEncoder RowEncoder (d, e, f, g)
forall a. ToPgRow a => RowEncoder a
rowEncoder

instance (ToPgField a, ToPgField b, ToPgField c, ToPgField d, ToPgField e, ToPgField f, ToPgField g, ToPgField h) => ToPgRow (a, b, c, d, e, f, g, h) where
  rowEncoder :: RowEncoder (a, b, c, d, e, f, g, h)
rowEncoder = ((a, b, c, d, e, f, g, h) -> ((a, b, c, d), (e, f, g, h)))
-> RowEncoder (a, b, c, d)
-> RowEncoder (e, f, g, h)
-> RowEncoder (a, b, c, d, e, f, g, h)
forall a b c.
(a -> (b, c)) -> RowEncoder b -> RowEncoder c -> RowEncoder a
divide (\(a
a, b
b, c
c, d
d, e
e, f
f, g
g, h
h) -> ((a
a, b
b, c
c, d
d), (e
e, f
f, g
g, h
h))) RowEncoder (a, b, c, d)
forall a. ToPgRow a => RowEncoder a
rowEncoder RowEncoder (e, f, g, h)
forall a. ToPgRow a => RowEncoder a
rowEncoder

instance (ToPgField a, ToPgField b, ToPgField c, ToPgField d, ToPgField e, ToPgField f, ToPgField g, ToPgField h, ToPgField i) => ToPgRow (a, b, c, d, e, f, g, h, i) where
  rowEncoder :: RowEncoder (a, b, c, d, e, f, g, h, i)
rowEncoder = ((a, b, c, d, e, f, g, h, i) -> ((a, b, c, d), (e, f, g, h, i)))
-> RowEncoder (a, b, c, d)
-> RowEncoder (e, f, g, h, i)
-> RowEncoder (a, b, c, d, e, f, g, h, i)
forall a b c.
(a -> (b, c)) -> RowEncoder b -> RowEncoder c -> RowEncoder a
divide (\(a
a, b
b, c
c, d
d, e
e, f
f, g
g, h
h, i
i) -> ((a
a, b
b, c
c, d
d), (e
e, f
f, g
g, h
h, i
i))) RowEncoder (a, b, c, d)
forall a. ToPgRow a => RowEncoder a
rowEncoder RowEncoder (e, f, g, h, i)
forall a. ToPgRow a => RowEncoder a
rowEncoder

instance (ToPgField a, ToPgField b, ToPgField c, ToPgField d, ToPgField e, ToPgField f, ToPgField g, ToPgField h, ToPgField i, ToPgField j) => ToPgRow (a, b, c, d, e, f, g, h, i, j) where
  rowEncoder :: RowEncoder (a, b, c, d, e, f, g, h, i, j)
rowEncoder = ((a, b, c, d, e, f, g, h, i, j)
 -> ((a, b, c, d, e), (f, g, h, i, j)))
-> RowEncoder (a, b, c, d, e)
-> RowEncoder (f, g, h, i, j)
-> RowEncoder (a, b, c, d, e, f, g, h, i, j)
forall a b c.
(a -> (b, c)) -> RowEncoder b -> RowEncoder c -> RowEncoder a
divide (\(a
a, b
b, c
c, d
d, e
e, f
f, g
g, h
h, i
i, j
j) -> ((a
a, b
b, c
c, d
d, e
e), (f
f, g
g, h
h, i
i, j
j))) RowEncoder (a, b, c, d, e)
forall a. ToPgRow a => RowEncoder a
rowEncoder RowEncoder (f, g, h, i, j)
forall a. ToPgRow a => RowEncoder a
rowEncoder

instance (ToPgField a, ToPgField b, ToPgField c, ToPgField d, ToPgField e, ToPgField f, ToPgField g, ToPgField h, ToPgField i, ToPgField j, ToPgField k) => ToPgRow (a, b, c, d, e, f, g, h, i, j, k) where
  rowEncoder :: RowEncoder (a, b, c, d, e, f, g, h, i, j, k)
rowEncoder = ((a, b, c, d, e, f, g, h, i, j, k)
 -> ((a, b, c, d, e, f), (g, h, i, j, k)))
-> RowEncoder (a, b, c, d, e, f)
-> RowEncoder (g, h, i, j, k)
-> RowEncoder (a, b, c, d, e, f, g, h, i, j, k)
forall a b c.
(a -> (b, c)) -> RowEncoder b -> RowEncoder c -> RowEncoder a
divide (\(a
a, b
b, c
c, d
d, e
e, f
f, g
g, h
h, i
i, j
j, k
k) -> ((a
a, b
b, c
c, d
d, e
e, f
f), (g
g, h
h, i
i, j
j, k
k))) RowEncoder (a, b, c, d, e, f)
forall a. ToPgRow a => RowEncoder a
rowEncoder RowEncoder (g, h, i, j, k)
forall a. ToPgRow a => RowEncoder a
rowEncoder

-- instance (ToPgField a) => ToPgRow [a] where
--   rowEncoder = RowEncoder {
--     toPgParams = \xs -> concatMap toPgParams xs
--     , toTypeOids = \_ -> concatMap (\)
--   } $ \cols -> map (\v encodingContext -> let typOid = toTypeOid (Proxy @a) encodingContext in (typOid, toPgField encodingContext v)) cols

-- | The OID for `Data.Int`, which is machine dependent.
haskellIntOid :: Oid

-- | All pg type OIDs that fit into Haskell's `Data.Int`, whose size is machine dependent.
haskellIntOids :: [Oid]
(Oid
haskellIntOid, [Oid]
haskellIntOids)
  | (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Bounded a => a
maxBound @Int) :: Integer) Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Int32 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Bounded a => a
maxBound @Int32) = (Oid
int8Oid, [Oid
int2Oid, Oid
int4Oid, Oid
int8Oid])
  | (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Bounded a => a
maxBound @Int) :: Integer) Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Int16 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Bounded a => a
maxBound @Int16) = (Oid
int4Oid, [Oid
int2Oid, Oid
int4Oid])
  | Bool
otherwise = (Oid
int2Oid, [Oid
int2Oid])

-- | Big-Endian binary encoder for Haskell's `Data.Int`, which is machine-dependent.
binaryIntEncoder :: Int -> BinaryField
binaryIntEncoder :: Int -> BinaryField
binaryIntEncoder
  | Oid
haskellIntOid Oid -> Oid -> Bool
forall a. Eq a => a -> a -> Bool
== Oid
int8Oid = ByteString -> BinaryField
NotNull (ByteString -> BinaryField)
-> (Int -> ByteString) -> Int -> BinaryField
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Serialize a => a -> ByteString
Cereal.encode @Int64 (Int64 -> ByteString) -> (Int -> Int64) -> Int -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral
  | Oid
haskellIntOid Oid -> Oid -> Bool
forall a. Eq a => a -> a -> Bool
== Oid
int4Oid = ByteString -> BinaryField
NotNull (ByteString -> BinaryField)
-> (Int -> ByteString) -> Int -> BinaryField
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Serialize a => a -> ByteString
Cereal.encode @Int32 (Int32 -> ByteString) -> (Int -> Int32) -> Int -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral
  | Bool
otherwise = ByteString -> BinaryField
NotNull (ByteString -> BinaryField)
-> (Int -> ByteString) -> Int -> BinaryField
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Serialize a => a -> ByteString
Cereal.encode @Int16 (Int16 -> ByteString) -> (Int -> Int16) -> Int -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int16
forall a b. (Integral a, Num b) => a -> b
fromIntegral

-- | Big-Endian binary decoder for Haskell's various IntXX types.
binaryIntDecoder :: forall a. (Integral a, Bounded a) => Oid -> ByteString -> Either String a
binaryIntDecoder :: forall a.
(Integral a, Bounded a) =>
Oid -> ByteString -> Either String a
binaryIntDecoder Oid
typOid = \ByteString
bs ->
  if Bool
doesFit
    then ByteString -> Either String a
intDecoder ByteString
bs
    else String -> Either String a
forall a b. a -> Either a b
Left (String -> Either String a) -> String -> Either String a
forall a b. (a -> b) -> a -> b
$ String
"Chosen integral type does not fit every value for PG type with OID " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Oid -> String
forall a. Show a => a -> String
show Oid
typOid
  where
    maxBoundPgType :: Integer
    intDecoder :: ByteString -> Either String a
    (Integer
maxBoundPgType, ByteString -> Either String a
intDecoder)
      | Oid
typOid Oid -> Oid -> Bool
forall a. Eq a => a -> a -> Bool
== Oid
int8Oid = (Int64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Integer) -> Int64 -> Integer
forall a b. (a -> b) -> a -> b
$ forall a. Bounded a => a
maxBound @Int64, (Int64 -> a) -> Either String Int64 -> Either String a
forall a b. (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int64 -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Either String Int64 -> Either String a)
-> (ByteString -> Either String Int64)
-> ByteString
-> Either String a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Serialize a => ByteString -> Either String a
Cereal.decode @Int64)
      | Oid
typOid Oid -> Oid -> Bool
forall a. Eq a => a -> a -> Bool
== Oid
int4Oid = (Int32 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int32 -> Integer) -> Int32 -> Integer
forall a b. (a -> b) -> a -> b
$ forall a. Bounded a => a
maxBound @Int32, (Int32 -> a) -> Either String Int32 -> Either String a
forall a b. (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int32 -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Either String Int32 -> Either String a)
-> (ByteString -> Either String Int32)
-> ByteString
-> Either String a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Serialize a => ByteString -> Either String a
Cereal.decode @Int32)
      | Oid
typOid Oid -> Oid -> Bool
forall a. Eq a => a -> a -> Bool
== Oid
int2Oid = (Int16 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int16 -> Integer) -> Int16 -> Integer
forall a b. (a -> b) -> a -> b
$ forall a. Bounded a => a
maxBound @Int16, (Int16 -> a) -> Either String Int16 -> Either String a
forall a b. (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int16 -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Either String Int16 -> Either String a)
-> (ByteString -> Either String Int16)
-> ByteString
-> Either String a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Serialize a => ByteString -> Either String a
Cereal.decode @Int16)
      | Bool
otherwise = String -> (Integer, ByteString -> Either String a)
forall a. HasCallStack => String -> a
error String
"Bug in Hpgsql. Decoding binary integral type not an int2, int4 or int8"
    doesFit :: Bool
doesFit = Integer
maxBoundPgType Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= a -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Bounded a => a
maxBound @a)

binaryFloat4Decoder :: ByteString -> Float
binaryFloat4Decoder :: ByteString -> Float
binaryFloat4Decoder = Word32 -> Float
castWord32ToFloat (Word32 -> Float) -> (ByteString -> Word32) -> ByteString -> Float
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Word32)
-> (Word32 -> Word32) -> Either String Word32 -> Word32
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Word32
forall a. HasCallStack => String -> a
error Word32 -> Word32
forall a. a -> a
id (Either String Word32 -> Word32)
-> (ByteString -> Either String Word32) -> ByteString -> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Serialize a => ByteString -> Either String a
Cereal.decode @Word32

binaryFloat8Decoder :: ByteString -> Double
binaryFloat8Decoder :: ByteString -> Double
binaryFloat8Decoder = Word64 -> Double
castWord64ToDouble (Word64 -> Double)
-> (ByteString -> Word64) -> ByteString -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Word64)
-> (Word64 -> Word64) -> Either String Word64 -> Word64
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Word64
forall a. HasCallStack => String -> a
error Word64 -> Word64
forall a. a -> a
id (Either String Word64 -> Word64)
-> (ByteString -> Either String Word64) -> ByteString -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Serialize a => ByteString -> Either String a
Cereal.decode @Word64

parsePgType :: [Oid] -> (Maybe ByteString -> Either String a) -> FieldDecoder a
parsePgType :: forall a.
[Oid] -> (Maybe ByteString -> Either String a) -> FieldDecoder a
parsePgType ![Oid]
requiredTypeOids !Maybe ByteString -> Either String a
fieldValueDecoder =
  FieldDecoder
    { fieldValueDecoder :: FieldInfo -> Maybe ByteString -> Either String a
fieldValueDecoder = \FieldInfo
_oid -> Maybe ByteString -> Either String a
fieldValueDecoder,
      allowedPgTypes :: FieldInfo -> Bool
allowedPgTypes = (Oid -> [Oid] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Oid]
requiredTypeOids) (Oid -> Bool) -> (FieldInfo -> Oid) -> FieldInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldInfo -> Oid
fieldTypeOid
    }

instance FromPgField () where
  fieldDecoder :: FieldDecoder ()
fieldDecoder =
    FieldDecoder
      { fieldValueDecoder :: FieldInfo -> Maybe ByteString -> Either String ()
fieldValueDecoder = \FieldInfo
_oid -> \case
          Just ByteString
"" -> () -> Either String ()
forall a b. b -> Either a b
Right ()
          Just ByteString
bs -> String -> Either String ()
forall a b. a -> Either a b
Left (String -> Either String ()) -> String -> Either String ()
forall a b. (a -> b) -> a -> b
$ String
"Invalid value '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ByteString -> String
forall a. Show a => a -> String
show ByteString
bs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' for postgres void type"
          Maybe ByteString
Nothing -> String -> Either String ()
forall a b. a -> Either a b
Left String
"Cannot decode SQL null as the Haskell () type. Use a `Maybe ()`",
        allowedPgTypes :: FieldInfo -> Bool
allowedPgTypes = (Oid -> Oid -> Bool
forall a. Eq a => a -> a -> Bool
== Oid
voidOid) (Oid -> Bool) -> (FieldInfo -> Oid) -> FieldInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldInfo -> Oid
fieldTypeOid
      }

instance FromPgField Int where
  fieldDecoder :: FieldDecoder Int
fieldDecoder =
    FieldDecoder
      { fieldValueDecoder :: FieldInfo -> Maybe ByteString -> Either String Int
fieldValueDecoder = \FieldInfo {fieldTypeOid :: FieldInfo -> Oid
fieldTypeOid = Oid
oid} ->
          let !decode :: ByteString -> Either String Int
decode = Oid -> ByteString -> Either String Int
forall a.
(Integral a, Bounded a) =>
Oid -> ByteString -> Either String a
binaryIntDecoder Oid
oid
           in \case
                Just ByteString
bs -> ByteString -> Either String Int
decode ByteString
bs
                Maybe ByteString
Nothing -> String -> Either String Int
forall a b. a -> Either a b
Left String
"Cannot decode SQL null as the Haskell Int type. Use a `Maybe Int`",
        allowedPgTypes :: FieldInfo -> Bool
allowedPgTypes = (Oid -> [Oid] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Oid]
haskellIntOids) (Oid -> Bool) -> (FieldInfo -> Oid) -> FieldInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldInfo -> Oid
fieldTypeOid
      }

instance FromPgField Int16 where
  fieldDecoder :: FieldDecoder Int16
fieldDecoder =
    FieldDecoder
      { fieldValueDecoder :: FieldInfo -> Maybe ByteString -> Either String Int16
fieldValueDecoder = \FieldInfo {fieldTypeOid :: FieldInfo -> Oid
fieldTypeOid = Oid
oid} ->
          let !decode :: ByteString -> Either String Int16
decode = Oid -> ByteString -> Either String Int16
forall a.
(Integral a, Bounded a) =>
Oid -> ByteString -> Either String a
binaryIntDecoder Oid
oid
           in \case
                Just ByteString
bs -> ByteString -> Either String Int16
decode ByteString
bs
                Maybe ByteString
Nothing -> String -> Either String Int16
forall a b. a -> Either a b
Left String
"Cannot decode SQL null as the Haskell Int16 type. Use a `Maybe Int16`",
        allowedPgTypes :: FieldInfo -> Bool
allowedPgTypes = (Oid -> Oid -> Bool
forall a. Eq a => a -> a -> Bool
== Oid
int2Oid) (Oid -> Bool) -> (FieldInfo -> Oid) -> FieldInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldInfo -> Oid
fieldTypeOid
      }

instance FromPgField Int32 where
  fieldDecoder :: FieldDecoder Int32
fieldDecoder =
    FieldDecoder
      { fieldValueDecoder :: FieldInfo -> Maybe ByteString -> Either String Int32
fieldValueDecoder = \FieldInfo {fieldTypeOid :: FieldInfo -> Oid
fieldTypeOid = Oid
oid} ->
          let !decode :: ByteString -> Either String Int32
decode = Oid -> ByteString -> Either String Int32
forall a.
(Integral a, Bounded a) =>
Oid -> ByteString -> Either String a
binaryIntDecoder Oid
oid
           in \case
                Just ByteString
bs -> ByteString -> Either String Int32
decode ByteString
bs
                Maybe ByteString
Nothing -> String -> Either String Int32
forall a b. a -> Either a b
Left String
"Cannot decode SQL null as the Haskell Int32 type. Use a `Maybe Int32`",
        allowedPgTypes :: FieldInfo -> Bool
allowedPgTypes = (Oid -> [Oid] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Oid
int2Oid, Oid
int4Oid]) (Oid -> Bool) -> (FieldInfo -> Oid) -> FieldInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldInfo -> Oid
fieldTypeOid
      }

instance FromPgField Int64 where
  fieldDecoder :: FieldDecoder Int64
fieldDecoder =
    FieldDecoder
      { fieldValueDecoder :: FieldInfo -> Maybe ByteString -> Either String Int64
fieldValueDecoder = \FieldInfo {fieldTypeOid :: FieldInfo -> Oid
fieldTypeOid = Oid
oid} ->
          let !decode :: ByteString -> Either String Int64
decode = Oid -> ByteString -> Either String Int64
forall a.
(Integral a, Bounded a) =>
Oid -> ByteString -> Either String a
binaryIntDecoder Oid
oid
           in \case
                Just ByteString
bs -> ByteString -> Either String Int64
decode ByteString
bs
                Maybe ByteString
Nothing -> String -> Either String Int64
forall a b. a -> Either a b
Left String
"Cannot decode SQL null as the Haskell Int64 type. Use a `Maybe Int64`",
        allowedPgTypes :: FieldInfo -> Bool
allowedPgTypes = (Oid -> [Oid] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Oid
int2Oid, Oid
int4Oid, Oid
int8Oid]) (Oid -> Bool) -> (FieldInfo -> Oid) -> FieldInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldInfo -> Oid
fieldTypeOid
      }

instance FromPgField Integer where
  fieldDecoder :: FieldDecoder Integer
fieldDecoder =
    FieldDecoder
      { fieldValueDecoder :: FieldInfo -> Maybe ByteString -> Either String Integer
fieldValueDecoder = \FieldInfo {fieldTypeOid :: FieldInfo -> Oid
fieldTypeOid = Oid
oid} ->
          let !decodeInt :: ByteString -> Either String Int64
decodeInt = forall a.
(Integral a, Bounded a) =>
Oid -> ByteString -> Either String a
binaryIntDecoder @Int64 Oid
oid
           in \case
                Just ByteString
bs
                  | Oid
oid Oid -> Oid -> Bool
forall a. Eq a => a -> a -> Bool
/= Oid
numericOid -> Int64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Integer) -> Either String Int64 -> Either String Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Either String Int64
decodeInt ByteString
bs
                  | Bool
otherwise -> case Parser Scientific -> ByteString -> ParseResult Scientific
forall a. Parser a -> ByteString -> ParseResult a
Parser.parseOnly (Bool -> Parser Scientific
scientificDecoder Bool
True Parser Scientific -> Parser () -> Parser Scientific
forall a b. Parser a -> Parser b -> Parser a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
Parser.endOfInput) ByteString
bs of
                      Parser.ParseOk Scientific
sci -> case forall r i. (RealFloat r, Integral i) => Scientific -> Either r i
floatingOrInteger @Double @Integer Scientific
sci of
                        Right Integer
i -> Integer -> Either String Integer
forall a b. b -> Either a b
Right Integer
i
                        Left Double
_ -> String -> Either String Integer
forall a b. a -> Either a b
Left String
"Internal error in Hpgsql. Scientific to Integer conversion failed"
                      Parser.ParseFail String
err -> String -> Either String Integer
forall a b. a -> Either a b
Left String
err
                Maybe ByteString
Nothing -> String -> Either String Integer
forall a b. a -> Either a b
Left String
"Cannot decode SQL null as the Haskell Integer type. Use a `Maybe Integer`",
        allowedPgTypes :: FieldInfo -> Bool
allowedPgTypes = (Oid -> [Oid] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Oid
int8Oid, Oid
numericOid, Oid
int4Oid, Oid
int2Oid]) (Oid -> Bool) -> (FieldInfo -> Oid) -> FieldInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldInfo -> Oid
fieldTypeOid
      }

instance FromPgField Oid where
  fieldDecoder :: FieldDecoder Oid
fieldDecoder =
    FieldDecoder
      { fieldValueDecoder :: FieldInfo -> Maybe ByteString -> Either String Oid
fieldValueDecoder = \FieldInfo
_ -> \case
          -- Oids are just int4
          Just ByteString
bs -> Int32 -> Oid
Oid (Int32 -> Oid) -> Either String Int32 -> Either String Oid
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Oid -> ByteString -> Either String Int32
forall a.
(Integral a, Bounded a) =>
Oid -> ByteString -> Either String a
binaryIntDecoder Oid
int4Oid ByteString
bs
          Maybe ByteString
Nothing -> String -> Either String Oid
forall a b. a -> Either a b
Left String
"Cannot decode SQL null as the Haskell Oid type. Use a `Maybe Oid`",
        allowedPgTypes :: FieldInfo -> Bool
allowedPgTypes = (Oid -> Oid -> Bool
forall a. Eq a => a -> a -> Bool
== Oid
oidOid) (Oid -> Bool) -> (FieldInfo -> Oid) -> FieldInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldInfo -> Oid
fieldTypeOid
      }

instance FromPgField Float where
  fieldDecoder :: FieldDecoder Float
fieldDecoder = [Oid]
-> (Maybe ByteString -> Either String Float) -> FieldDecoder Float
forall a.
[Oid] -> (Maybe ByteString -> Either String a) -> FieldDecoder a
parsePgType [Oid
float4Oid] ((Maybe ByteString -> Either String Float) -> FieldDecoder Float)
-> (Maybe ByteString -> Either String Float) -> FieldDecoder Float
forall a b. (a -> b) -> a -> b
$ \case
    Just ByteString
bs -> Float -> Either String Float
forall a b. b -> Either a b
Right (Float -> Either String Float) -> Float -> Either String Float
forall a b. (a -> b) -> a -> b
$ ByteString -> Float
binaryFloat4Decoder ByteString
bs
    Maybe ByteString
Nothing -> String -> Either String Float
forall a b. a -> Either a b
Left String
"Cannot decode SQL null as the Haskell Float type. Use a `Maybe Float`"

instance FromPgField Double where
  fieldDecoder :: FieldDecoder Double
fieldDecoder =
    FieldDecoder
      { fieldValueDecoder :: FieldInfo -> Maybe ByteString -> Either String Double
fieldValueDecoder = \FieldInfo {fieldTypeOid :: FieldInfo -> Oid
fieldTypeOid = Oid
oid} ->
          let !decoder :: ByteString -> Double
decoder
                | Oid
oid Oid -> Oid -> Bool
forall a. Eq a => a -> a -> Bool
== Oid
float8Oid = ByteString -> Double
binaryFloat8Decoder
                | Bool
otherwise = Float -> Double
float2Double (Float -> Double) -> (ByteString -> Float) -> ByteString -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Float
binaryFloat4Decoder
           in \case
                Just ByteString
bs -> Double -> Either String Double
forall a b. b -> Either a b
Right (Double -> Either String Double) -> Double -> Either String Double
forall a b. (a -> b) -> a -> b
$ ByteString -> Double
decoder ByteString
bs
                Maybe ByteString
Nothing -> String -> Either String Double
forall a b. a -> Either a b
Left String
"Cannot decode SQL null as the Haskell Double type. Use a `Maybe Double`",
        allowedPgTypes :: FieldInfo -> Bool
allowedPgTypes = (Oid -> [Oid] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Oid
float8Oid, Oid
float4Oid]) (Oid -> Bool) -> (FieldInfo -> Oid) -> FieldInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldInfo -> Oid
fieldTypeOid
      }

-- | Allows you to specify a type (and other checks, possibly) for a `FieldDecoder`.
-- This can be useful to ensure you're not accidentally decoding a different type.
--
-- > data MyEnum = Val1 | Val2 | Val3
-- > myEnumFieldDecoderWithTypeInfoCheck :: FieldDecoder MyEnum
-- > myEnumFieldDecoderWithTypeInfoCheck =
-- >   let convert = \case
-- >         "val1" -> Val1
-- >         "val2" -> Val2
-- >         "val3" -> Val3
-- >         _ -> error "Invalid value for MyEnum"
-- >    in typeFieldDecoder
-- >         (typeMustBeNamed "my_enum")
-- >         $ convert <$> rawBytesFieldDecoder
--
-- This will work unless you use non-default flags in your connection options.
typeFieldDecoder :: (FieldInfo -> Bool) -> FieldDecoder a -> FieldDecoder a
typeFieldDecoder :: forall a. (FieldInfo -> Bool) -> FieldDecoder a -> FieldDecoder a
typeFieldDecoder FieldInfo -> Bool
fieldCheck FieldDecoder a
dec = FieldDecoder a
dec {allowedPgTypes = fieldCheck}

typeMustBeNamed :: Text -> (FieldInfo -> Bool)
typeMustBeNamed :: Text -> FieldInfo -> Bool
typeMustBeNamed Text
typName = \FieldInfo
fieldInfo ->
  (TypeInfo -> Text
typeName (TypeInfo -> Text) -> Maybe TypeInfo -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Oid -> TypeInfoCache -> Maybe TypeInfo
lookupTypeByOid FieldInfo
fieldInfo.fieldTypeOid FieldInfo
fieldInfo.encodingContext.typeInfoCache) Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just Text
typName

scientificDecoder :: Bool -> Parser.Parser Scientific
scientificDecoder :: Bool -> Parser Scientific
scientificDecoder Bool
mustBeInteger = do
  ndigits <- Parser Int16
int16Parser
  weight <- int16Parser
  sign <- int16Parser -- 0x0000 is positive, 0x4000 is negative, 0xC000 is NAN, 0xD000 is Positive Infinity, 0xF000 is Negative Infinity
  unless (sign == 0x0000 || sign == 0x4000) $ fail "NaN, positive or negative infinities cannot be decoded into Integer or Scientific"
  !dscale <- int16Parser
  when (mustBeInteger && dscale /= 0) $ fail "Decoding into `Integer` requires explicit casting with `numeric(X,0)` to force integral values"
  valueAbs <- parseAndMult ndigits (fromIntegral weight * 4) 0
  pure $ (if sign == 0x0000 then 1 else (-1)) * valueAbs
  where
    parseAndMult :: Int16 -> Int -> Scientific -> Parser.Parser Scientific
    parseAndMult :: Int16 -> Int -> Scientific -> Parser Scientific
parseAndMult Int16
0 Int
_ !Scientific
val = Scientific -> Parser Scientific
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Scientific
val
    parseAndMult !Int16
ndigitsLeft !Int
currexpon !Scientific
val = do
      !digit <- Int16 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int16 -> Integer) -> Parser Int16 -> Parser Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Int16
int16Parser
      parseAndMult (ndigitsLeft - 1) (currexpon - 4) (val + scientific digit currexpon)

instance FromPgField Scientific where
  -- See https://github.com/postgres/postgres/blob/799959dc7cf0e2462601bea8d07b6edec3fa0c4f/src/backend/utils/adt/numeric.c#L1163
  fieldDecoder :: FieldDecoder Scientific
fieldDecoder =
    FieldDecoder
      { fieldValueDecoder :: FieldInfo -> Maybe ByteString -> Either String Scientific
fieldValueDecoder = \FieldInfo {fieldTypeOid :: FieldInfo -> Oid
fieldTypeOid = Oid
oid} ->
          let !decodeInt :: ByteString -> Either String Int64
decodeInt = forall a.
(Integral a, Bounded a) =>
Oid -> ByteString -> Either String a
binaryIntDecoder @Int64 Oid
oid
           in \case
                Just ByteString
bs ->
                  -- TODO: There is loss converting from Float/Double to Scientific, but it might be quite small, so should we accept
                  -- float4Oid and float8Oid here?
                  if Oid
oid Oid -> Oid -> Bool
forall a. Eq a => a -> a -> Bool
== Oid
numericOid
                    then case Parser Scientific -> ByteString -> ParseResult Scientific
forall a. Parser a -> ByteString -> ParseResult a
Parser.parseOnly (Bool -> Parser Scientific
scientificDecoder Bool
False Parser Scientific -> Parser () -> Parser Scientific
forall a b. Parser a -> Parser b -> Parser a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
Parser.endOfInput) ByteString
bs of
                      Parser.ParseOk Scientific
sci -> Scientific -> Either String Scientific
forall a b. b -> Either a b
Right Scientific
sci
                      Parser.ParseFail String
err -> String -> Either String Scientific
forall a b. a -> Either a b
Left String
err
                    else (Integer -> Int -> Scientific) -> Int -> Integer -> Scientific
forall a b c. (a -> b -> c) -> b -> a -> c
flip Integer -> Int -> Scientific
scientific Int
0 (Integer -> Scientific)
-> (Int64 -> Integer) -> Int64 -> Scientific
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Scientific)
-> Either String Int64 -> Either String Scientific
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Either String Int64
decodeInt ByteString
bs
                Maybe ByteString
Nothing -> String -> Either String Scientific
forall a b. a -> Either a b
Left String
"Cannot decode SQL null as the Haskell Scientific type. Use a `Maybe Scientific`",
        allowedPgTypes :: FieldInfo -> Bool
allowedPgTypes = (Oid -> [Oid] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Oid
numericOid, Oid
int2Oid, Oid
int4Oid, Oid
int8Oid]) (Oid -> Bool) -> (FieldInfo -> Oid) -> FieldInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldInfo -> Oid
fieldTypeOid
      }

instance FromPgField (Ratio Integer) where
  fieldDecoder :: FieldDecoder (Ratio Integer)
fieldDecoder = Scientific -> Ratio Integer
forall a. Real a => a -> Ratio Integer
toRational (Scientific -> Ratio Integer)
-> FieldDecoder Scientific -> FieldDecoder (Ratio Integer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromPgField a => FieldDecoder a
fieldDecoder @Scientific

binaryTrue :: ByteString
binaryTrue :: ByteString
binaryTrue = Bool -> ByteString
forall a. Serialize a => a -> ByteString
Cereal.encode Bool
True

instance FromPgField Bool where
  fieldDecoder :: FieldDecoder Bool
fieldDecoder = [Oid]
-> (Maybe ByteString -> Either String Bool) -> FieldDecoder Bool
forall a.
[Oid] -> (Maybe ByteString -> Either String a) -> FieldDecoder a
parsePgType [Oid
boolOid] ((Maybe ByteString -> Either String Bool) -> FieldDecoder Bool)
-> (Maybe ByteString -> Either String Bool) -> FieldDecoder Bool
forall a b. (a -> b) -> a -> b
$ \case
    Just ByteString
bs -> Bool -> Either String Bool
forall a b. b -> Either a b
Right (Bool -> Either String Bool) -> Bool -> Either String Bool
forall a b. (a -> b) -> a -> b
$ ByteString
bs ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
binaryTrue
    Maybe ByteString
Nothing -> String -> Either String Bool
forall a b. a -> Either a b
Left String
"Cannot decode SQL null as the Haskell Bool type. Use a `Maybe Bool`"

instance FromPgField Char where
  fieldDecoder :: FieldDecoder Char
fieldDecoder =
    let textParser :: FieldInfo -> Maybe ByteString -> Either String Text
textParser = FieldDecoder Text
-> FieldInfo -> Maybe ByteString -> Either String Text
forall a.
FieldDecoder a -> FieldInfo -> Maybe ByteString -> Either String a
fieldValueDecoder (forall a. FromPgField a => FieldDecoder a
fieldDecoder @Text)
     in FieldDecoder
          { fieldValueDecoder :: FieldInfo -> Maybe ByteString -> Either String Char
fieldValueDecoder = \colInfo :: FieldInfo
colInfo@FieldInfo {fieldTypeOid :: FieldInfo -> Oid
fieldTypeOid = Oid
oid} ->
              let !decodeText :: Maybe ByteString -> Either String Text
decodeText = FieldInfo -> Maybe ByteString -> Either String Text
textParser FieldInfo
colInfo
               in \Maybe ByteString
mbs -> case Maybe ByteString
mbs of
                    Just ByteString
bs ->
                      if Oid
oid Oid -> Oid -> Bool
forall a. Eq a => a -> a -> Bool
== Oid
charOid
                        -- TODO: Postgres has values of type "char" in the pg_type.typcategory table.
                        -- We should test this instance works with those, and we haven't yet.
                        then Char -> Either String Char
forall a b. b -> Either a b
Right (Char -> Either String Char) -> Char -> Either String Char
forall a b. (a -> b) -> a -> b
$ ByteString -> Char
BSC.head ByteString
bs
                        else case Maybe ByteString -> Either String Text
decodeText Maybe ByteString
mbs of
                          Left String
err -> String -> Either String Char
forall a b. a -> Either a b
Left String
err
                          Right Text
t -> if Text -> Int
Text.length Text
t Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 then String -> Either String Char
forall a b. a -> Either a b
Left String
"Cannot parse text with more than one character into a Haskell Char type." else Char -> Either String Char
forall a b. b -> Either a b
Right (HasCallStack => Text -> Char
Text -> Char
Text.head Text
t)
                    Maybe ByteString
Nothing -> String -> Either String Char
forall a b. a -> Either a b
Left String
"Cannot decode SQL null as the Haskell Char type. Use a `Maybe Char`",
            -- TODO: All the varchar types?
            allowedPgTypes :: FieldInfo -> Bool
allowedPgTypes = (Oid -> [Oid] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Oid
charOid, Oid
textOid]) (Oid -> Bool) -> (FieldInfo -> Oid) -> FieldInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldInfo -> Oid
fieldTypeOid
          }

instance FromPgField ByteString where
  fieldDecoder :: FieldDecoder ByteString
fieldDecoder = [Oid]
-> (Maybe ByteString -> Either String ByteString)
-> FieldDecoder ByteString
forall a.
[Oid] -> (Maybe ByteString -> Either String a) -> FieldDecoder a
parsePgType [Oid
byteaOid] ((Maybe ByteString -> Either String ByteString)
 -> FieldDecoder ByteString)
-> (Maybe ByteString -> Either String ByteString)
-> FieldDecoder ByteString
forall a b. (a -> b) -> a -> b
$ \case
    Just ByteString
bs -> ByteString -> Either String ByteString
forall a b. b -> Either a b
Right ByteString
bs
    Maybe ByteString
Nothing -> String -> Either String ByteString
forall a b. a -> Either a b
Left String
"Cannot decode SQL null as the Haskell ByteString type. Use a `Maybe ByteString`"

instance FromPgField LBS.ByteString where
  fieldDecoder :: FieldDecoder ByteString
fieldDecoder = [Oid]
-> (Maybe ByteString -> Either String ByteString)
-> FieldDecoder ByteString
forall a.
[Oid] -> (Maybe ByteString -> Either String a) -> FieldDecoder a
parsePgType [Oid
byteaOid] ((Maybe ByteString -> Either String ByteString)
 -> FieldDecoder ByteString)
-> (Maybe ByteString -> Either String ByteString)
-> FieldDecoder ByteString
forall a b. (a -> b) -> a -> b
$ \case
    Just ByteString
bs -> ByteString -> Either String ByteString
forall a b. b -> Either a b
Right (ByteString -> Either String ByteString)
-> ByteString -> Either String ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
LBS.fromStrict ByteString
bs
    Maybe ByteString
Nothing -> String -> Either String ByteString
forall a b. a -> Either a b
Left String
"Cannot decode SQL null as the Haskell ByteString type. Use a `Maybe ByteString`"

instance FromPgField Text where
  fieldDecoder :: FieldDecoder Text
fieldDecoder = [Oid]
-> (Maybe ByteString -> Either String Text) -> FieldDecoder Text
forall a.
[Oid] -> (Maybe ByteString -> Either String a) -> FieldDecoder a
parsePgType [Oid
textOid, Oid
varcharOid, Oid
nameOid] ((Maybe ByteString -> Either String Text) -> FieldDecoder Text)
-> (Maybe ByteString -> Either String Text) -> FieldDecoder Text
forall a b. (a -> b) -> a -> b
$ \case
    Just ByteString
bs -> Text -> Either String Text
forall a b. b -> Either a b
Right (Text -> Either String Text) -> Text -> Either String Text
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
decodeUtf8 ByteString
bs
    -- TODO: Use some faster unsafeDecodeUtf8 function?
    Maybe ByteString
Nothing -> String -> Either String Text
forall a b. a -> Either a b
Left String
"Cannot decode SQL null as the Haskell Text type. Use a `Maybe Text`"

instance FromPgField LT.Text where
  fieldDecoder :: FieldDecoder Text
fieldDecoder = [Oid]
-> (Maybe ByteString -> Either String Text) -> FieldDecoder Text
forall a.
[Oid] -> (Maybe ByteString -> Either String a) -> FieldDecoder a
parsePgType [Oid
textOid, Oid
varcharOid, Oid
nameOid] ((Maybe ByteString -> Either String Text) -> FieldDecoder Text)
-> (Maybe ByteString -> Either String Text) -> FieldDecoder Text
forall a b. (a -> b) -> a -> b
$ \case
    Just ByteString
bs -> Text -> Either String Text
forall a b. b -> Either a b
Right (Text -> Either String Text) -> Text -> Either String Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
LT.fromStrict (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
decodeUtf8 ByteString
bs
    -- TODO: Use some faster unsafeDecodeUtf8 function?
    Maybe ByteString
Nothing -> String -> Either String Text
forall a b. a -> Either a b
Left String
"Cannot decode SQL null as the Haskell Text type. Use a `Maybe Text`"

instance FromPgField String where
  fieldDecoder :: FieldDecoder String
fieldDecoder = [Oid]
-> (Maybe ByteString -> Either String String)
-> FieldDecoder String
forall a.
[Oid] -> (Maybe ByteString -> Either String a) -> FieldDecoder a
parsePgType [Oid
textOid, Oid
varcharOid, Oid
nameOid] ((Maybe ByteString -> Either String String) -> FieldDecoder String)
-> (Maybe ByteString -> Either String String)
-> FieldDecoder String
forall a b. (a -> b) -> a -> b
$ \case
    -- connection option).
    Just ByteString
bs -> String -> Either String String
forall a b. b -> Either a b
Right (String -> Either String String) -> String -> Either String String
forall a b. (a -> b) -> a -> b
$ Text -> String
Text.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
decodeUtf8 ByteString
bs
    -- TODO: Use some faster unsafeDecodeUtf8 function?
    Maybe ByteString
Nothing -> String -> Either String String
forall a b. a -> Either a b
Left String
"Cannot decode SQL null as the Haskell String type. Use a `Maybe String`"

-- | This instance does not work if you have fillTypeInfoCache disabled (that would be a non-default
-- connection option).
instance FromPgField (CI Text) where
  fieldDecoder :: FieldDecoder (CI Text)
fieldDecoder = (FieldInfo -> Bool)
-> FieldDecoder (CI Text) -> FieldDecoder (CI Text)
forall a. (FieldInfo -> Bool) -> FieldDecoder a -> FieldDecoder a
typeFieldDecoder (Text -> FieldInfo -> Bool
typeMustBeNamed Text
"citext") (FieldDecoder (CI Text) -> FieldDecoder (CI Text))
-> FieldDecoder (CI Text) -> FieldDecoder (CI Text)
forall a b. (a -> b) -> a -> b
$ Text -> CI Text
forall s. FoldCase s => s -> CI s
CI.mk (Text -> CI Text) -> FieldDecoder Text -> FieldDecoder (CI Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FieldDecoder Text
forall a. FromPgField a => FieldDecoder a
fieldDecoder

-- | This instance does not work if you have fillTypeInfoCache disabled (that would be a non-default
-- connection option).
instance FromPgField (CI LT.Text) where
  fieldDecoder :: FieldDecoder (CI Text)
fieldDecoder = (FieldInfo -> Bool)
-> FieldDecoder (CI Text) -> FieldDecoder (CI Text)
forall a. (FieldInfo -> Bool) -> FieldDecoder a -> FieldDecoder a
typeFieldDecoder (Text -> FieldInfo -> Bool
typeMustBeNamed Text
"citext") (FieldDecoder (CI Text) -> FieldDecoder (CI Text))
-> FieldDecoder (CI Text) -> FieldDecoder (CI Text)
forall a b. (a -> b) -> a -> b
$ Text -> CI Text
forall s. FoldCase s => s -> CI s
CI.mk (Text -> CI Text) -> FieldDecoder Text -> FieldDecoder (CI Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FieldDecoder Text
forall a. FromPgField a => FieldDecoder a
fieldDecoder

-- | This instance does not work if you have fillTypeInfoCache disabled (that would be a non-default
-- connection option).
instance FromPgField (CI String) where
  fieldDecoder :: FieldDecoder (CI String)
fieldDecoder = (FieldInfo -> Bool)
-> FieldDecoder (CI String) -> FieldDecoder (CI String)
forall a. (FieldInfo -> Bool) -> FieldDecoder a -> FieldDecoder a
typeFieldDecoder (Text -> FieldInfo -> Bool
typeMustBeNamed Text
"citext") (FieldDecoder (CI String) -> FieldDecoder (CI String))
-> FieldDecoder (CI String) -> FieldDecoder (CI String)
forall a b. (a -> b) -> a -> b
$ String -> CI String
forall s. FoldCase s => s -> CI s
CI.mk (String -> CI String)
-> FieldDecoder String -> FieldDecoder (CI String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FieldDecoder String
forall a. FromPgField a => FieldDecoder a
fieldDecoder

instance FromPgField UTCTime where
  fieldDecoder :: FieldDecoder UTCTime
fieldDecoder = [Oid]
-> (Maybe ByteString -> Either String UTCTime)
-> FieldDecoder UTCTime
forall a.
[Oid] -> (Maybe ByteString -> Either String a) -> FieldDecoder a
parsePgType [Oid
timestamptzOid] ((Maybe ByteString -> Either String UTCTime)
 -> FieldDecoder UTCTime)
-> (Maybe ByteString -> Either String UTCTime)
-> FieldDecoder UTCTime
forall a b. (a -> b) -> a -> b
$ \case
    Just ByteString
bs -> do
      -- See https://github.com/postgres/postgres/blob/50cb7505b3010736b9a7922e903931534785f3aa/src/backend/utils/adt/timestamp.c#L1909
      totalusecs <- forall a. Serialize a => ByteString -> Either String a
Cereal.decode @Int64 ByteString
bs
      let (day, timeusecs) = totalusecs `divMod` 86_400_000_000 -- USECS per day
          parsedDate = CalendarDiffDays -> Day -> Day
addJulianDurationClip (Integer -> Integer -> CalendarDiffDays
CalendarDiffDays Integer
0 (Int64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
day)) (Day -> Day) -> Day -> Day
forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Day
fromJulian Integer
1999 Int
12 Int
19
      Right $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000)
    Maybe ByteString
Nothing -> String -> Either String UTCTime
forall a b. a -> Either a b
Left String
"Cannot decode SQL null as the Haskell UTCTime type. Use a `Maybe UTCTime`"

instance FromPgField (Unbounded UTCTime) where
  fieldDecoder :: FieldDecoder (Unbounded UTCTime)
fieldDecoder = [Oid]
-> (Maybe ByteString -> Either String (Unbounded UTCTime))
-> FieldDecoder (Unbounded UTCTime)
forall a.
[Oid] -> (Maybe ByteString -> Either String a) -> FieldDecoder a
parsePgType [Oid
timestamptzOid] ((Maybe ByteString -> Either String (Unbounded UTCTime))
 -> FieldDecoder (Unbounded UTCTime))
-> (Maybe ByteString -> Either String (Unbounded UTCTime))
-> FieldDecoder (Unbounded UTCTime)
forall a b. (a -> b) -> a -> b
$ \case
    Just ByteString
bs -> do
      -- See https://github.com/postgres/postgres/blob/50cb7505b3010736b9a7922e903931534785f3aa/src/backend/utils/adt/timestamp.c#L1909
      totalusecs <- forall a. Serialize a => ByteString -> Either String a
Cereal.decode @Int64 ByteString
bs
      Right $
        if totalusecs == minBound
          then NegInfinity
          else
            if totalusecs == maxBound
              then PosInfinity
              else
                let (day, timeusecs) = totalusecs `divMod` 86_400_000_000 -- USECS per day
                    parsedDate = CalendarDiffDays -> Day -> Day
addJulianDurationClip (Integer -> Integer -> CalendarDiffDays
CalendarDiffDays Integer
0 (Int64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
day)) (Day -> Day) -> Day -> Day
forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Day
fromJulian Integer
1999 Int
12 Int
19
                 in Finite $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000)
    Maybe ByteString
Nothing -> String -> Either String (Unbounded UTCTime)
forall a b. a -> Either a b
Left String
"Cannot decode SQL null as the Haskell (Unbounded UTCTime) type. Use a `Maybe (Unbounded UTCTime)`"

instance FromPgField ZonedTime where
  fieldDecoder :: FieldDecoder ZonedTime
fieldDecoder = [Oid]
-> (Maybe ByteString -> Either String ZonedTime)
-> FieldDecoder ZonedTime
forall a.
[Oid] -> (Maybe ByteString -> Either String a) -> FieldDecoder a
parsePgType [Oid
timestamptzOid] ((Maybe ByteString -> Either String ZonedTime)
 -> FieldDecoder ZonedTime)
-> (Maybe ByteString -> Either String ZonedTime)
-> FieldDecoder ZonedTime
forall a b. (a -> b) -> a -> b
$ \case
    Just ByteString
bs -> do
      -- See https://github.com/postgres/postgres/blob/50cb7505b3010736b9a7922e903931534785f3aa/src/backend/utils/adt/timestamp.c#L1909
      totalusecs <- forall a. Serialize a => ByteString -> Either String a
Cereal.decode @Int64 ByteString
bs
      let (day, timeusecs) = totalusecs `divMod` 86_400_000_000 -- USECS per day
          parsedDate = CalendarDiffDays -> Day -> Day
addJulianDurationClip (Integer -> Integer -> CalendarDiffDays
CalendarDiffDays Integer
0 (Int64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
day)) (Day -> Day) -> Day -> Day
forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Day
fromJulian Integer
1999 Int
12 Int
19
      Right $ utcToZonedTime utc $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000)
    Maybe ByteString
Nothing -> String -> Either String ZonedTime
forall a b. a -> Either a b
Left String
"Cannot decode SQL null as the Haskell ZonedTime type. Use a `Maybe ZonedTime`"

instance FromPgField (Unbounded ZonedTime) where
  fieldDecoder :: FieldDecoder (Unbounded ZonedTime)
fieldDecoder = [Oid]
-> (Maybe ByteString -> Either String (Unbounded ZonedTime))
-> FieldDecoder (Unbounded ZonedTime)
forall a.
[Oid] -> (Maybe ByteString -> Either String a) -> FieldDecoder a
parsePgType [Oid
timestamptzOid] ((Maybe ByteString -> Either String (Unbounded ZonedTime))
 -> FieldDecoder (Unbounded ZonedTime))
-> (Maybe ByteString -> Either String (Unbounded ZonedTime))
-> FieldDecoder (Unbounded ZonedTime)
forall a b. (a -> b) -> a -> b
$ \case
    Just ByteString
bs -> do
      -- See https://github.com/postgres/postgres/blob/50cb7505b3010736b9a7922e903931534785f3aa/src/backend/utils/adt/timestamp.c#L1909
      totalusecs <- forall a. Serialize a => ByteString -> Either String a
Cereal.decode @Int64 ByteString
bs
      Right $
        if totalusecs == minBound
          then NegInfinity
          else
            if totalusecs == maxBound
              then PosInfinity
              else
                let (day, timeusecs) = totalusecs `divMod` 86_400_000_000 -- USECS per day
                    parsedDate = CalendarDiffDays -> Day -> Day
addJulianDurationClip (Integer -> Integer -> CalendarDiffDays
CalendarDiffDays Integer
0 (Int64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
day)) (Day -> Day) -> Day -> Day
forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Day
fromJulian Integer
1999 Int
12 Int
19
                 in Finite $ utcToZonedTime utc $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000)
    Maybe ByteString
Nothing -> String -> Either String (Unbounded ZonedTime)
forall a b. a -> Either a b
Left String
"Cannot decode SQL null as the Haskell ZonedTime type. Use a `Maybe ZonedTime`"

instance FromPgField LocalTime where
  fieldDecoder :: FieldDecoder LocalTime
fieldDecoder = [Oid]
-> (Maybe ByteString -> Either String LocalTime)
-> FieldDecoder LocalTime
forall a.
[Oid] -> (Maybe ByteString -> Either String a) -> FieldDecoder a
parsePgType [Oid
timestampOid] ((Maybe ByteString -> Either String LocalTime)
 -> FieldDecoder LocalTime)
-> (Maybe ByteString -> Either String LocalTime)
-> FieldDecoder LocalTime
forall a b. (a -> b) -> a -> b
$ \case
    Just ByteString
bs -> do
      totalusecs <- forall a. Serialize a => ByteString -> Either String a
Cereal.decode @Int64 ByteString
bs
      let (day, timeusecs) = totalusecs `divMod` 86_400_000_000 -- USECS per day
          parsedDate = CalendarDiffDays -> Day -> Day
addJulianDurationClip (Integer -> Integer -> CalendarDiffDays
CalendarDiffDays Integer
0 (Int64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
day)) (Day -> Day) -> Day -> Day
forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Day
fromJulian Integer
1999 Int
12 Int
19
      Right $ LocalTime parsedDate (timeToTimeOfDay $ picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000)
    Maybe ByteString
Nothing -> String -> Either String LocalTime
forall a b. a -> Either a b
Left String
"Cannot decode SQL null as the Haskell LocalTime type. Use a `Maybe LocalTime`"

instance FromPgField TimeOfDay where
  fieldDecoder :: FieldDecoder TimeOfDay
fieldDecoder = [Oid]
-> (Maybe ByteString -> Either String TimeOfDay)
-> FieldDecoder TimeOfDay
forall a.
[Oid] -> (Maybe ByteString -> Either String a) -> FieldDecoder a
parsePgType [Oid
timeOid] ((Maybe ByteString -> Either String TimeOfDay)
 -> FieldDecoder TimeOfDay)
-> (Maybe ByteString -> Either String TimeOfDay)
-> FieldDecoder TimeOfDay
forall a b. (a -> b) -> a -> b
$ \case
    Just ByteString
bs -> do
      usecs <- forall a. Serialize a => ByteString -> Either String a
Cereal.decode @Int64 ByteString
bs
      Right $ timeToTimeOfDay $ picosecondsToDiffTime $ fromIntegral usecs * 1_000_000
    Maybe ByteString
Nothing -> String -> Either String TimeOfDay
forall a b. a -> Either a b
Left String
"Cannot decode SQL null as the Haskell TimeOfDay type. Use a `Maybe TimeOfDay`"

instance FromPgField Day where
  fieldDecoder :: FieldDecoder Day
fieldDecoder = [Oid]
-> (Maybe ByteString -> Either String Day) -> FieldDecoder Day
forall a.
[Oid] -> (Maybe ByteString -> Either String a) -> FieldDecoder a
parsePgType [Oid
dateOid] ((Maybe ByteString -> Either String Day) -> FieldDecoder Day)
-> (Maybe ByteString -> Either String Day) -> FieldDecoder Day
forall a b. (a -> b) -> a -> b
$ \case
    Just ByteString
bs -> do
      -- There is a very specific conversion function for these, which I poorly translated to Haskell
      -- https://github.com/postgres/postgres/blob/799959dc7cf0e2462601bea8d07b6edec3fa0c4f/src/backend/utils/adt/datetime.c#L321
      -- But I found a simpler way to do this. Let's see if it works in our property based tests
      jd <- forall a. Serialize a => ByteString -> Either String a
Cereal.decode @Int32 ByteString
bs
      Right $ addJulianDurationClip (CalendarDiffDays 0 (fromIntegral jd - 13)) $ fromJulian 2000 01 01
    Maybe ByteString
Nothing -> String -> Either String Day
forall a b. a -> Either a b
Left String
"Cannot decode SQL null as the Haskell Day type. Use a `Maybe Day`"

instance FromPgField (Unbounded Day) where
  fieldDecoder :: FieldDecoder (Unbounded Day)
fieldDecoder = [Oid]
-> (Maybe ByteString -> Either String (Unbounded Day))
-> FieldDecoder (Unbounded Day)
forall a.
[Oid] -> (Maybe ByteString -> Either String a) -> FieldDecoder a
parsePgType [Oid
dateOid] ((Maybe ByteString -> Either String (Unbounded Day))
 -> FieldDecoder (Unbounded Day))
-> (Maybe ByteString -> Either String (Unbounded Day))
-> FieldDecoder (Unbounded Day)
forall a b. (a -> b) -> a -> b
$ \case
    Just ByteString
bs -> do
      -- There is a very specific conversion function for these, which I poorly translated to Haskell
      -- https://github.com/postgres/postgres/blob/799959dc7cf0e2462601bea8d07b6edec3fa0c4f/src/backend/utils/adt/datetime.c#L321
      -- But I found a simpler way to do this. Let's see if it works in our property based tests
      jd <- forall a. Serialize a => ByteString -> Either String a
Cereal.decode @Int32 ByteString
bs
      Right $
        if jd == minBound
          then NegInfinity
          else
            if jd == maxBound
              then PosInfinity
              else
                Finite $ addJulianDurationClip (CalendarDiffDays 0 (fromIntegral jd - 13)) $ fromJulian 2000 01 01
    Maybe ByteString
Nothing -> String -> Either String (Unbounded Day)
forall a b. a -> Either a b
Left String
"Cannot decode SQL null as the Haskell (Unbounded Day) type. Use a `Maybe (Unbounded Day)`"

instance FromPgField CalendarDiffTime where
  fieldDecoder :: FieldDecoder CalendarDiffTime
fieldDecoder = [Oid]
-> (Maybe ByteString -> Either String CalendarDiffTime)
-> FieldDecoder CalendarDiffTime
forall a.
[Oid] -> (Maybe ByteString -> Either String a) -> FieldDecoder a
parsePgType [Oid
intervalOid] ((Maybe ByteString -> Either String CalendarDiffTime)
 -> FieldDecoder CalendarDiffTime)
-> (Maybe ByteString -> Either String CalendarDiffTime)
-> FieldDecoder CalendarDiffTime
forall a b. (a -> b) -> a -> b
$ \case
    Just ByteString
bs -> do
      (nMicrosecs :: Int64, nDays :: Int32, nMonths :: Int32) <- ByteString -> Either String (Int64, Int32, Int32)
forall a. Serialize a => ByteString -> Either String a
Cereal.decode ByteString
bs
      Right $ CalendarDiffTime {ctMonths = fromIntegral nMonths, ctTime = secondsToNominalDiffTime (fromIntegral nDays * 86400) + realToFrac (picosecondsToDiffTime (fromIntegral nMicrosecs * 1_000_000))}
    Maybe ByteString
Nothing -> String -> Either String CalendarDiffTime
forall a b. a -> Either a b
Left String
"Cannot decode SQL null as the Haskell CalendarDiffTime type. Use a `Maybe CalendarDiffTime`"

instance FromPgField UUID where
  fieldDecoder :: FieldDecoder UUID
fieldDecoder = [Oid]
-> (Maybe ByteString -> Either String UUID) -> FieldDecoder UUID
forall a.
[Oid] -> (Maybe ByteString -> Either String a) -> FieldDecoder a
parsePgType [Oid
uuidOid] ((Maybe ByteString -> Either String UUID) -> FieldDecoder UUID)
-> (Maybe ByteString -> Either String UUID) -> FieldDecoder UUID
forall a b. (a -> b) -> a -> b
$ \case
    Just ByteString
bs -> case ByteString -> Maybe UUID
UUID.fromByteString (ByteString -> ByteString
LBS.fromStrict ByteString
bs) of
      Just UUID
uuid -> UUID -> Either String UUID
forall a b. b -> Either a b
Right UUID
uuid
      Maybe UUID
Nothing -> String -> Either String UUID
forall a b. a -> Either a b
Left String
"Bug in Hpgsql: UUID field could not be decoded"
    Maybe ByteString
Nothing -> String -> Either String UUID
forall a b. a -> Either a b
Left String
"Cannot decode SQL null as the Haskell UUID type. Use a `Maybe UUID`"

instance FromPgField Aeson.Value where
  fieldDecoder :: FieldDecoder Value
fieldDecoder =
    FieldDecoder
      { fieldValueDecoder :: FieldInfo -> Maybe ByteString -> Either String Value
fieldValueDecoder =
          \FieldInfo {Oid
fieldTypeOid :: FieldInfo -> Oid
fieldTypeOid :: Oid
fieldTypeOid} ->
            let
              -- jsonb has a byte prepended to the contents and json does not
              !fixJsonb :: ByteString -> ByteString
fixJsonb = if Oid
fieldTypeOid Oid -> Oid -> Bool
forall a. Eq a => a -> a -> Bool
== Oid
jsonbOid then Int -> ByteString -> ByteString
BS.drop Int
1 else ByteString -> ByteString
forall a. a -> a
Prelude.id
             in
              \case
                Just ByteString
bs -> case ByteString -> Maybe Value
forall a. FromJSON a => ByteString -> Maybe a
Aeson.decodeStrict (ByteString -> Maybe Value) -> ByteString -> Maybe Value
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
fixJsonb ByteString
bs of
                  Just Value
d -> Value -> Either String Value
forall a b. b -> Either a b
Right Value
d
                  Maybe Value
Nothing -> String -> Either String Value
forall a b. a -> Either a b
Left String
"Bug in Hpgsql. Postgres produced a json or jsonb value that Aeson does not consider valid."
                Maybe ByteString
Nothing -> String -> Either String Value
forall a b. a -> Either a b
Left String
"Cannot decode SQL null as the Haskell Aeson.Value type. Use a `Maybe Aeson.Value` if you want SQL nulls",
        allowedPgTypes :: FieldInfo -> Bool
allowedPgTypes = (Oid -> [Oid] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Oid
jsonOid, Oid
jsonbOid]) (Oid -> Bool) -> (FieldInfo -> Oid) -> FieldInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldInfo -> Oid
fieldTypeOid
      }

-- | A FieldDecoder that accepts and decodes SQL NULLs into `Nothing` values
-- for a given decoder.
nullableField :: FieldDecoder a -> FieldDecoder (Maybe a)
nullableField :: forall a. FieldDecoder a -> FieldDecoder (Maybe a)
nullableField FieldDecoder {FieldInfo -> Bool
FieldInfo -> Maybe ByteString -> Either String a
fieldValueDecoder :: forall a.
FieldDecoder a -> FieldInfo -> Maybe ByteString -> Either String a
allowedPgTypes :: forall a. FieldDecoder a -> FieldInfo -> Bool
fieldValueDecoder :: FieldInfo -> Maybe ByteString -> Either String a
allowedPgTypes :: FieldInfo -> Bool
..} =
  FieldDecoder
    { fieldValueDecoder :: FieldInfo -> Maybe ByteString -> Either String (Maybe a)
fieldValueDecoder = \FieldInfo
oid ->
        let !origFieldValueParser :: Maybe ByteString -> Either String a
origFieldValueParser = FieldInfo -> Maybe ByteString -> Either String a
fieldValueDecoder FieldInfo
oid
         in \case
              Maybe ByteString
Nothing -> Maybe a -> Either String (Maybe a)
forall a b. b -> Either a b
Right Maybe a
forall a. Maybe a
Nothing
              Maybe ByteString
justBs -> a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> Either String a -> Either String (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ByteString -> Either String a
origFieldValueParser Maybe ByteString
justBs,
      FieldInfo -> Bool
allowedPgTypes :: FieldInfo -> Bool
allowedPgTypes :: FieldInfo -> Bool
allowedPgTypes
    }

instance (FromPgField a) => FromPgField (Maybe a) where
  fieldDecoder :: FieldDecoder (Maybe a)
fieldDecoder = FieldDecoder a -> FieldDecoder (Maybe a)
forall a. FieldDecoder a -> FieldDecoder (Maybe a)
nullableField FieldDecoder a
forall a. FromPgField a => FieldDecoder a
fieldDecoder

allowOnlyArrayTypes :: FieldInfo -> Bool
allowOnlyArrayTypes :: FieldInfo -> Bool
allowOnlyArrayTypes FieldInfo
fieldInfo =
  -- TODO: We could check the elemTypeOid too, but maybe later
  case Oid -> TypeInfoCache -> Maybe TypeInfo
lookupTypeByOid FieldInfo
fieldInfo.fieldTypeOid FieldInfo
fieldInfo.encodingContext.typeInfoCache of
    Just (TypeInfo {typeDetails :: TypeInfo -> TypeDetails
typeDetails = ArrayType ArrayTypeDetails
_}) -> Bool
True
    Maybe TypeInfo
Nothing -> Bool
True -- Assume user knows what they're doing
    Just TypeInfo
_ -> Bool
False -- Definitely not an array

instance forall a. (FromPgField a) => FromPgField (Vector a) where
  fieldDecoder :: FieldDecoder (Vector a)
fieldDecoder = (forall (m :: * -> *). Monad m => Int -> m a -> m (Vector a))
-> FieldDecoder a -> FieldDecoder (Vector a)
forall a (f :: * -> *).
Monoid (f a) =>
(forall (m :: * -> *). Monad m => Int -> m a -> m (f a))
-> FieldDecoder a -> FieldDecoder (f a)
arrayField Int -> m a -> m (Vector a)
forall (m :: * -> *). Monad m => Int -> m a -> m (Vector a)
forall (m :: * -> *) a. Monad m => Int -> m a -> m (Vector a)
Vector.replicateM FieldDecoder a
forall a. FromPgField a => FieldDecoder a
fieldDecoder

instance {-# OVERLAPPING #-} forall a. (FromPgField a) => FromPgField (Vector (Vector a)) where
  -- From https://github.com/postgres/postgres/blob/5941946d0934b9eccb0d5bfebd40b155249a0130/src/backend/utils/adt/arrayfuncs.c#L1548
  fieldDecoder :: FieldDecoder (Vector (Vector a))
fieldDecoder =
    FieldDecoder
      { fieldValueDecoder :: FieldInfo -> Maybe ByteString -> Either String (Vector (Vector a))
fieldValueDecoder = \FieldInfo
colInfo ->
          let !arrayFieldDecoder :: Parser (Vector (Vector a))
arrayFieldDecoder = EncodingContext -> Parser (Vector (Vector a))
arrayParser FieldInfo
colInfo.encodingContext Parser (Vector (Vector a))
-> Parser () -> Parser (Vector (Vector a))
forall a b. Parser a -> Parser b -> Parser a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
Parser.endOfInput
           in \case
                Maybe ByteString
Nothing -> String -> Either String (Vector (Vector a))
forall a b. a -> Either a b
Left String
"Cannot decode SQL null as the Haskell Vector type. Use a `Maybe (Vector (Vector a))`"
                Just ByteString
bs -> case Parser (Vector (Vector a))
-> ByteString -> ParseResult (Vector (Vector a))
forall a. Parser a -> ByteString -> ParseResult a
Parser.parseOnly Parser (Vector (Vector a))
arrayFieldDecoder ByteString
bs of
                  Parser.ParseOk Vector (Vector a)
v -> Vector (Vector a) -> Either String (Vector (Vector a))
forall a b. b -> Either a b
Right Vector (Vector a)
v
                  Parser.ParseFail String
err -> String -> Either String (Vector (Vector a))
forall a b. a -> Either a b
Left String
err,
        allowedPgTypes :: FieldInfo -> Bool
allowedPgTypes = FieldInfo -> Bool
allowOnlyArrayTypes
      }
    where
      !elementParser :: FieldDecoder a
elementParser = forall a. FromPgField a => FieldDecoder a
fieldDecoder @a
      arrayParser :: EncodingContext -> Parser.Parser (Vector (Vector a))
      arrayParser :: EncodingContext -> Parser (Vector (Vector a))
arrayParser EncodingContext
encodingContext = do
        !ndim <- Parser Int32
int32Parser
        !_hasNull <- int32Parser
        !elementTypeOid :: Oid <- Oid . fromIntegral <$> int32Parser
        let !elementColInfo = Oid -> Maybe Text -> EncodingContext -> FieldInfo
FieldInfo Oid
elementTypeOid Maybe Text
forall a. Maybe a
Nothing EncodingContext
encodingContext
        when (ndim /= 2) $ fail $ "TODO: No support for " ++ show ndim ++ "-dimensional arrays in Hpgsql. Got array with ndim=" ++ show ndim
        unless (elementParser.allowedPgTypes elementColInfo) $ fail $ "Array contains elements of type OID " ++ show elementTypeOid ++ " but decoder does not handle that type"
        numRows <- do
          !dim_i :: Int <- fromIntegral <$> int32Parser
          !_lb_i <- int32Parser
          pure dim_i
        lengthEachRow <- do
          !dim_i :: Int <- fromIntegral <$> int32Parser
          !_lb_i <- int32Parser
          pure dim_i

        Vector.replicateM numRows $ do
          Vector.replicateM lengthEachRow $
            do
              size :: Int <- fromIntegral <$> int32Parser
              elementBs <- if size == (-1) then pure Nothing else Just <$> Parser.take size
              case elementParser.fieldValueDecoder elementColInfo elementBs of
                Left String
err -> String -> Parser a
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser a) -> String -> Parser a
forall a b. (a -> b) -> a -> b
$ String
"Error parsing array element: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
err
                Right a
el -> a -> Parser a
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
el

int16Parser :: Parser.Parser Int16
int16Parser :: Parser Int16
int16Parser = (String -> Parser Int16)
-> (Int16 -> Parser Int16) -> Either String Int16 -> Parser Int16
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Parser Int16
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail Int16 -> Parser Int16
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String Int16 -> Parser Int16)
-> (ByteString -> Either String Int16)
-> ByteString
-> Parser Int16
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Serialize a => ByteString -> Either String a
Cereal.decode @Int16 (ByteString -> Parser Int16) -> Parser ByteString -> Parser Int16
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Int -> Parser ByteString
Parser.take Int
2

-- | Derives `FromPgRow` generically.
genericFromPgRow :: forall a. (Generic a, ProductTypeDecoder (Rep a)) => RowDecoder a
genericFromPgRow :: forall a. (Generic a, ProductTypeDecoder (Rep a)) => RowDecoder a
genericFromPgRow = Rep a (ZonkAny 3) -> a
forall a x. Generic a => Rep a x -> a
forall x. Rep a x -> a
to (Rep a (ZonkAny 3) -> a)
-> RowDecoder (Rep a (ZonkAny 3)) -> RowDecoder a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. ProductTypeDecoder f => RowDecoder (f a)
genRowDecoder @(Rep a)

class ProductTypeDecoder f where
  genRowDecoder :: RowDecoder (f a)

instance (ProductTypeDecoder a, ProductTypeDecoder b) => ProductTypeDecoder (a :*: b) where
  genRowDecoder :: forall a. RowDecoder ((:*:) a b a)
genRowDecoder = a a -> b a -> (:*:) a b a
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:) (a a -> b a -> (:*:) a b a)
-> RowDecoder (a a) -> RowDecoder (b a -> (:*:) a b a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RowDecoder (a a)
forall a. RowDecoder (a a)
forall (f :: * -> *) a. ProductTypeDecoder f => RowDecoder (f a)
genRowDecoder RowDecoder (b a -> (:*:) a b a)
-> RowDecoder (b a) -> RowDecoder ((:*:) a b a)
forall a b. RowDecoder (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RowDecoder (b a)
forall a. RowDecoder (b a)
forall (f :: * -> *) a. ProductTypeDecoder f => RowDecoder (f a)
genRowDecoder

instance (ProductTypeDecoder f) => ProductTypeDecoder (M1 a c f) where
  genRowDecoder :: forall a. RowDecoder (M1 a c f a)
genRowDecoder = f a -> M1 a c f a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f a -> M1 a c f a) -> RowDecoder (f a) -> RowDecoder (M1 a c f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RowDecoder (f a)
forall a. RowDecoder (f a)
forall (f :: * -> *) a. ProductTypeDecoder f => RowDecoder (f a)
genRowDecoder

instance (FromPgField a) => ProductTypeDecoder (K1 r a) where
  genRowDecoder :: forall a. RowDecoder (K1 r a a)
genRowDecoder = (a -> K1 r a a) -> RowDecoder a -> RowDecoder (K1 r a a)
forall a b. (a -> b) -> RowDecoder a -> RowDecoder b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> K1 r a a
forall k i c (p :: k). c -> K1 i c p
K1 (RowDecoder a -> RowDecoder (K1 r a a))
-> RowDecoder a -> RowDecoder (K1 r a a)
forall a b. (a -> b) -> a -> b
$ FieldDecoder a -> RowDecoder a
forall a. FieldDecoder a -> RowDecoder a
singleField (FieldDecoder a -> RowDecoder a) -> FieldDecoder a -> RowDecoder a
forall a b. (a -> b) -> a -> b
$ forall a. FromPgField a => FieldDecoder a
fieldDecoder @a

genericToPgRow :: forall a. (Generic a, ProductTypeEncoder (Rep a)) => RowEncoder a
genericToPgRow :: forall a. (Generic a, ProductTypeEncoder (Rep a)) => RowEncoder a
genericToPgRow = (a -> Rep a (ZonkAny 2))
-> RowEncoder (Rep a (ZonkAny 2)) -> RowEncoder a
forall a' a. (a' -> a) -> RowEncoder a -> RowEncoder a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap a -> Rep a (ZonkAny 2)
forall x. a -> Rep a x
forall a x. Generic a => a -> Rep a x
from RowEncoder (Rep a (ZonkAny 2))
forall a. RowEncoder (Rep a a)
forall (f :: * -> *) a. ProductTypeEncoder f => RowEncoder (f a)
genRowEncoder

class ProductTypeEncoder f where
  genRowEncoder :: RowEncoder (f a)

instance (ProductTypeEncoder a, ProductTypeEncoder b) => ProductTypeEncoder (a :*: b) where
  genRowEncoder :: forall a. RowEncoder ((:*:) a b a)
genRowEncoder = ((:*:) a b a -> (a a, b a))
-> RowEncoder (a a) -> RowEncoder (b a) -> RowEncoder ((:*:) a b a)
forall a b c.
(a -> (b, c)) -> RowEncoder b -> RowEncoder c -> RowEncoder a
divide (\(a a
a :*: b a
b) -> (a a
a, b a
b)) RowEncoder (a a)
forall a. RowEncoder (a a)
forall (f :: * -> *) a. ProductTypeEncoder f => RowEncoder (f a)
genRowEncoder RowEncoder (b a)
forall a. RowEncoder (b a)
forall (f :: * -> *) a. ProductTypeEncoder f => RowEncoder (f a)
genRowEncoder

instance (ProductTypeEncoder f) => ProductTypeEncoder (M1 i c f) where
  genRowEncoder :: forall a. RowEncoder (M1 i c f a)
genRowEncoder = (M1 i c f a -> f a) -> RowEncoder (f a) -> RowEncoder (M1 i c f a)
forall a' a. (a' -> a) -> RowEncoder a -> RowEncoder a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap M1 i c f a -> f a
forall k i (c :: Meta) (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1 RowEncoder (f a)
forall a. RowEncoder (f a)
forall (f :: * -> *) a. ProductTypeEncoder f => RowEncoder (f a)
genRowEncoder

instance (ToPgField a) => ProductTypeEncoder (K1 r a) where
  genRowEncoder :: forall a. RowEncoder (K1 r a a)
genRowEncoder = (K1 r a a -> a) -> RowEncoder a -> RowEncoder (K1 r a a)
forall a' a. (a' -> a) -> RowEncoder a -> RowEncoder a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap K1 r a a -> a
forall k i c (p :: k). K1 i c p -> c
unK1 RowEncoder a
forall a. ToPgField a => RowEncoder a
singleFieldRowEncoder

-- | For the very common case of a Haskell enum matching a custom postgres enum type
-- that has its values all as lower case strings, this newtype can help you derive
-- instances as such:
--
-- > data Mood = Sad | Ok | Happy
-- >   deriving stock (Generic)
-- >   deriving (FromPgField, ToPgField) via (LowerCasedPgEnum Mood)
--
-- And this would match the Postgres equivalent:
--
-- > CREATE TYPE mood AS ENUM ('sad', 'ok', 'happy');
--
-- If you run into PostgreSQL type inference problems with this, you can
-- write instances manually with 'genericEnumFieldDecoder', 'genericEnumFieldEncoder',
-- 'typeFieldEncoder', and 'typeFieldDecoder'.
newtype LowerCasedPgEnum a = LowerCasedPgEnum a

instance (Generic a, EnumDecoder (Rep a)) => FromPgField (LowerCasedPgEnum a) where
  fieldDecoder :: FieldDecoder (LowerCasedPgEnum a)
fieldDecoder = a -> LowerCasedPgEnum a
forall a. a -> LowerCasedPgEnum a
LowerCasedPgEnum (a -> LowerCasedPgEnum a)
-> FieldDecoder a -> FieldDecoder (LowerCasedPgEnum a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> Text) -> FieldDecoder a
forall a.
(Generic a, EnumDecoder (Rep a)) =>
(Text -> Text) -> FieldDecoder a
genericEnumFieldDecoder Text -> Text
LT.toLower

instance (Generic a, EnumEncoder (Rep a)) => ToPgField (LowerCasedPgEnum a) where
  fieldEncoder :: FieldEncoder (LowerCasedPgEnum a)
fieldEncoder = (EncodingContext -> LowerCasedPgEnum a -> BinaryField)
-> FieldEncoder (LowerCasedPgEnum a)
forall a. (EncodingContext -> a -> BinaryField) -> FieldEncoder a
untypedFieldEncoder ((EncodingContext -> LowerCasedPgEnum a -> BinaryField)
 -> FieldEncoder (LowerCasedPgEnum a))
-> (EncodingContext -> LowerCasedPgEnum a -> BinaryField)
-> FieldEncoder (LowerCasedPgEnum a)
forall a b. (a -> b) -> a -> b
$ \EncodingContext
_encCtx -> \(LowerCasedPgEnum a
v) -> ByteString -> BinaryField
NotNull (ByteString -> BinaryField) -> ByteString -> BinaryField
forall a b. (a -> b) -> a -> b
$ (Text -> Text) -> a -> ByteString
forall a.
(Generic a, EnumEncoder (Rep a)) =>
(Text -> Text) -> a -> ByteString
genericEnumFieldEncoder Text -> Text
Text.toLower a
v

-- | One of the functions behind 'LowerCasedPgEnum', but you can decide
-- how to map your type's constructor names arbitrarily, which can be
-- useful if you're not using lowercase values in your postgres enums.
genericEnumFieldDecoder ::
  forall a.
  (Generic a, EnumDecoder (Rep a)) =>
  -- | A function that takes in the Haskell constructor name and returns the textual representation of the enum in postgres
  (LT.Text -> LT.Text) ->
  FieldDecoder a
genericEnumFieldDecoder :: forall a.
(Generic a, EnumDecoder (Rep a)) =>
(Text -> Text) -> FieldDecoder a
genericEnumFieldDecoder Text -> Text
nameTransform = a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe (String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"Invalid enum value. Not one of " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [ByteString] -> String
forall a. Show a => a -> String
show (Map ByteString a -> [ByteString]
forall k a. Map k a -> [k]
Map.keys Map ByteString a
allValuesMap)) (Maybe a -> a) -> (ByteString -> Maybe a) -> ByteString -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> Map ByteString a -> Maybe a)
-> Map ByteString a -> ByteString -> Maybe a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ByteString -> Map ByteString a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Map ByteString a
allValuesMap (ByteString -> a) -> FieldDecoder ByteString -> FieldDecoder a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FieldDecoder ByteString
rawBytesFieldDecoder
  where
    -- TODO: Vector of pointers to ByteStrings for a bit more memory locality? Does it make a perf difference?
    allValuesMap :: Map ByteString a
allValuesMap = (Text -> ByteString) -> Map Text a -> Map ByteString a
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeys (ByteString -> ByteString
LBS.toStrict (ByteString -> ByteString)
-> (Text -> ByteString) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
LT.encodeUtf8 (Text -> ByteString) -> (Text -> Text) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
nameTransform) (Map Text a -> Map ByteString a) -> Map Text a -> Map ByteString a
forall a b. (a -> b) -> a -> b
$ (Rep a (ZonkAny 1) -> a)
-> Map Text (Rep a (ZonkAny 1)) -> Map Text a
forall a b. (a -> b) -> Map Text a -> Map Text b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Rep a (ZonkAny 1) -> a
forall a x. Generic a => Rep a x -> a
forall x. Rep a x -> a
to Map Text (Rep a (ZonkAny 1))
forall a. Map Text (Rep a a)
forall (f :: * -> *) a. EnumDecoder f => Map Text (f a)
genEnumDecoder

class EnumDecoder f where
  -- | Returns the textual representation and constructed object for every possible
  -- value of the enum.
  genEnumDecoder :: Map LT.Text (f a)

instance (EnumDecoder a, EnumDecoder b) => EnumDecoder (a :+: b) where
  genEnumDecoder :: forall a. Map Text ((:+:) a b a)
genEnumDecoder = (a a -> (:+:) a b a
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (a a -> (:+:) a b a) -> Map Text (a a) -> Map Text ((:+:) a b a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Text (a a)
forall a. Map Text (a a)
forall (f :: * -> *) a. EnumDecoder f => Map Text (f a)
genEnumDecoder) Map Text ((:+:) a b a)
-> Map Text ((:+:) a b a) -> Map Text ((:+:) a b a)
forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` (b a -> (:+:) a b a
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (b a -> (:+:) a b a) -> Map Text (b a) -> Map Text ((:+:) a b a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Text (b a)
forall a. Map Text (b a)
forall (f :: * -> *) a. EnumDecoder f => Map Text (f a)
genEnumDecoder)

instance (EnumDecoder f) => EnumDecoder (M1 D c f) where
  genEnumDecoder :: forall a. Map Text (M1 D c f a)
genEnumDecoder = f a -> M1 D c f a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f a -> M1 D c f a) -> Map Text (f a) -> Map Text (M1 D c f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Text (f a)
forall a. Map Text (f a)
forall (f :: * -> *) a. EnumDecoder f => Map Text (f a)
genEnumDecoder

-- U1 is "Unit"-type, that is: no value in the constructor, AKA "pure enum".
instance (KnownSymbol ctorName) => EnumDecoder (M1 C ('MetaCons ctorName ctorFixity 'False) U1) where
  genEnumDecoder :: forall a.
Map Text (M1 C ('MetaCons ctorName ctorFixity 'False) U1 a)
genEnumDecoder = Text
-> M1 C ('MetaCons ctorName ctorFixity 'False) U1 a
-> Map Text (M1 C ('MetaCons ctorName ctorFixity 'False) U1 a)
forall k a. k -> a -> Map k a
Map.singleton (String -> Text
LT.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Proxy ctorName -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @ctorName)) (U1 a -> M1 C ('MetaCons ctorName ctorFixity 'False) U1 a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 U1 a
forall k (p :: k). U1 p
U1)

-- | One of the functions behind 'LowerCasedPgEnum', but you can decide
-- how to map your type's constructor names arbitrarily, which can be
-- useful if you're not using lowercase values in your postgres enums.
genericEnumFieldEncoder ::
  forall a.
  (Generic a, EnumEncoder (Rep a)) =>
  -- | A function that takes in the Haskell constructor name and returns the textual representation of the enum in postgres
  (Text -> Text) ->
  a ->
  ByteString
genericEnumFieldEncoder :: forall a.
(Generic a, EnumEncoder (Rep a)) =>
(Text -> Text) -> a -> ByteString
genericEnumFieldEncoder Text -> Text
nameTransform = Text -> ByteString
encodeUtf8 (Text -> ByteString) -> (a -> Text) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
nameTransform (Text -> Text) -> (a -> Text) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rep a (ZonkAny 0) -> Text
forall a. Rep a a -> Text
forall (f :: * -> *) a. EnumEncoder f => f a -> Text
genEnumEncoder (Rep a (ZonkAny 0) -> Text)
-> (a -> Rep a (ZonkAny 0)) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Rep a (ZonkAny 0)
forall x. a -> Rep a x
forall a x. Generic a => a -> Rep a x
from

class EnumEncoder f where
  -- | Returns the textual representation of an enum value's constructor.
  genEnumEncoder :: f a -> Text

instance (EnumEncoder a, EnumEncoder b) => EnumEncoder (a :+: b) where
  genEnumEncoder :: forall a. (:+:) a b a -> Text
genEnumEncoder (L1 a a
x) = a a -> Text
forall a. a a -> Text
forall (f :: * -> *) a. EnumEncoder f => f a -> Text
genEnumEncoder a a
x
  genEnumEncoder (R1 b a
x) = b a -> Text
forall a. b a -> Text
forall (f :: * -> *) a. EnumEncoder f => f a -> Text
genEnumEncoder b a
x

instance (EnumEncoder f) => EnumEncoder (M1 D c f) where
  genEnumEncoder :: forall a. M1 D c f a -> Text
genEnumEncoder (M1 f a
x) = f a -> Text
forall a. f a -> Text
forall (f :: * -> *) a. EnumEncoder f => f a -> Text
genEnumEncoder f a
x

-- U1 is "Unit"-type, that is: no value in the constructor, AKA "pure enum".
instance (KnownSymbol ctorName) => EnumEncoder (M1 C ('MetaCons ctorName ctorFixity 'False) U1) where
  genEnumEncoder :: forall a. M1 C ('MetaCons ctorName ctorFixity 'False) U1 a -> Text
genEnumEncoder M1 C ('MetaCons ctorName ctorFixity 'False) U1 a
_ = String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Proxy ctorName -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @ctorName)

-- | Returns a `FieldEncoder` that is sent without a type OID in queries.
-- This means postgres will try to infer the type of these arguments.
-- Check `typedFieldEncoder` if you're interested in encoding your custom types,
-- you probably don't need this.
untypedFieldEncoder :: (EncodingContext -> a -> BinaryField) -> FieldEncoder a
untypedFieldEncoder :: forall a. (EncodingContext -> a -> BinaryField) -> FieldEncoder a
untypedFieldEncoder EncodingContext -> a -> BinaryField
enc = FieldEncoder {toTypeOid :: EncodingContext -> Maybe Oid
toTypeOid = \EncodingContext
_ -> Maybe Oid
forall a. Maybe a
Nothing, toPgField :: EncodingContext -> a -> BinaryField
toPgField = EncodingContext -> a -> BinaryField
enc}

-- | A decoder that accepts any PG type and returns the object's
-- postgres' binary representation as a ByteString.
rawBytesFieldDecoder :: FieldDecoder ByteString
rawBytesFieldDecoder :: FieldDecoder ByteString
rawBytesFieldDecoder =
  FieldDecoder
    { fieldValueDecoder :: FieldInfo -> Maybe ByteString -> Either String ByteString
fieldValueDecoder = \FieldInfo
_oid -> \case
        Maybe ByteString
Nothing -> String -> Either String ByteString
forall a b. a -> Either a b
Left String
"Cannot decode SQL null as the `rawBytesFieldDecoder`."
        Just ByteString
bs -> ByteString -> Either String ByteString
forall a b. b -> Either a b
Right ByteString
bs,
      allowedPgTypes :: FieldInfo -> Bool
allowedPgTypes = Bool -> FieldInfo -> Bool
forall a b. a -> b -> a
const Bool
True
    }

-- | Returns a field-encoding function for a vector-like Foldable (e.g. Lists and Vector itself).
toPgVectorField :: forall f a. (Foldable f, ToPgField a) => EncodingContext -> f a -> BinaryField
toPgVectorField :: forall (f :: * -> *) a.
(Foldable f, ToPgField a) =>
EncodingContext -> f a -> BinaryField
toPgVectorField EncodingContext
encCtx =
  let fe :: FieldEncoder a
fe = forall a. ToPgField a => FieldEncoder a
fieldEncoder @a
      encodeElement :: a -> LengthAwareBuilder
encodeElement a
el = BinaryField -> LengthAwareBuilder
Builder.binaryField (BinaryField -> LengthAwareBuilder)
-> BinaryField -> LengthAwareBuilder
forall a b. (a -> b) -> a -> b
$ FieldEncoder a
fe.toPgField EncodingContext
encCtx a
el
      Oid Int32
elemOid = Oid -> Maybe Oid -> Oid
forall a. a -> Maybe a -> a
fromMaybe (Int32 -> Oid
Oid Int32
0) (FieldEncoder a
fe.toTypeOid EncodingContext
encCtx)
   in \f a
vec ->
        let ndim :: LengthAwareBuilder
ndim = ByteString -> LengthAwareBuilder
Builder.byteString (ByteString -> LengthAwareBuilder)
-> ByteString -> LengthAwareBuilder
forall a b. (a -> b) -> a -> b
$ forall a. Serialize a => a -> ByteString
Cereal.encode @Int32 Int32
1
            -- Postgres seems to build the "has_nulls" flag itself in the ReadArrayBinary function at https://github.com/postgres/postgres/blob/aa7f9493a02f5981c09b924323f0e7a58a32f2ed/src/backend/utils/adt/arrayfuncs.c#L1429, so we can just set it to 0
            hasNull :: LengthAwareBuilder
hasNull = ByteString -> LengthAwareBuilder
Builder.byteString (ByteString -> LengthAwareBuilder)
-> ByteString -> LengthAwareBuilder
forall a b. (a -> b) -> a -> b
$ forall a. Serialize a => a -> ByteString
Cereal.encode @Int32 Int32
0
            -- hasNull = Builder.byteString $ Cereal.encode @Int32 (if Vector.any (\e -> toPgField e == Nothing) vec then 1 else 0)
            elemOidBs :: LengthAwareBuilder
elemOidBs = ByteString -> LengthAwareBuilder
Builder.byteString (ByteString -> LengthAwareBuilder)
-> ByteString -> LengthAwareBuilder
forall a b. (a -> b) -> a -> b
$ forall a. Serialize a => a -> ByteString
Cereal.encode @Int32 Int32
elemOid
            lb1 :: LengthAwareBuilder
lb1 = ByteString -> LengthAwareBuilder
Builder.byteString (ByteString -> LengthAwareBuilder)
-> ByteString -> LengthAwareBuilder
forall a b. (a -> b) -> a -> b
$ forall a. Serialize a => a -> ByteString
Cereal.encode @Int32 Int32
1
            (Sum Int32
len, LengthAwareBuilder
encodedElements) = (a -> (Sum Int32, LengthAwareBuilder))
-> f a -> (Sum Int32, LengthAwareBuilder)
forall m a. Monoid m => (a -> m) -> f a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\a
el -> (Int32 -> Sum Int32
forall a. a -> Sum a
Sum Int32
1, a -> LengthAwareBuilder
encodeElement a
el)) f a
vec
            dim1 :: LengthAwareBuilder
dim1 = ByteString -> LengthAwareBuilder
Builder.byteString (ByteString -> LengthAwareBuilder)
-> ByteString -> LengthAwareBuilder
forall a b. (a -> b) -> a -> b
$ forall a. Serialize a => a -> ByteString
Cereal.encode @Int32 Int32
len
            fullBs :: LengthAwareBuilder
fullBs = LengthAwareBuilder
ndim LengthAwareBuilder -> LengthAwareBuilder -> LengthAwareBuilder
forall a. Semigroup a => a -> a -> a
<> LengthAwareBuilder
hasNull LengthAwareBuilder -> LengthAwareBuilder -> LengthAwareBuilder
forall a. Semigroup a => a -> a -> a
<> LengthAwareBuilder
elemOidBs LengthAwareBuilder -> LengthAwareBuilder -> LengthAwareBuilder
forall a. Semigroup a => a -> a -> a
<> LengthAwareBuilder
dim1 LengthAwareBuilder -> LengthAwareBuilder -> LengthAwareBuilder
forall a. Semigroup a => a -> a -> a
<> LengthAwareBuilder
lb1 LengthAwareBuilder -> LengthAwareBuilder -> LengthAwareBuilder
forall a. Semigroup a => a -> a -> a
<> LengthAwareBuilder
encodedElements
         in ByteString -> BinaryField
NotNull (LengthAwareBuilder -> ByteString
Builder.toStrictByteString LengthAwareBuilder
fullBs)

-- | A FieldDecoder that accepts and decodes Postgres arrays.
arrayField :: forall a f. (Monoid (f a)) => (forall m. (Monad m) => Int -> m a -> m (f a)) -> FieldDecoder a -> FieldDecoder (f a)
arrayField :: forall a (f :: * -> *).
Monoid (f a) =>
(forall (m :: * -> *). Monad m => Int -> m a -> m (f a))
-> FieldDecoder a -> FieldDecoder (f a)
arrayField !forall (m :: * -> *). Monad m => Int -> m a -> m (f a)
replicateFunction !FieldDecoder a
elementParser =
  -- From https://github.com/postgres/postgres/blob/5941946d0934b9eccb0d5bfebd40b155249a0130/src/backend/utils/adt/arrayfuncs.c#L1548
  FieldDecoder
    { fieldValueDecoder :: FieldInfo -> Maybe ByteString -> Either String (f a)
fieldValueDecoder = \FieldInfo
colInfo ->
        let !arrayFieldDecoder :: Parser (f a)
arrayFieldDecoder = EncodingContext -> Parser (f a)
arrayParser FieldInfo
colInfo.encodingContext Parser (f a) -> Parser () -> Parser (f a)
forall a b. Parser a -> Parser b -> Parser a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
Parser.endOfInput
         in \case
              Maybe ByteString
Nothing -> String -> Either String (f a)
forall a b. a -> Either a b
Left String
"Cannot decode SQL null as the Haskell Vector type. Use a `Maybe (Vector a)`"
              Just ByteString
bs -> case Parser (f a) -> ByteString -> ParseResult (f a)
forall a. Parser a -> ByteString -> ParseResult a
Parser.parseOnly Parser (f a)
arrayFieldDecoder ByteString
bs of
                Parser.ParseOk f a
v -> f a -> Either String (f a)
forall a b. b -> Either a b
Right f a
v
                Parser.ParseFail String
err -> String -> Either String (f a)
forall a b. a -> Either a b
Left String
err,
      allowedPgTypes :: FieldInfo -> Bool
allowedPgTypes = FieldInfo -> Bool
allowOnlyArrayTypes
    }
  where
    arrayParser :: EncodingContext -> Parser.Parser (f a)
    arrayParser :: EncodingContext -> Parser (f a)
arrayParser EncodingContext
encodingContext = do
      !ndim <- Parser Int32
int32Parser
      !_hasNull <- int32Parser
      !elementTypeOid :: Oid <- Oid . fromIntegral <$> int32Parser
      let !elementColInfo = Oid -> Maybe Text -> EncodingContext -> FieldInfo
FieldInfo Oid
elementTypeOid Maybe Text
forall a. Maybe a
Nothing EncodingContext
encodingContext
      when (ndim > 1) $ fail $ "TODO: No support for multi-dimensional arrays in Hpgsql. Got array with ndim=" ++ show ndim
      if ndim == 0
        then pure mempty
        else do
          !dim_i :: Int <- fromIntegral <$> int32Parser
          !_lb_i <- int32Parser
          unless (elementParser.allowedPgTypes elementColInfo) $ fail $ "Array contains elements of type OID " ++ show elementTypeOid ++ " but decoder does not handle that type"
          replicateFunction dim_i $ do
            size :: Int <- fromIntegral <$> int32Parser
            elementBs <- if size == (-1) then pure Nothing else Just <$> Parser.take size
            case elementParser.fieldValueDecoder elementColInfo elementBs of
              Left String
err -> String -> Parser a
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser a) -> String -> Parser a
forall a b. (a -> b) -> a -> b
$ String
"Error parsing array element: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
err
              Right a
el -> a -> Parser a
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
el