module PostgreSQL.Binary.Decoding
  ( valueParser,
    --
    Value,

    -- * Primitive
    int,
    float4,
    float8,
    bool,
    bytea_strict,
    bytea_lazy,

    -- * Textual
    text_strict,
    text_lazy,
    char,

    -- * Misc
    fn,
    numeric,
    uuid,
    inet,
    macaddr,
    json_ast,
    json_bytes,
    jsonb_ast,
    jsonb_bytes,

    -- * Time
    date,
    time_int,
    time_float,
    timetz_int,
    timetz_float,
    timestamp_int,
    timestamp_float,
    timestamptz_int,
    timestamptz_float,
    interval_int,
    interval_float,

    -- * Exotic

    -- ** Array
    Array,
    array,
    valueArray,
    nullableValueArray,
    dimensionArray,

    -- ** Composite
    Composite,
    composite,
    valueComposite,
    nullableValueComposite,
    typedValueComposite,
    typedNullableValueComposite,

    -- ** HStore
    hstore,
    enum,
    refine,

    -- ** Range
    int4range,
    int8range,
    numrange,
    tsrange_int,
    tsrange_float,
    tstzrange_int,
    tstzrange_float,
    daterange,

    -- ** Multirange
    int4multirange,
    int8multirange,
    nummultirange,
    tsmultirange_int,
    tsmultirange_float,
    tstzmultirange_int,
    tstzmultirange_float,
    datemultirange,
  )
where

import BinaryParser
import Control.Monad.Error.Class
import qualified Data.Aeson as Aeson
import qualified Data.ByteString as ByteString
import qualified Data.ByteString.Lazy as LazyByteString
import qualified Data.IP as IP
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import qualified Data.Text.Encoding.Error as Text
import qualified Data.Text.Lazy.Encoding as LazyText
import qualified Data.UUID as UUID
import qualified Data.Vector as Vector
import qualified PostgreSQL.Binary.Inet as Inet
import qualified PostgreSQL.Binary.Integral as Integral
import qualified PostgreSQL.Binary.Interval as Interval
import qualified PostgreSQL.Binary.Numeric as Numeric
import PostgreSQL.Binary.Prelude hiding (bool, drop, fail, state, take)
import qualified PostgreSQL.Binary.Range as Range
import qualified PostgreSQL.Binary.Time as Time

type Value =
  BinaryParser

valueParser :: Value a -> ByteString -> Either Text a
valueParser :: forall a. Value a -> ByteString -> Either Text a
valueParser =
  BinaryParser a -> ByteString -> Either Text a
forall a. Value a -> ByteString -> Either Text a
BinaryParser.run

-- * Helpers

-- |
-- Any int number of a limited byte-size.
{-# INLINE intOfSize #-}
intOfSize :: (Integral a, Bits a) => Int -> Value a
intOfSize :: forall a. (Integral a, Bits a) => Int -> Value a
intOfSize Int
x =
  (ByteString -> a) -> BinaryParser ByteString -> BinaryParser a
forall a b. (a -> b) -> BinaryParser a -> BinaryParser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> a
forall a. (Bits a, Num a) => ByteString -> a
Integral.pack (Int -> BinaryParser ByteString
bytesOfSize Int
x)

{-# INLINEABLE onContent #-}
onContent :: Value a -> Value (Maybe a)
onContent :: forall a. Value a -> Value (Maybe a)
onContent Value a
decoder =
  Value Int32
size
    Value Int32
-> (Int32 -> BinaryParser (Maybe a)) -> BinaryParser (Maybe a)
forall a b.
BinaryParser a -> (a -> BinaryParser b) -> BinaryParser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      (-1) -> Maybe a -> BinaryParser (Maybe a)
forall a. a -> BinaryParser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
      Int32
n -> (a -> Maybe a) -> Value a -> BinaryParser (Maybe a)
forall a b. (a -> b) -> BinaryParser a -> BinaryParser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Maybe a
forall a. a -> Maybe a
Just (Int -> Value a -> Value a
forall a. Int -> BinaryParser a -> BinaryParser a
sized (Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
n) Value a
decoder)
  where
    size :: Value Int32
size =
      Int -> Value Int32
forall a. (Integral a, Bits a) => Int -> Value a
intOfSize Int
4 :: Value Int32

{-# INLINE nonNull #-}
nonNull :: Maybe a -> Value a
nonNull :: forall a. Maybe a -> Value a
nonNull =
  Value a -> (a -> Value a) -> Maybe a -> Value a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> Value a
forall a. Text -> BinaryParser a
failure Text
"Unexpected NULL") a -> Value a
forall a. a -> BinaryParser a
forall (m :: * -> *) a. Monad m => a -> m a
return

-- * Primitive

-- |
-- Lifts a custom decoder implementation.
{-# INLINE fn #-}
fn :: (ByteString -> Either Text a) -> Value a
fn :: forall a. (ByteString -> Either Text a) -> Value a
fn ByteString -> Either Text a
fn =
  BinaryParser ByteString
BinaryParser.remainders BinaryParser ByteString
-> (ByteString -> BinaryParser a) -> BinaryParser a
forall a b.
BinaryParser a -> (a -> BinaryParser b) -> BinaryParser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Text -> BinaryParser a)
-> (a -> BinaryParser a) -> Either Text a -> BinaryParser a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Text -> BinaryParser a
forall a. Text -> BinaryParser a
BinaryParser.failure a -> BinaryParser a
forall a. a -> BinaryParser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text a -> BinaryParser a)
-> (ByteString -> Either Text a) -> ByteString -> BinaryParser a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ByteString -> Either Text a
fn

{-# INLINE int #-}
int :: (Integral a, Bits a) => Value a
int :: forall a. (Integral a, Bits a) => Value a
int =
  (ByteString -> a) -> BinaryParser ByteString -> BinaryParser a
forall a b. (a -> b) -> BinaryParser a -> BinaryParser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> a
forall a. (Bits a, Num a) => ByteString -> a
Integral.pack BinaryParser ByteString
remainders

float4 :: Value Float
float4 :: Value Float
float4 =
  Value Int32 -> Value Float
forall a b. a -> b
unsafeCoerce (Value Int32
forall a. (Integral a, Bits a) => Value a
int :: Value Int32)

float8 :: Value Double
float8 :: Value Double
float8 =
  Value Int64 -> Value Double
forall a b. a -> b
unsafeCoerce (Value Int64
forall a. (Integral a, Bits a) => Value a
int :: Value Int64)

{-# INLINE bool #-}
bool :: Value Bool
bool :: Value Bool
bool =
  (Word8 -> Bool) -> BinaryParser Word8 -> Value Bool
forall a b. (a -> b) -> BinaryParser a -> BinaryParser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
1) BinaryParser Word8
byte

{-# NOINLINE numeric #-}
numeric :: Value Scientific
numeric :: Value Scientific
numeric =
  do
    componentsAmount <- Int -> Value Int
forall a. (Integral a, Bits a) => Int -> Value a
intOfSize Int
2
    pointIndex <- intOfSize 2
    signCode <- intOfSize 2
    unitOfSize 2
    components <- Vector.replicateM componentsAmount (intOfSize 2)
    either failure return (Numeric.scientific pointIndex signCode components)

{-# INLINEABLE uuid #-}
uuid :: Value UUID
uuid :: Value UUID
uuid =
  Word32 -> Word32 -> Word32 -> Word32 -> UUID
UUID.fromWords (Word32 -> Word32 -> Word32 -> Word32 -> UUID)
-> BinaryParser Word32
-> BinaryParser (Word32 -> Word32 -> Word32 -> UUID)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> BinaryParser Word32
forall a. (Integral a, Bits a) => Int -> Value a
intOfSize Int
4 BinaryParser (Word32 -> Word32 -> Word32 -> UUID)
-> BinaryParser Word32 -> BinaryParser (Word32 -> Word32 -> UUID)
forall a b.
BinaryParser (a -> b) -> BinaryParser a -> BinaryParser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> BinaryParser Word32
forall a. (Integral a, Bits a) => Int -> Value a
intOfSize Int
4 BinaryParser (Word32 -> Word32 -> UUID)
-> BinaryParser Word32 -> BinaryParser (Word32 -> UUID)
forall a b.
BinaryParser (a -> b) -> BinaryParser a -> BinaryParser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> BinaryParser Word32
forall a. (Integral a, Bits a) => Int -> Value a
intOfSize Int
4 BinaryParser (Word32 -> UUID) -> BinaryParser Word32 -> Value UUID
forall a b.
BinaryParser (a -> b) -> BinaryParser a -> BinaryParser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> BinaryParser Word32
forall a. (Integral a, Bits a) => Int -> Value a
intOfSize Int
4

{-# INLINE ip4 #-}
ip4 :: Value IP.IPv4
ip4 :: Value IPv4
ip4 =
  Word32 -> IPv4
IP.toIPv4w (Word32 -> IPv4) -> BinaryParser Word32 -> Value IPv4
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> BinaryParser Word32
forall a. (Integral a, Bits a) => Int -> Value a
intOfSize Int
4

{-# INLINE ip6 #-}
ip6 :: Value IP.IPv6
ip6 :: Value IPv6
ip6 =
  (Word32, Word32, Word32, Word32) -> IPv6
IP.toIPv6w ((Word32, Word32, Word32, Word32) -> IPv6)
-> BinaryParser (Word32, Word32, Word32, Word32) -> Value IPv6
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((,,,) (Word32
 -> Word32 -> Word32 -> Word32 -> (Word32, Word32, Word32, Word32))
-> BinaryParser Word32
-> BinaryParser
     (Word32 -> Word32 -> Word32 -> (Word32, Word32, Word32, Word32))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> BinaryParser Word32
forall a. (Integral a, Bits a) => Int -> Value a
intOfSize Int
4 BinaryParser
  (Word32 -> Word32 -> Word32 -> (Word32, Word32, Word32, Word32))
-> BinaryParser Word32
-> BinaryParser
     (Word32 -> Word32 -> (Word32, Word32, Word32, Word32))
forall a b.
BinaryParser (a -> b) -> BinaryParser a -> BinaryParser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> BinaryParser Word32
forall a. (Integral a, Bits a) => Int -> Value a
intOfSize Int
4 BinaryParser (Word32 -> Word32 -> (Word32, Word32, Word32, Word32))
-> BinaryParser Word32
-> BinaryParser (Word32 -> (Word32, Word32, Word32, Word32))
forall a b.
BinaryParser (a -> b) -> BinaryParser a -> BinaryParser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> BinaryParser Word32
forall a. (Integral a, Bits a) => Int -> Value a
intOfSize Int
4 BinaryParser (Word32 -> (Word32, Word32, Word32, Word32))
-> BinaryParser Word32
-> BinaryParser (Word32, Word32, Word32, Word32)
forall a b.
BinaryParser (a -> b) -> BinaryParser a -> BinaryParser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> BinaryParser Word32
forall a. (Integral a, Bits a) => Int -> Value a
intOfSize Int
4)

{-# INLINEABLE inet #-}
inet :: Value IP.IPRange
inet :: Value IPRange
inet = do
  af <- Int -> BinaryParser Word8
forall a. (Integral a, Bits a) => Int -> Value a
intOfSize Int
1
  netmask <- intOfSize 1
  isCidr <- intOfSize 1 :: Value Int -- unused
  ipSize <- intOfSize 1 :: Value Int -- unused
  if
    | af == Inet.inetAddressFamily ->
        do
          ip <- ip4
          return . IP.IPv4Range $ IP.makeAddrRange ip netmask
    | af == Inet.inet6AddressFamily ->
        do
          ip <- ip6
          return . IP.IPv6Range $ IP.makeAddrRange ip netmask
    | otherwise -> BinaryParser.failure ("Unknown address family: " <> fromString (show af))

{-# INLINEABLE macaddr #-}
macaddr :: Value (Word8, Word8, Word8, Word8, Word8, Word8)
macaddr :: Value (Word8, Word8, Word8, Word8, Word8, Word8)
macaddr =
  (,,,,,) (Word8
 -> Word8
 -> Word8
 -> Word8
 -> Word8
 -> Word8
 -> (Word8, Word8, Word8, Word8, Word8, Word8))
-> BinaryParser Word8
-> BinaryParser
     (Word8
      -> Word8
      -> Word8
      -> Word8
      -> Word8
      -> (Word8, Word8, Word8, Word8, Word8, Word8))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BinaryParser Word8
byte BinaryParser
  (Word8
   -> Word8
   -> Word8
   -> Word8
   -> Word8
   -> (Word8, Word8, Word8, Word8, Word8, Word8))
-> BinaryParser Word8
-> BinaryParser
     (Word8
      -> Word8
      -> Word8
      -> Word8
      -> (Word8, Word8, Word8, Word8, Word8, Word8))
forall a b.
BinaryParser (a -> b) -> BinaryParser a -> BinaryParser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BinaryParser Word8
byte BinaryParser
  (Word8
   -> Word8
   -> Word8
   -> Word8
   -> (Word8, Word8, Word8, Word8, Word8, Word8))
-> BinaryParser Word8
-> BinaryParser
     (Word8
      -> Word8 -> Word8 -> (Word8, Word8, Word8, Word8, Word8, Word8))
forall a b.
BinaryParser (a -> b) -> BinaryParser a -> BinaryParser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BinaryParser Word8
byte BinaryParser
  (Word8
   -> Word8 -> Word8 -> (Word8, Word8, Word8, Word8, Word8, Word8))
-> BinaryParser Word8
-> BinaryParser
     (Word8 -> Word8 -> (Word8, Word8, Word8, Word8, Word8, Word8))
forall a b.
BinaryParser (a -> b) -> BinaryParser a -> BinaryParser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BinaryParser Word8
byte BinaryParser
  (Word8 -> Word8 -> (Word8, Word8, Word8, Word8, Word8, Word8))
-> BinaryParser Word8
-> BinaryParser
     (Word8 -> (Word8, Word8, Word8, Word8, Word8, Word8))
forall a b.
BinaryParser (a -> b) -> BinaryParser a -> BinaryParser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BinaryParser Word8
byte BinaryParser (Word8 -> (Word8, Word8, Word8, Word8, Word8, Word8))
-> BinaryParser Word8
-> Value (Word8, Word8, Word8, Word8, Word8, Word8)
forall a b.
BinaryParser (a -> b) -> BinaryParser a -> BinaryParser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BinaryParser Word8
byte

{-# INLINEABLE json_ast #-}
json_ast :: Value Aeson.Value
json_ast :: Value Value
json_ast =
  BinaryParser ByteString
bytea_strict BinaryParser ByteString
-> (ByteString -> Value Value) -> Value Value
forall a b.
BinaryParser a -> (a -> BinaryParser b) -> BinaryParser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (String -> Value Value)
-> (Value -> Value Value) -> Either String Value -> Value Value
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> Value Value
forall a. Text -> BinaryParser a
BinaryParser.failure (Text -> Value Value) -> (String -> Text) -> String -> Value Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> Text
forall a. IsString a => String -> a
fromString) Value -> Value Value
forall a. a -> BinaryParser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String Value -> Value Value)
-> (ByteString -> Either String Value) -> ByteString -> Value Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ByteString -> Either String Value
forall a. FromJSON a => ByteString -> Either String a
Aeson.eitherDecodeStrict'

-- |
-- Given a function, which parses a plain UTF-8 JSON string encoded as a byte-array,
-- produces a decoder.
{-# INLINEABLE json_bytes #-}
json_bytes :: (ByteString -> Either Text a) -> Value a
json_bytes :: forall a. (ByteString -> Either Text a) -> Value a
json_bytes ByteString -> Either Text a
cont =
  BinaryParser ByteString
getAllBytes BinaryParser ByteString
-> (ByteString -> BinaryParser a) -> BinaryParser a
forall a b.
BinaryParser a -> (a -> BinaryParser b) -> BinaryParser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> BinaryParser a
parseJSON
  where
    getAllBytes :: BinaryParser ByteString
getAllBytes =
      BinaryParser ByteString
BinaryParser.remainders
    parseJSON :: ByteString -> BinaryParser a
parseJSON =
      (Text -> BinaryParser a)
-> (a -> BinaryParser a) -> Either Text a -> BinaryParser a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Text -> BinaryParser a
forall a. Text -> BinaryParser a
BinaryParser.failure a -> BinaryParser a
forall a. a -> BinaryParser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text a -> BinaryParser a)
-> (ByteString -> Either Text a) -> ByteString -> BinaryParser a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ByteString -> Either Text a
cont

{-# INLINEABLE jsonb_ast #-}
jsonb_ast :: Value Aeson.Value
jsonb_ast :: Value Value
jsonb_ast =
  (ByteString -> Either Text Value) -> Value Value
forall a. (ByteString -> Either Text a) -> Value a
jsonb_bytes ((ByteString -> Either Text Value) -> Value Value)
-> (ByteString -> Either Text Value) -> Value Value
forall a b. (a -> b) -> a -> b
$ (String -> Text) -> Either String Value -> Either Text Value
forall a b x. (a -> b) -> Either a x -> Either b x
mapLeft String -> Text
forall a. IsString a => String -> a
fromString (Either String Value -> Either Text Value)
-> (ByteString -> Either String Value)
-> ByteString
-> Either Text Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ByteString -> Either String Value
forall a. FromJSON a => ByteString -> Either String a
Aeson.eitherDecodeStrict'

-- |
-- Given a function, which parses a plain UTF-8 JSON string encoded as a byte-array,
-- produces a decoder.
--
-- For those wondering, yes,
-- JSONB is encoded as plain JSON string in the binary format of Postgres.
-- Sad, but true.
{-# INLINEABLE jsonb_bytes #-}
jsonb_bytes :: (ByteString -> Either Text a) -> Value a
jsonb_bytes :: forall a. (ByteString -> Either Text a) -> Value a
jsonb_bytes ByteString -> Either Text a
cont =
  BinaryParser ByteString
getAllBytes BinaryParser ByteString
-> (ByteString -> BinaryParser ByteString)
-> BinaryParser ByteString
forall a b.
BinaryParser a -> (a -> BinaryParser b) -> BinaryParser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> BinaryParser ByteString
trimBytes BinaryParser ByteString
-> (ByteString -> BinaryParser a) -> BinaryParser a
forall a b.
BinaryParser a -> (a -> BinaryParser b) -> BinaryParser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> BinaryParser a
parseJSON
  where
    getAllBytes :: BinaryParser ByteString
getAllBytes =
      BinaryParser ByteString
BinaryParser.remainders
    trimBytes :: ByteString -> BinaryParser ByteString
trimBytes =
      BinaryParser ByteString
-> (ByteString -> BinaryParser ByteString)
-> Maybe ByteString
-> BinaryParser ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> BinaryParser ByteString
forall a. Text -> BinaryParser a
BinaryParser.failure Text
"Empty input") ByteString -> BinaryParser ByteString
forall a. a -> BinaryParser a
forall (m :: * -> *) a. Monad m => a -> m a
return
        (Maybe ByteString -> BinaryParser ByteString)
-> (ByteString -> Maybe ByteString)
-> ByteString
-> BinaryParser ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ((Word8, ByteString) -> ByteString)
-> Maybe (Word8, ByteString) -> Maybe ByteString
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Word8, ByteString) -> ByteString
forall a b. (a, b) -> b
snd
        (Maybe (Word8, ByteString) -> Maybe ByteString)
-> (ByteString -> Maybe (Word8, ByteString))
-> ByteString
-> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ByteString -> Maybe (Word8, ByteString)
ByteString.uncons
    parseJSON :: ByteString -> BinaryParser a
parseJSON =
      (Text -> BinaryParser a)
-> (a -> BinaryParser a) -> Either Text a -> BinaryParser a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Text -> BinaryParser a
forall a. Text -> BinaryParser a
BinaryParser.failure a -> BinaryParser a
forall a. a -> BinaryParser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text a -> BinaryParser a)
-> (ByteString -> Either Text a) -> ByteString -> BinaryParser a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ByteString -> Either Text a
cont

-- ** Textual

-- |
-- A UTF-8-decoded char.
{-# INLINEABLE char #-}
char :: Value Char
char :: Value Char
char =
  (Text -> Maybe (Char, Text))
-> BinaryParser Text -> BinaryParser (Maybe (Char, Text))
forall a b. (a -> b) -> BinaryParser a -> BinaryParser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Maybe (Char, Text)
Text.uncons BinaryParser Text
text_strict BinaryParser (Maybe (Char, Text))
-> (Maybe (Char, Text) -> Value Char) -> Value Char
forall a b.
BinaryParser a -> (a -> BinaryParser b) -> BinaryParser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just (Char
c, Text
"") -> Char -> Value Char
forall a. a -> BinaryParser a
forall (m :: * -> *) a. Monad m => a -> m a
return Char
c
    Maybe (Char, Text)
Nothing -> Text -> Value Char
forall a. Text -> BinaryParser a
failure Text
"Empty input"
    Maybe (Char, Text)
_ -> Text -> Value Char
forall a. Text -> BinaryParser a
failure Text
"Consumed too much"

-- |
-- Any of the variable-length character types:
-- BPCHAR, VARCHAR, NAME and TEXT.
{-# INLINEABLE text_strict #-}
text_strict :: Value Text
text_strict :: BinaryParser Text
text_strict =
  do
    input <- BinaryParser ByteString
remainders
    either (failure . exception input) return (Text.decodeUtf8' input)
  where
    exception :: a -> UnicodeException -> a
exception a
input =
      \case
        Text.DecodeError String
_ Maybe Word8
_ -> String -> a
forall a. IsString a => String -> a
fromString (String
"Failed to decode the following bytes in UTF-8: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
input)
        UnicodeException
_ -> String -> a
forall a. HasCallStack => String -> a
error String
"Unexpected unicode exception"

-- |
-- Any of the variable-length character types:
-- BPCHAR, VARCHAR, NAME and TEXT.
{-# INLINEABLE text_lazy #-}
text_lazy :: Value LazyText
text_lazy :: Value LazyText
text_lazy =
  do
    input <- Value LazyByteString
bytea_lazy
    either (failure . exception input) return (LazyText.decodeUtf8' input)
  where
    exception :: a -> UnicodeException -> a
exception a
input =
      \case
        Text.DecodeError String
_ Maybe Word8
_ -> String -> a
forall a. IsString a => String -> a
fromString (String
"Failed to decode the following bytes in UTF-8: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
input)
        UnicodeException
_ -> String -> a
forall a. HasCallStack => String -> a
error String
"Unexpected unicode exception"

-- |
-- BYTEA or any other type in its undecoded form.
{-# INLINE bytea_strict #-}
bytea_strict :: Value ByteString
bytea_strict :: BinaryParser ByteString
bytea_strict =
  BinaryParser ByteString
remainders

-- |
-- BYTEA or any other type in its undecoded form.
{-# INLINE bytea_lazy #-}
bytea_lazy :: Value LazyByteString
bytea_lazy :: Value LazyByteString
bytea_lazy =
  (ByteString -> LazyByteString)
-> BinaryParser ByteString -> Value LazyByteString
forall a b. (a -> b) -> BinaryParser a -> BinaryParser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> LazyByteString
LazyByteString.fromStrict BinaryParser ByteString
remainders

-- * Date and Time

-- |
-- @DATE@ values decoding.
date :: Value Day
date :: Value Day
date =
  (Int32 -> Day) -> Value Int32 -> Value Day
forall a b. (a -> b) -> BinaryParser a -> BinaryParser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Integer -> Day
forall a. Integral a => a -> Day
Time.postgresJulianToDay (Integer -> Day) -> (Int32 -> Integer) -> Int32 -> Day
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Int32 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral) (Value Int32
forall a. (Integral a, Bits a) => Value a
int :: Value Int32)

-- |
-- @TIME@ values decoding for servers, which have @integer_datetimes@ enabled.
time_int :: Value TimeOfDay
time_int :: Value TimeOfDay
time_int =
  (Int64 -> TimeOfDay) -> Value Int64 -> Value TimeOfDay
forall a b. (a -> b) -> BinaryParser a -> BinaryParser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int64 -> TimeOfDay
Time.microsToTimeOfDay Value Int64
forall a. (Integral a, Bits a) => Value a
int

-- |
-- @TIME@ values decoding for servers, which don't have @integer_datetimes@ enabled.
time_float :: Value TimeOfDay
time_float :: Value TimeOfDay
time_float =
  (Double -> TimeOfDay) -> Value Double -> Value TimeOfDay
forall a b. (a -> b) -> BinaryParser a -> BinaryParser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Double -> TimeOfDay
Time.secsToTimeOfDay Value Double
float8

-- |
-- @TIMETZ@ values decoding for servers, which have @integer_datetimes@ enabled.
timetz_int :: Value (TimeOfDay, TimeZone)
timetz_int :: Value (TimeOfDay, TimeZone)
timetz_int =
  (,) (TimeOfDay -> TimeZone -> (TimeOfDay, TimeZone))
-> Value TimeOfDay
-> BinaryParser (TimeZone -> (TimeOfDay, TimeZone))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Value TimeOfDay -> Value TimeOfDay
forall a. Int -> BinaryParser a -> BinaryParser a
sized Int
8 Value TimeOfDay
time_int BinaryParser (TimeZone -> (TimeOfDay, TimeZone))
-> BinaryParser TimeZone -> Value (TimeOfDay, TimeZone)
forall a b.
BinaryParser (a -> b) -> BinaryParser a -> BinaryParser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BinaryParser TimeZone
tz

-- |
-- @TIMETZ@ values decoding for servers, which don't have @integer_datetimes@ enabled.
timetz_float :: Value (TimeOfDay, TimeZone)
timetz_float :: Value (TimeOfDay, TimeZone)
timetz_float =
  (,) (TimeOfDay -> TimeZone -> (TimeOfDay, TimeZone))
-> Value TimeOfDay
-> BinaryParser (TimeZone -> (TimeOfDay, TimeZone))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Value TimeOfDay -> Value TimeOfDay
forall a. Int -> BinaryParser a -> BinaryParser a
sized Int
8 Value TimeOfDay
time_float BinaryParser (TimeZone -> (TimeOfDay, TimeZone))
-> BinaryParser TimeZone -> Value (TimeOfDay, TimeZone)
forall a b.
BinaryParser (a -> b) -> BinaryParser a -> BinaryParser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BinaryParser TimeZone
tz

{-# INLINE tz #-}
tz :: Value TimeZone
tz :: BinaryParser TimeZone
tz =
  (Int32 -> TimeZone) -> Value Int32 -> BinaryParser TimeZone
forall a b. (a -> b) -> BinaryParser a -> BinaryParser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> TimeZone
minutesToTimeZone (Int -> TimeZone) -> (Int32 -> Int) -> Int32 -> TimeZone
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Int -> Int
forall a. Num a => a -> a
negate (Int -> Int) -> (Int32 -> Int) -> Int32 -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ((Int -> Int -> Int) -> Int -> Int -> Int
forall a b c. (a -> b -> c) -> b -> a -> c
flip Int -> Int -> Int
forall a. Integral a => a -> a -> a
div Int
60) (Int -> Int) -> (Int32 -> Int) -> Int32 -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral) (Value Int32
forall a. (Integral a, Bits a) => Value a
int :: Value Int32)

-- |
-- @TIMESTAMP@ values decoding for servers, which have @integer_datetimes@ enabled.
timestamp_int :: Value LocalTime
timestamp_int :: Value LocalTime
timestamp_int =
  (Int64 -> LocalTime) -> Value Int64 -> Value LocalTime
forall a b. (a -> b) -> BinaryParser a -> BinaryParser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int64 -> LocalTime
Time.microsToLocalTime Value Int64
forall a. (Integral a, Bits a) => Value a
int

-- |
-- @TIMESTAMP@ values decoding for servers, which don't have @integer_datetimes@ enabled.
timestamp_float :: Value LocalTime
timestamp_float :: Value LocalTime
timestamp_float =
  (Double -> LocalTime) -> Value Double -> Value LocalTime
forall a b. (a -> b) -> BinaryParser a -> BinaryParser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Double -> LocalTime
Time.secsToLocalTime Value Double
float8

-- |
-- @TIMESTAMP@ values decoding for servers, which have @integer_datetimes@ enabled.
timestamptz_int :: Value UTCTime
timestamptz_int :: Value UTCTime
timestamptz_int =
  (Int64 -> UTCTime) -> Value Int64 -> Value UTCTime
forall a b. (a -> b) -> BinaryParser a -> BinaryParser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int64 -> UTCTime
Time.microsToUTC Value Int64
forall a. (Integral a, Bits a) => Value a
int

-- |
-- @TIMESTAMP@ values decoding for servers, which don't have @integer_datetimes@ enabled.
timestamptz_float :: Value UTCTime
timestamptz_float :: Value UTCTime
timestamptz_float =
  (Double -> UTCTime) -> Value Double -> Value UTCTime
forall a b. (a -> b) -> BinaryParser a -> BinaryParser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Double -> UTCTime
Time.secsToUTC Value Double
float8

-- |
-- @INTERVAL@ values decoding for servers, which don't have @integer_datetimes@ enabled.
interval_int :: Value DiffTime
interval_int :: Value DiffTime
interval_int =
  do
    u <- Int -> Value Int64 -> Value Int64
forall a. Int -> BinaryParser a -> BinaryParser a
sized Int
8 Value Int64
forall a. (Integral a, Bits a) => Value a
int
    d <- sized 4 int
    m <- int
    return $ Interval.toDiffTime $ Interval.Interval u d m

-- |
-- @INTERVAL@ values decoding for servers, which have @integer_datetimes@ enabled.
interval_float :: Value DiffTime
interval_float :: Value DiffTime
interval_float =
  do
    u <- Int -> Value Int64 -> Value Int64
forall a. Int -> BinaryParser a -> BinaryParser a
sized Int
8 ((Double -> Int64) -> Value Double -> Value Int64
forall a b. (a -> b) -> BinaryParser a -> BinaryParser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Rational -> Int64
forall b. Integral b => Rational -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (Rational -> Int64) -> (Double -> Rational) -> Double -> Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* (Rational
10 Rational -> Integer -> Rational
forall a b. (Num a, Integral b) => a -> b -> a
^ Integer
6)) (Rational -> Rational)
-> (Double -> Rational) -> Double -> Rational
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Double -> Rational
forall a. Real a => a -> Rational
toRational) Value Double
float8)
    d <- sized 4 int
    m <- int
    return $ Interval.toDiffTime $ Interval.Interval u d m

-- * Exotic

-- |
-- A function for generic in place parsing of an HStore value.
--
-- Accepts:
--
-- * An implementation of the @replicateM@ function
-- (@Control.Monad.'Control.Monad.replicateM'@, @Data.Vector.'Data.Vector.replicateM'@),
-- which determines how to produce the final datastructure from the rows.
--
-- * A decoder for keys.
--
-- * A decoder for values.
--
-- Here's how you can use it to produce a parser to list:
--
-- @
-- hstoreAsList :: Value [ ( Text , Maybe Text ) ]
-- hstoreAsList =
--   hstore replicateM text text
-- @
{-# INLINEABLE hstore #-}
hstore :: (forall m. (Monad m) => Int -> m (k, Maybe v) -> m r) -> Value k -> Value v -> Value r
hstore :: forall k v r.
(forall (m :: * -> *). Monad m => Int -> m (k, Maybe v) -> m r)
-> Value k -> Value v -> Value r
hstore forall (m :: * -> *). Monad m => Int -> m (k, Maybe v) -> m r
replicateM Value k
keyContent Value v
valueContent =
  do
    componentsAmount <- Int -> Value Int
forall a. (Integral a, Bits a) => Int -> Value a
intOfSize Int
4
    replicateM componentsAmount component
  where
    component :: BinaryParser (k, Maybe v)
component =
      (,) (k -> Maybe v -> (k, Maybe v))
-> Value k -> BinaryParser (Maybe v -> (k, Maybe v))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value k
key BinaryParser (Maybe v -> (k, Maybe v))
-> BinaryParser (Maybe v) -> BinaryParser (k, Maybe v)
forall a b.
BinaryParser (a -> b) -> BinaryParser a -> BinaryParser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BinaryParser (Maybe v)
value
      where
        key :: Value k
key =
          Value k -> Value (Maybe k)
forall a. Value a -> Value (Maybe a)
onContent Value k
keyContent Value (Maybe k) -> (Maybe k -> Value k) -> Value k
forall a b.
BinaryParser a -> (a -> BinaryParser b) -> BinaryParser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe k -> Value k
forall a. Maybe a -> Value a
nonNull
        value :: BinaryParser (Maybe v)
value =
          Value v -> BinaryParser (Maybe v)
forall a. Value a -> Value (Maybe a)
onContent Value v
valueContent

-- * Composite

data Composite a
  = Composite
      -- | Amount of fields.
      Int
      -- | Decoder for the fields by the current offset.
      (Int -> BinaryParser.BinaryParser a)
  deriving ((forall a b. (a -> b) -> Composite a -> Composite b)
-> (forall a b. a -> Composite b -> Composite a)
-> Functor Composite
forall a b. a -> Composite b -> Composite a
forall a b. (a -> b) -> Composite a -> Composite 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) -> Composite a -> Composite b
fmap :: forall a b. (a -> b) -> Composite a -> Composite b
$c<$ :: forall a b. a -> Composite b -> Composite a
<$ :: forall a b. a -> Composite b -> Composite a
Functor)

instance Applicative Composite where
  pure :: forall a. a -> Composite a
pure a
x = Int -> (Int -> BinaryParser a) -> Composite a
forall a. Int -> (Int -> BinaryParser a) -> Composite a
Composite Int
0 (\Int
_ -> a -> BinaryParser a
forall a. a -> BinaryParser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x)
  Composite Int
n Int -> BinaryParser (a -> b)
f <*> :: forall a b. Composite (a -> b) -> Composite a -> Composite b
<*> Composite Int
m Int -> BinaryParser a
x =
    Int -> (Int -> BinaryParser b) -> Composite b
forall a. Int -> (Int -> BinaryParser a) -> Composite a
Composite (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
m) (\Int
offset -> Int -> BinaryParser (a -> b)
f Int
offset BinaryParser (a -> b) -> BinaryParser a -> BinaryParser b
forall a b.
BinaryParser (a -> b) -> BinaryParser a -> BinaryParser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> BinaryParser a
x (Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n))

-- |
-- Unlift a 'Composite' to a value 'Value'.
{-# INLINE composite #-}
composite :: Composite a -> Value a
composite :: forall a. Composite a -> Value a
composite (Composite Int
expectedFields Int -> BinaryParser a
body) = do
  actualFields <- Int -> Value Int
forall a. (Integral a, Bits a) => Int -> Value a
intOfSize Int
4
  if actualFields /= expectedFields
    then failure ("Unexpected amount of fields available: " <> fromString (show expectedFields) <> ", expected at least " <> fromString (show (fromIntegral actualFields)))
    else body 0

-- |
-- Nullable composite field.
{-# INLINE baseFieldValueComposite #-}
baseFieldValueComposite :: BinaryParser a -> Composite a
baseFieldValueComposite :: forall a. BinaryParser a -> Composite a
baseFieldValueComposite BinaryParser a
parser =
  Int -> (Int -> BinaryParser a) -> Composite a
forall a. Int -> (Int -> BinaryParser a) -> Composite a
Composite
    Int
1
    ( \Int
fieldIndex ->
        BinaryParser a -> (Text -> BinaryParser a) -> BinaryParser a
forall a.
BinaryParser a -> (Text -> BinaryParser a) -> BinaryParser a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError
          BinaryParser a
parser
          ( \Text
err ->
              Text -> BinaryParser a
forall a. Text -> BinaryParser a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
                ( [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
                    [ Text
"At field ",
                      String -> Text
forall a. IsString a => String -> a
fromString (Int -> String
forall a. Show a => a -> String
show Int
fieldIndex),
                      Text
": ",
                      Text
err
                    ]
                )
          )
    )

-- |
-- Nullable composite field.
{-# INLINE nullableValueComposite #-}
nullableValueComposite :: Value a -> Composite (Maybe a)
nullableValueComposite :: forall a. Value a -> Composite (Maybe a)
nullableValueComposite Value a
valueValue =
  BinaryParser (Maybe a) -> Composite (Maybe a)
forall a. BinaryParser a -> Composite a
baseFieldValueComposite (BinaryParser ()
skipOid BinaryParser () -> BinaryParser (Maybe a) -> BinaryParser (Maybe a)
forall a b. BinaryParser a -> BinaryParser b -> BinaryParser b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Value a -> BinaryParser (Maybe a)
forall a. Value a -> Value (Maybe a)
onContent Value a
valueValue)
  where
    skipOid :: BinaryParser ()
skipOid =
      Int -> BinaryParser ()
unitOfSize Int
4

-- |
-- Lift a non-nullable value 'Value' into 'Composite'.
{-# INLINE valueComposite #-}
valueComposite :: Value a -> Composite a
valueComposite :: forall a. BinaryParser a -> Composite a
valueComposite Value a
valueValue =
  Value a -> Composite a
forall a. BinaryParser a -> Composite a
baseFieldValueComposite
    (BinaryParser ()
skipOid BinaryParser () -> BinaryParser (Maybe a) -> BinaryParser (Maybe a)
forall a b. BinaryParser a -> BinaryParser b -> BinaryParser b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Value a -> BinaryParser (Maybe a)
forall a. Value a -> Value (Maybe a)
onContent Value a
valueValue BinaryParser (Maybe a) -> (Maybe a -> Value a) -> Value a
forall a b.
BinaryParser a -> (a -> BinaryParser b) -> BinaryParser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value a -> (a -> Value a) -> Maybe a -> Value a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> Value a
forall a. Text -> BinaryParser a
failure Text
"Unexpected NULL") a -> Value a
forall a. a -> BinaryParser a
forall (m :: * -> *) a. Monad m => a -> m a
return)
  where
    skipOid :: BinaryParser ()
skipOid =
      Int -> BinaryParser ()
unitOfSize Int
4

-- |
-- Nullable composite field with a checked type OID.
{-# INLINE typedNullableValueComposite #-}
typedNullableValueComposite ::
  -- | Expected type OID.
  Word32 ->
  Value a ->
  Composite (Maybe a)
typedNullableValueComposite :: forall a. Word32 -> Value a -> Composite (Maybe a)
typedNullableValueComposite Word32
expectedOid Value a
valueParser =
  BinaryParser (Maybe a) -> Composite (Maybe a)
forall a. BinaryParser a -> Composite a
baseFieldValueComposite
    ( do
        actualOid <- Int -> BinaryParser Word32
forall a. (Integral a, Bits a) => Int -> Value a
intOfSize Int
4
        if actualOid /= expectedOid
          then throwError ("Unexpected OID: " <> fromString (show actualOid) <> ", expected " <> fromString (show expectedOid))
          else onContent valueParser
    )

-- |
-- Non-nullable composite field with a checked type OID.
{-# INLINE typedValueComposite #-}
typedValueComposite ::
  -- | Expected type OID.
  Word32 ->
  Value a ->
  Composite a
typedValueComposite :: forall a. Word32 -> Value a -> Composite a
typedValueComposite Word32
expectedOid Value a
valueParser =
  Value a -> Composite a
forall a. BinaryParser a -> Composite a
baseFieldValueComposite
    ( do
        actualOid <- Int -> BinaryParser Word32
forall a. (Integral a, Bits a) => Int -> Value a
intOfSize Int
4
        if actualOid /= expectedOid
          then throwError ("Unexpected OID: " <> fromString (show actualOid) <> ", expected " <> fromString (show expectedOid))
          else onContent valueParser >>= maybe (failure "Unexpected NULL") return
    )

-- * Array

-- |
-- An efficient generic array decoder,
-- which constructs the result value in place while parsing.
--
-- Here's how you can use it to produce a specific array value decoder:
--
-- @
-- x :: Value [ [ Text ] ]
-- x =
--   array (dimensionArray replicateM (fmap catMaybes (dimensionArray replicateM (nullableValueArray text))))
-- @
newtype Array a
  = Array ([Word32] -> Value a)
  deriving ((forall a b. (a -> b) -> Array a -> Array b)
-> (forall a b. a -> Array b -> Array a) -> Functor Array
forall a b. a -> Array b -> Array a
forall a b. (a -> b) -> Array a -> Array 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) -> Array a -> Array b
fmap :: forall a b. (a -> b) -> Array a -> Array b
$c<$ :: forall a b. a -> Array b -> Array a
<$ :: forall a b. a -> Array b -> Array a
Functor)

-- |
-- Unlift an 'Array' to a value 'Value'.
{-# INLINE array #-}
array :: Array a -> Value a
array :: forall a. Array a -> Value a
array (Array [Word32] -> Value a
decoder) =
  do
    dimensionsAmount <- Int -> Value Int
forall a. (Integral a, Bits a) => Int -> Value a
intOfSize Int
4
    if dimensionsAmount /= 0
      then do
        unitOfSize (4 + 4)
        dimensionSizes <- replicateM dimensionsAmount dimensionSize
        decoder dimensionSizes
      else decoder [0]
  where
    dimensionSize :: BinaryParser a
dimensionSize =
      Int -> BinaryParser a
forall a. (Integral a, Bits a) => Int -> Value a
intOfSize Int
4 BinaryParser a -> BinaryParser () -> BinaryParser a
forall a b. BinaryParser a -> BinaryParser b -> BinaryParser a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Int -> BinaryParser ()
unitOfSize Int
4

-- |
-- A function for parsing a dimension of an array.
-- Provides support for multi-dimensional arrays.
--
-- Accepts:
--
-- * An implementation of the @replicateM@ function
-- (@Control.Monad.'Control.Monad.replicateM'@, @Data.Vector.'Data.Vector.replicateM'@),
-- which determines the output value.
--
-- * A decoder of its components, which can be either another 'dimensionArray' or 'nullableValueArray'.
{-# INLINE dimensionArray #-}
dimensionArray :: (forall m. (Monad m) => Int -> m a -> m b) -> Array a -> Array b
dimensionArray :: forall a b.
(forall (m :: * -> *). Monad m => Int -> m a -> m b)
-> Array a -> Array b
dimensionArray forall (m :: * -> *). Monad m => Int -> m a -> m b
replicateM (Array [Word32] -> Value a
component) =
  ([Word32] -> Value b) -> Array b
forall a. ([Word32] -> Value a) -> Array a
Array (([Word32] -> Value b) -> Array b)
-> ([Word32] -> Value b) -> Array b
forall a b. (a -> b) -> a -> b
$ \case
    Word32
head : [Word32]
tail -> Int -> Value a -> Value b
forall (m :: * -> *). Monad m => Int -> m a -> m b
replicateM (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
head) ([Word32] -> Value a
component [Word32]
tail)
    [Word32]
_ -> Text -> Value b
forall a. Text -> BinaryParser a
failure Text
"A missing dimension length"

-- |
-- Lift a value 'Value' into 'Array' for parsing of nullable leaf values.
{-# INLINE nullableValueArray #-}
nullableValueArray :: Value a -> Array (Maybe a)
nullableValueArray :: forall a. Value a -> Array (Maybe a)
nullableValueArray =
  ([Word32] -> Value (Maybe a)) -> Array (Maybe a)
forall a. ([Word32] -> Value a) -> Array a
Array (([Word32] -> Value (Maybe a)) -> Array (Maybe a))
-> (Value a -> [Word32] -> Value (Maybe a))
-> Value a
-> Array (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Value (Maybe a) -> [Word32] -> Value (Maybe a)
forall a b. a -> b -> a
const (Value (Maybe a) -> [Word32] -> Value (Maybe a))
-> (Value a -> Value (Maybe a))
-> Value a
-> [Word32]
-> Value (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Value a -> Value (Maybe a)
forall a. Value a -> Value (Maybe a)
onContent

-- |
-- Lift a value 'Value' into 'Array' for parsing of non-nullable leaf values.
{-# INLINE valueArray #-}
valueArray :: Value a -> Array a
valueArray :: forall a. Value a -> Array a
valueArray =
  ([Word32] -> Value a) -> Array a
forall a. ([Word32] -> Value a) -> Array a
Array (([Word32] -> Value a) -> Array a)
-> (Value a -> [Word32] -> Value a) -> Value a -> Array a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Value a -> [Word32] -> Value a
forall a b. a -> b -> a
const (Value a -> [Word32] -> Value a)
-> (Value a -> Value a) -> Value a -> [Word32] -> Value a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. BinaryParser (Value a) -> Value a
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (BinaryParser (Value a) -> Value a)
-> (Value a -> BinaryParser (Value a)) -> Value a -> Value a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Maybe a -> Value a)
-> BinaryParser (Maybe a) -> BinaryParser (Value a)
forall a b. (a -> b) -> BinaryParser a -> BinaryParser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Value a -> (a -> Value a) -> Maybe a -> Value a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> Value a
forall a. Text -> BinaryParser a
failure Text
"Unexpected NULL") a -> Value a
forall a. a -> BinaryParser a
forall (m :: * -> *) a. Monad m => a -> m a
return) (BinaryParser (Maybe a) -> BinaryParser (Value a))
-> (Value a -> BinaryParser (Maybe a))
-> Value a
-> BinaryParser (Value a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Value a -> BinaryParser (Maybe a)
forall a. Value a -> Value (Maybe a)
onContent

-- * Enum

-- |
-- Given a partial mapping from text to value,
-- produces a decoder of that value.
{-# INLINE enum #-}
enum :: (Text -> Maybe a) -> Value a
enum :: forall a. (Text -> Maybe a) -> Value a
enum Text -> Maybe a
mapping =
  BinaryParser Text
text_strict BinaryParser Text -> (Text -> BinaryParser a) -> BinaryParser a
forall a b.
BinaryParser a -> (a -> BinaryParser b) -> BinaryParser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> BinaryParser a
onText
  where
    onText :: Text -> BinaryParser a
onText Text
text =
      BinaryParser a
-> (a -> BinaryParser a) -> Maybe a -> BinaryParser a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe BinaryParser a
onNothing a -> BinaryParser a
forall {f :: * -> *} {a}. Applicative f => a -> f a
onJust (Text -> Maybe a
mapping Text
text)
      where
        onNothing :: BinaryParser a
onNothing =
          Text -> BinaryParser a
forall a. Text -> BinaryParser a
failure (Text
"No mapping for text \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
text Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\"")
        onJust :: a -> f a
onJust =
          a -> f a
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- * Refining values

-- | Given additional constraints when
-- using an existing value decoder, produces
-- a decoder of that value.
{-# INLINE refine #-}
refine :: (a -> Either Text b) -> Value a -> Value b
refine :: forall a b. (a -> Either Text b) -> Value a -> Value b
refine a -> Either Text b
fn Value a
m = Value a
m Value a -> (a -> BinaryParser b) -> BinaryParser b
forall a b.
BinaryParser a -> (a -> BinaryParser b) -> BinaryParser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ((Text -> BinaryParser b)
-> (b -> BinaryParser b) -> Either Text b -> BinaryParser b
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Text -> BinaryParser b
forall a. Text -> BinaryParser a
failure b -> BinaryParser b
forall a. a -> BinaryParser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text b -> BinaryParser b)
-> (a -> Either Text b) -> a -> BinaryParser b
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a -> Either Text b
fn)

-- * Range

-- |
-- One of the range types:
--
-- * @int4range@
-- * @int8range@
-- * @numrange@
-- * @tsrange@
-- * @tstzrange@
-- * @daterange@
{-# INLINE range #-}
range :: Value a -> Value (Range.Range a)
range :: forall a. Value a -> Value (Range a)
range Value a
decoder =
  do
    flags <- BinaryParser Word8
byte
    let emptyRange = Word8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word8
flags Int
0
        lowerInclusive = Word8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word8
flags Int
1
        upperInclusive = Word8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word8
flags Int
2
        lowerInfinite = Word8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word8
flags Int
3
        upperInfinite = Word8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word8
flags Int
4
    if
      | emptyRange ->
          pure $ Range.Empty
      | lowerInfinite && upperInfinite ->
          pure $ Range.Range Range.Inf Range.Inf
      | lowerInfinite ->
          Range.Range <$> pure Range.Inf <*> bound upperInclusive decoder
      | upperInfinite ->
          Range.Range <$> bound lowerInclusive decoder <*> pure Range.Inf
      | otherwise ->
          Range.Range <$> bound lowerInclusive decoder <*> bound upperInclusive decoder
  where
    bound :: Bool -> Value b -> BinaryParser (Bound b)
bound Bool
isIncl =
      Value b -> Value (Maybe b)
forall a. Value a -> Value (Maybe a)
onContent
        (Value b -> Value (Maybe b))
-> (Maybe b -> BinaryParser (Bound b))
-> Value b
-> BinaryParser (Bound b)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Maybe b -> Value b
forall a. Maybe a -> Value a
nonNull
        (Maybe b -> Value b)
-> (b -> BinaryParser (Bound b))
-> Maybe b
-> BinaryParser (Bound b)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> if Bool
isIncl then Bound b -> BinaryParser (Bound b)
forall a. a -> BinaryParser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bound b -> BinaryParser (Bound b))
-> (b -> Bound b) -> b -> BinaryParser (Bound b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. b -> Bound b
forall a. a -> Bound a
Range.Incl else Bound b -> BinaryParser (Bound b)
forall a. a -> BinaryParser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bound b -> BinaryParser (Bound b))
-> (b -> Bound b) -> b -> BinaryParser (Bound b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. b -> Bound b
forall a. a -> Bound a
Range.Excl

-- |
-- @int4range@
{-# INLINE int4range #-}
int4range :: Value (Range.Range Int32)
int4range :: Value (Range Int32)
int4range = Value Int32 -> Value (Range Int32)
forall a. Value a -> Value (Range a)
range Value Int32
forall a. (Integral a, Bits a) => Value a
int

-- |
-- @int8range@
{-# INLINE int8range #-}
int8range :: Value (Range.Range Int64)
int8range :: Value (Range Int64)
int8range = Value Int64 -> Value (Range Int64)
forall a. Value a -> Value (Range a)
range Value Int64
forall a. (Integral a, Bits a) => Value a
int

-- |
-- @numrange@
{-# INLINE numrange #-}
numrange :: Value (Range.Range Scientific)
numrange :: Value (Range Scientific)
numrange = Value Scientific -> Value (Range Scientific)
forall a. Value a -> Value (Range a)
range Value Scientific
numeric

-- |
-- @tsrange@
{-# INLINE tsrange_int #-}
tsrange_int :: Value (Range.Range LocalTime)
tsrange_int :: Value (Range LocalTime)
tsrange_int = Value LocalTime -> Value (Range LocalTime)
forall a. Value a -> Value (Range a)
range Value LocalTime
timestamp_int

-- |
-- @tsrange@
{-# INLINE tsrange_float #-}
tsrange_float :: Value (Range.Range LocalTime)
tsrange_float :: Value (Range LocalTime)
tsrange_float = Value LocalTime -> Value (Range LocalTime)
forall a. Value a -> Value (Range a)
range Value LocalTime
timestamp_float

-- |
-- @tstzrange@
{-# INLINE tstzrange_int #-}
tstzrange_int :: Value (Range.Range UTCTime)
tstzrange_int :: Value (Range UTCTime)
tstzrange_int = Value UTCTime -> Value (Range UTCTime)
forall a. Value a -> Value (Range a)
range Value UTCTime
timestamptz_int

-- |
-- @tstzrange@
{-# INLINE tstzrange_float #-}
tstzrange_float :: Value (Range.Range UTCTime)
tstzrange_float :: Value (Range UTCTime)
tstzrange_float = Value UTCTime -> Value (Range UTCTime)
forall a. Value a -> Value (Range a)
range Value UTCTime
timestamptz_float

-- |
-- @daterange@
{-# INLINE daterange #-}
daterange :: Value (Range.Range Day)
daterange :: Value (Range Day)
daterange = Value Day -> Value (Range Day)
forall a. Value a -> Value (Range a)
range Value Day
date

-- * Multirange

-- |
-- One of the multirange types:
--
-- * @int4multirange@
-- * @int8multirange@
-- * @nummultirange@
-- * @tsmultirange@
-- * @tstzmultirange@
-- * @datemultirange@
{-# INLINE multirange #-}
multirange :: Value a -> Value (Range.Multirange a)
multirange :: forall a. Value a -> Value (Multirange a)
multirange Value a
decoder =
  do
    rangeCount <- Int -> Value Int
forall a. (Integral a, Bits a) => Int -> Value a
intOfSize Int
4
    replicateM rangeCount (onContent (range decoder) >>= nonNull)

-- |
-- @int4multirange@
{-# INLINE int4multirange #-}
int4multirange :: Value (Range.Multirange Int32)
int4multirange :: Value (Multirange Int32)
int4multirange = Value Int32 -> Value (Multirange Int32)
forall a. Value a -> Value (Multirange a)
multirange Value Int32
forall a. (Integral a, Bits a) => Value a
int

-- |
-- @int8multirange@
{-# INLINE int8multirange #-}
int8multirange :: Value (Range.Multirange Int64)
int8multirange :: Value (Multirange Int64)
int8multirange = Value Int64 -> Value (Multirange Int64)
forall a. Value a -> Value (Multirange a)
multirange Value Int64
forall a. (Integral a, Bits a) => Value a
int

-- |
-- @nummultirange@
{-# INLINE nummultirange #-}
nummultirange :: Value (Range.Multirange Scientific)
nummultirange :: Value (Multirange Scientific)
nummultirange = Value Scientific -> Value (Multirange Scientific)
forall a. Value a -> Value (Multirange a)
multirange Value Scientific
numeric

-- |
-- @tsmultirange@
{-# INLINE tsmultirange_int #-}
tsmultirange_int :: Value (Range.Multirange LocalTime)
tsmultirange_int :: Value (Multirange LocalTime)
tsmultirange_int = Value LocalTime -> Value (Multirange LocalTime)
forall a. Value a -> Value (Multirange a)
multirange Value LocalTime
timestamp_int

-- |
-- @tsmultirange@
{-# INLINE tsmultirange_float #-}
tsmultirange_float :: Value (Range.Multirange LocalTime)
tsmultirange_float :: Value (Multirange LocalTime)
tsmultirange_float = Value LocalTime -> Value (Multirange LocalTime)
forall a. Value a -> Value (Multirange a)
multirange Value LocalTime
timestamp_float

-- |
-- @tstzmultirange@
{-# INLINE tstzmultirange_int #-}
tstzmultirange_int :: Value (Range.Multirange UTCTime)
tstzmultirange_int :: Value (Multirange UTCTime)
tstzmultirange_int = Value UTCTime -> Value (Multirange UTCTime)
forall a. Value a -> Value (Multirange a)
multirange Value UTCTime
timestamptz_int

-- |
-- @tstzmultirange@
{-# INLINE tstzmultirange_float #-}
tstzmultirange_float :: Value (Range.Multirange UTCTime)
tstzmultirange_float :: Value (Multirange UTCTime)
tstzmultirange_float = Value UTCTime -> Value (Multirange UTCTime)
forall a. Value a -> Value (Multirange a)
multirange Value UTCTime
timestamptz_float

-- |
-- @datemultirange@
{-# INLINE datemultirange #-}
datemultirange :: Value (Range.Multirange Day)
datemultirange :: Value (Multirange Day)
datemultirange = Value Day -> Value (Multirange Day)
forall a. Value a -> Value (Multirange a)
multirange Value Day
date