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,
  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,
  -- ** HStore
  hstore,
  -- **
  enum,
  refine,
)
where

import PostgreSQL.Binary.Prelude hiding (take, bool, drop, state, fail, failure)
import BinaryParser
import qualified PostgreSQL.Binary.Integral as Integral
import qualified PostgreSQL.Binary.Interval as Interval
import qualified PostgreSQL.Binary.Numeric as Numeric
import qualified PostgreSQL.Binary.Time as Time
import qualified PostgreSQL.Binary.Inet as Inet
import qualified Data.Vector as Vector
import qualified Data.ByteString as ByteString
import qualified Data.ByteString.Lazy as LazyByteString
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.Aeson as Aeson
import qualified Network.IP.Addr as IPAddr


type Value =
  BinaryParser

valueParser :: Value a -> ByteString -> Either Text a
valueParser :: Value a -> ByteString -> Either Text a
valueParser =
  Value a -> ByteString -> Either Text a
forall a. BinaryParser 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 :: Int -> Value a
intOfSize Int
x =
  (ByteString -> a) -> BinaryParser ByteString -> Value a
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)

{-# INLINABLE onContent #-}
onContent :: Value a -> Value ( Maybe a )
onContent :: Value a -> Value (Maybe a)
onContent Value a
decoder =
  Value Int32
size Value Int32 -> (Int32 -> Value (Maybe a)) -> Value (Maybe a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
  \case
    (-1) -> Maybe a -> Value (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
    Int32
n -> (a -> Maybe a) -> Value a -> Value (Maybe a)
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

{-# INLINABLE content #-}
content :: Value (Maybe ByteString)
content :: Value (Maybe ByteString)
content =
  Int -> Value Int
forall a. (Integral a, Bits a) => Int -> Value a
intOfSize Int
4 Value Int
-> (Int -> Value (Maybe ByteString)) -> Value (Maybe ByteString)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    (-1) -> Maybe ByteString -> Value (Maybe ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ByteString
forall a. Maybe a
Nothing
    Int
n -> (ByteString -> Maybe ByteString)
-> BinaryParser ByteString -> Value (Maybe ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (Int -> BinaryParser ByteString
bytesOfSize Int
n)

{-# INLINE nonNull #-}
nonNull :: Maybe a -> Value a
nonNull :: 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 (m :: * -> *) a. Monad m => a -> m a
return


-- * Primitive
-------------------------

-- |
-- Lifts a custom decoder implementation.
{-# INLINE fn #-}
fn :: (ByteString -> Either Text a) -> Value a
fn :: (ByteString -> Either Text a) -> Value a
fn ByteString -> Either Text a
fn =
  BinaryParser ByteString
BinaryParser.remainders BinaryParser ByteString -> (ByteString -> Value a) -> Value a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Text -> Value a) -> (a -> Value a) -> Either Text a -> Value a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Text -> Value a
forall a. Text -> BinaryParser a
BinaryParser.failure a -> Value a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text a -> Value a)
-> (ByteString -> Either Text a) -> ByteString -> Value a
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 :: Value a
int =
  (ByteString -> a) -> BinaryParser ByteString -> Value a
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 (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
    Int
componentsAmount <- Int -> Value Int
forall a. (Integral a, Bits a) => Int -> Value a
intOfSize Int
2
    Int16
pointIndex <- Int -> Value Int16
forall a. (Integral a, Bits a) => Int -> Value a
intOfSize Int
2
    Word16
signCode <- Int -> Value Word16
forall a. (Integral a, Bits a) => Int -> Value a
intOfSize Int
2
    Int -> BinaryParser ()
unitOfSize Int
2
    Vector Word16
components <- Int -> Value Word16 -> BinaryParser (Vector Word16)
forall (m :: * -> *) a. Monad m => Int -> m a -> m (Vector a)
Vector.replicateM Int
componentsAmount (Int -> Value Word16
forall a. (Integral a, Bits a) => Int -> Value a
intOfSize Int
2)
    (Text -> Value Scientific)
-> (Scientific -> Value Scientific)
-> Either Text Scientific
-> Value Scientific
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Text -> Value Scientific
forall a. Text -> BinaryParser a
failure Scientific -> Value Scientific
forall (m :: * -> *) a. Monad m => a -> m a
return (Int16 -> Word16 -> Vector Word16 -> Either Text Scientific
Numeric.scientific Int16
pointIndex Word16
signCode Vector Word16
components)

{-# INLINABLE 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 (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 (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 (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 IPAddr.IP4
ip4 :: Value IP4
ip4 =
  Word8 -> Word8 -> Word8 -> Word8 -> IP4
IPAddr.ip4FromOctets (Word8 -> Word8 -> Word8 -> Word8 -> IP4)
-> BinaryParser Word8
-> BinaryParser (Word8 -> Word8 -> Word8 -> IP4)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> BinaryParser Word8
forall a. (Integral a, Bits a) => Int -> Value a
intOfSize Int
1 BinaryParser (Word8 -> Word8 -> Word8 -> IP4)
-> BinaryParser Word8 -> BinaryParser (Word8 -> Word8 -> IP4)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> BinaryParser Word8
forall a. (Integral a, Bits a) => Int -> Value a
intOfSize Int
1 BinaryParser (Word8 -> Word8 -> IP4)
-> BinaryParser Word8 -> BinaryParser (Word8 -> IP4)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> BinaryParser Word8
forall a. (Integral a, Bits a) => Int -> Value a
intOfSize Int
1 BinaryParser (Word8 -> IP4) -> BinaryParser Word8 -> Value IP4
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> BinaryParser Word8
forall a. (Integral a, Bits a) => Int -> Value a
intOfSize Int
1

{-# INLINE ip6 #-}
ip6 :: Value IPAddr.IP6
ip6 :: Value IP6
ip6 =
  Word16
-> Word16
-> Word16
-> Word16
-> Word16
-> Word16
-> Word16
-> Word16
-> IP6
IPAddr.ip6FromWords (Word16
 -> Word16
 -> Word16
 -> Word16
 -> Word16
 -> Word16
 -> Word16
 -> Word16
 -> IP6)
-> Value Word16
-> BinaryParser
     (Word16
      -> Word16 -> Word16 -> Word16 -> Word16 -> Word16 -> Word16 -> IP6)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Value Word16
forall a. (Integral a, Bits a) => Int -> Value a
intOfSize Int
2 BinaryParser
  (Word16
   -> Word16 -> Word16 -> Word16 -> Word16 -> Word16 -> Word16 -> IP6)
-> Value Word16
-> BinaryParser
     (Word16 -> Word16 -> Word16 -> Word16 -> Word16 -> Word16 -> IP6)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> Value Word16
forall a. (Integral a, Bits a) => Int -> Value a
intOfSize Int
2 BinaryParser
  (Word16 -> Word16 -> Word16 -> Word16 -> Word16 -> Word16 -> IP6)
-> Value Word16
-> BinaryParser
     (Word16 -> Word16 -> Word16 -> Word16 -> Word16 -> IP6)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> Value Word16
forall a. (Integral a, Bits a) => Int -> Value a
intOfSize Int
2 BinaryParser
  (Word16 -> Word16 -> Word16 -> Word16 -> Word16 -> IP6)
-> Value Word16
-> BinaryParser (Word16 -> Word16 -> Word16 -> Word16 -> IP6)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> Value Word16
forall a. (Integral a, Bits a) => Int -> Value a
intOfSize Int
2 BinaryParser (Word16 -> Word16 -> Word16 -> Word16 -> IP6)
-> Value Word16 -> BinaryParser (Word16 -> Word16 -> Word16 -> IP6)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> Value Word16
forall a. (Integral a, Bits a) => Int -> Value a
intOfSize Int
2 BinaryParser (Word16 -> Word16 -> Word16 -> IP6)
-> Value Word16 -> BinaryParser (Word16 -> Word16 -> IP6)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> Value Word16
forall a. (Integral a, Bits a) => Int -> Value a
intOfSize Int
2 BinaryParser (Word16 -> Word16 -> IP6)
-> Value Word16 -> BinaryParser (Word16 -> IP6)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> Value Word16
forall a. (Integral a, Bits a) => Int -> Value a
intOfSize Int
2 BinaryParser (Word16 -> IP6) -> Value Word16 -> Value IP6
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> Value Word16
forall a. (Integral a, Bits a) => Int -> Value a
intOfSize Int
2

{-# INLINABLE inet #-}
inet :: Value (IPAddr.NetAddr IPAddr.IP)
inet :: Value (NetAddr IP)
inet = do
  Word8
af <- Int -> BinaryParser Word8
forall a. (Integral a, Bits a) => Int -> Value a
intOfSize Int
1
  Word8
netmask <- Int -> BinaryParser Word8
forall a. (Integral a, Bits a) => Int -> Value a
intOfSize Int
1
  Word8
isCidr <- Int -> BinaryParser Word8
forall a. (Integral a, Bits a) => Int -> Value a
intOfSize Int
1
  Int8
ipSize <- Int -> Value Int8
forall a. (Integral a, Bits a) => Int -> Value a
intOfSize Int
1
  if | Word8
af Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
Inet.inetAddressFamily ->
       do IP4
ip <- Value IP4
ip4
          NetAddr IP -> Value (NetAddr IP)
forall (m :: * -> *) a. Monad m => a -> m a
return (NetAddr IP -> Value (NetAddr IP))
-> NetAddr IP -> Value (NetAddr IP)
forall a b. (a -> b) -> a -> b
$ Word8 -> Word8 -> Word8 -> Int8 -> IP -> NetAddr IP
inetFromBytes Word8
af Word8
netmask Word8
isCidr Int8
ipSize (IP4 -> IP
forall t₄ t₆. t₄ -> IP46 t₄ t₆
IPAddr.IPv4 IP4
ip)
     | Word8
af Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
Inet.inet6AddressFamily ->
       do IP6
ip <- Value IP6
ip6
          NetAddr IP -> Value (NetAddr IP)
forall (m :: * -> *) a. Monad m => a -> m a
return (NetAddr IP -> Value (NetAddr IP))
-> NetAddr IP -> Value (NetAddr IP)
forall a b. (a -> b) -> a -> b
$ Word8 -> Word8 -> Word8 -> Int8 -> IP -> NetAddr IP
inetFromBytes Word8
af Word8
netmask Word8
isCidr Int8
ipSize (IP6 -> IP
forall t₄ t₆. t₆ -> IP46 t₄ t₆
IPAddr.IPv6 IP6
ip)
     | Bool
otherwise -> Text -> Value (NetAddr IP)
forall a. Text -> BinaryParser a
BinaryParser.failure (Text
"Unknown address family: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a. IsString a => String -> a
fromString (Word8 -> String
forall a. Show a => a -> String
show Word8
af))
  where
    inetFromBytes :: Word8 -> Word8 -> Word8 -> Int8 -> IPAddr.IP -> IPAddr.NetAddr IPAddr.IP
    inetFromBytes :: Word8 -> Word8 -> Word8 -> Int8 -> IP -> NetAddr IP
inetFromBytes Word8
_ Word8
netmask Word8
_ Int8
_ IP
ip = NetHost (NetAddr IP) -> Word8 -> NetAddr IP
forall n. IsNetAddr n => NetHost n -> Word8 -> n
IPAddr.netAddr IP
NetHost (NetAddr IP)
ip Word8
netmask

{-# INLINABLE 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 (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 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 (f :: * -> *) a. Applicative f => a -> f a
pure (Either String Value -> Value Value)
-> (ByteString -> Either String Value) -> ByteString -> Value Value
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.
{-# INLINABLE json_bytes #-}
json_bytes :: (ByteString -> Either Text a) -> Value a
json_bytes :: (ByteString -> Either Text a) -> Value a
json_bytes ByteString -> Either Text a
cont =
  BinaryParser ByteString
getAllBytes BinaryParser ByteString -> (ByteString -> Value a) -> Value a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> Value a
parseJSON
  where
    getAllBytes :: BinaryParser ByteString
getAllBytes =
      BinaryParser ByteString
BinaryParser.remainders
    parseJSON :: ByteString -> Value a
parseJSON =
      (Text -> Value a) -> (a -> Value a) -> Either Text a -> Value a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Text -> Value a
forall a. Text -> BinaryParser a
BinaryParser.failure a -> Value a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text a -> Value a)
-> (ByteString -> Either Text a) -> ByteString -> Value a
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

{-# INLINABLE 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 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.
{-# INLINABLE jsonb_bytes #-}
jsonb_bytes :: (ByteString -> Either Text a) -> Value a
jsonb_bytes :: (ByteString -> Either Text a) -> Value a
jsonb_bytes ByteString -> Either Text a
cont =
  BinaryParser ByteString
getAllBytes BinaryParser ByteString
-> (ByteString -> BinaryParser ByteString)
-> BinaryParser ByteString
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> BinaryParser ByteString
trimBytes BinaryParser ByteString -> (ByteString -> Value a) -> Value a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> Value 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 (m :: * -> *) a. Monad m => a -> m a
return (Maybe ByteString -> BinaryParser ByteString)
-> (ByteString -> Maybe ByteString)
-> ByteString
-> BinaryParser ByteString
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 (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 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 -> Value a
parseJSON =
      (Text -> Value a) -> (a -> Value a) -> Either Text a -> Value a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Text -> Value a
forall a. Text -> BinaryParser a
BinaryParser.failure a -> Value a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text a -> Value a)
-> (ByteString -> Either Text a) -> ByteString -> Value a
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.
{-# INLINABLE char #-}
char :: Value Char
char :: Value Char
char =
  (Text -> Maybe (Char, Text))
-> BinaryParser Text -> BinaryParser (Maybe (Char, Text))
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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just (Char
c, Text
"") -> Char -> Value Char
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.
{-# INLINABLE text_strict #-}
text_strict :: Value Text
text_strict :: BinaryParser Text
text_strict =
  do
    ByteString
input <- BinaryParser ByteString
remainders
    (UnicodeException -> BinaryParser Text)
-> (Text -> BinaryParser Text)
-> Either UnicodeException Text
-> BinaryParser Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> BinaryParser Text
forall a. Text -> BinaryParser a
failure (Text -> BinaryParser Text)
-> (UnicodeException -> Text)
-> UnicodeException
-> BinaryParser Text
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ByteString -> UnicodeException -> Text
forall p a. (IsString p, Show a) => a -> UnicodeException -> p
exception ByteString
input) Text -> BinaryParser Text
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> Either UnicodeException Text
Text.decodeUtf8' ByteString
input)
  where
    exception :: a -> UnicodeException -> p
exception a
input =
      \case
        Text.DecodeError String
_ Maybe Word8
_ -> String -> p
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 -> p
forall a. HasCallStack => String -> a
error String
"Unexpected unicode exception"

-- |
-- Any of the variable-length character types:
-- BPCHAR, VARCHAR, NAME and TEXT.
{-# INLINABLE text_lazy #-}
text_lazy :: Value LazyText
text_lazy :: Value LazyText
text_lazy =
  do
    LazyByteString
input <- Value LazyByteString
bytea_lazy
    (UnicodeException -> Value LazyText)
-> (LazyText -> Value LazyText)
-> Either UnicodeException LazyText
-> Value LazyText
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> Value LazyText
forall a. Text -> BinaryParser a
failure (Text -> Value LazyText)
-> (UnicodeException -> Text) -> UnicodeException -> Value LazyText
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. LazyByteString -> UnicodeException -> Text
forall p a. (IsString p, Show a) => a -> UnicodeException -> p
exception LazyByteString
input ) LazyText -> Value LazyText
forall (m :: * -> *) a. Monad m => a -> m a
return (LazyByteString -> Either UnicodeException LazyText
LazyText.decodeUtf8' LazyByteString
input)
  where
    exception :: a -> UnicodeException -> p
exception a
input =
      \case
        Text.DecodeError String
_ Maybe Word8
_ -> String -> p
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 -> p
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 (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 (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 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 (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 (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 (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 (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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> TimeZone
minutesToTimeZone (Int -> TimeZone) -> (Int32 -> Int) -> Int32 -> TimeZone
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 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 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 (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 (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 (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 (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
    Int64
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
    Int32
d <- Int -> Value Int32 -> Value Int32
forall a. Int -> BinaryParser a -> BinaryParser a
sized Int
4 Value Int32
forall a. (Integral a, Bits a) => Value a
int
    Int32
m <- Value Int32
forall a. (Integral a, Bits a) => Value a
int
    DiffTime -> Value DiffTime
forall (m :: * -> *) a. Monad m => a -> m a
return (DiffTime -> Value DiffTime) -> DiffTime -> Value DiffTime
forall a b. (a -> b) -> a -> b
$ Interval -> DiffTime
Interval.toDiffTime (Interval -> DiffTime) -> Interval -> DiffTime
forall a b. (a -> b) -> a -> b
$ Int64 -> Int32 -> Int32 -> Interval
Interval.Interval Int64
u Int32
d Int32
m

-- |
-- @INTERVAL@ values decoding for servers, which have @integer_datetimes@ enabled.
interval_float :: Value DiffTime
interval_float :: Value DiffTime
interval_float =
  do
    Int64
u <- Int -> Value Int64 -> Value Int64
forall a. Int -> BinaryParser a -> BinaryParser a
sized Int
8 ((Double -> Int64) -> Value Double -> Value Int64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Rational -> Int64
forall a b. (RealFrac a, Integral b) => a -> b
round (Rational -> Int64) -> (Double -> Rational) -> Double -> Int64
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
10Rational -> Integer -> Rational
forall a b. (Num a, Integral b) => a -> b -> a
^Integer
6)) (Rational -> Rational)
-> (Double -> Rational) -> Double -> Rational
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)
    Int32
d <- Int -> Value Int32 -> Value Int32
forall a. Int -> BinaryParser a -> BinaryParser a
sized Int
4 Value Int32
forall a. (Integral a, Bits a) => Value a
int
    Int32
m <- Value Int32
forall a. (Integral a, Bits a) => Value a
int
    DiffTime -> Value DiffTime
forall (m :: * -> *) a. Monad m => a -> m a
return (DiffTime -> Value DiffTime) -> DiffTime -> Value DiffTime
forall a b. (a -> b) -> a -> b
$ Interval -> DiffTime
Interval.toDiffTime (Interval -> DiffTime) -> Interval -> DiffTime
forall a b. (a -> b) -> a -> b
$ Int64 -> Int32 -> Int32 -> Interval
Interval.Interval Int64
u Int32
d Int32
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
-- @
-- 
{-# INLINABLE hstore #-}
hstore :: ( 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)
-> 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
    Int
componentsAmount <- Int -> Value Int
forall a. (Integral a, Bits a) => Int -> Value a
intOfSize Int
4
    Int -> BinaryParser (k, Maybe v) -> Value r
forall (m :: * -> *). Monad m => Int -> m (k, Maybe v) -> m r
replicateM Int
componentsAmount BinaryParser (k, Maybe v)
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 (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 (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
-------------------------

newtype Composite a =
  Composite ( Value a )
  deriving ( a -> Composite b -> Composite a
(a -> b) -> Composite a -> Composite b
(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
<$ :: a -> Composite b -> Composite a
$c<$ :: forall a b. a -> Composite b -> Composite a
fmap :: (a -> b) -> Composite a -> Composite b
$cfmap :: forall a b. (a -> b) -> Composite a -> Composite b
Functor , Functor Composite
a -> Composite a
Functor Composite
-> (forall a. a -> Composite a)
-> (forall a b. Composite (a -> b) -> Composite a -> Composite b)
-> (forall a b c.
    (a -> b -> c) -> Composite a -> Composite b -> Composite c)
-> (forall a b. Composite a -> Composite b -> Composite b)
-> (forall a b. Composite a -> Composite b -> Composite a)
-> Applicative Composite
Composite a -> Composite b -> Composite b
Composite a -> Composite b -> Composite a
Composite (a -> b) -> Composite a -> Composite b
(a -> b -> c) -> Composite a -> Composite b -> Composite c
forall a. a -> Composite a
forall a b. Composite a -> Composite b -> Composite a
forall a b. Composite a -> Composite b -> Composite b
forall a b. Composite (a -> b) -> Composite a -> Composite b
forall a b c.
(a -> b -> c) -> Composite a -> Composite b -> Composite c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: Composite a -> Composite b -> Composite a
$c<* :: forall a b. Composite a -> Composite b -> Composite a
*> :: Composite a -> Composite b -> Composite b
$c*> :: forall a b. Composite a -> Composite b -> Composite b
liftA2 :: (a -> b -> c) -> Composite a -> Composite b -> Composite c
$cliftA2 :: forall a b c.
(a -> b -> c) -> Composite a -> Composite b -> Composite c
<*> :: Composite (a -> b) -> Composite a -> Composite b
$c<*> :: forall a b. Composite (a -> b) -> Composite a -> Composite b
pure :: a -> Composite a
$cpure :: forall a. a -> Composite a
$cp1Applicative :: Functor Composite
Applicative , Applicative Composite
a -> Composite a
Applicative Composite
-> (forall a b. Composite a -> (a -> Composite b) -> Composite b)
-> (forall a b. Composite a -> Composite b -> Composite b)
-> (forall a. a -> Composite a)
-> Monad Composite
Composite a -> (a -> Composite b) -> Composite b
Composite a -> Composite b -> Composite b
forall a. a -> Composite a
forall a b. Composite a -> Composite b -> Composite b
forall a b. Composite a -> (a -> Composite b) -> Composite b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> Composite a
$creturn :: forall a. a -> Composite a
>> :: Composite a -> Composite b -> Composite b
$c>> :: forall a b. Composite a -> Composite b -> Composite b
>>= :: Composite a -> (a -> Composite b) -> Composite b
$c>>= :: forall a b. Composite a -> (a -> Composite b) -> Composite b
$cp1Monad :: Applicative Composite
Monad , Monad Composite
Monad Composite
-> (forall a. String -> Composite a) -> MonadFail Composite
String -> Composite a
forall a. String -> Composite a
forall (m :: * -> *).
Monad m -> (forall a. String -> m a) -> MonadFail m
fail :: String -> Composite a
$cfail :: forall a. String -> Composite a
$cp1MonadFail :: Monad Composite
MonadFail )

-- |
-- Unlift a 'Composite' to a value 'Value'.
{-# INLINE composite #-}
composite :: Composite a -> Value a
composite :: Composite a -> Value a
composite (Composite Value a
decoder) =
  BinaryParser ()
numOfComponents BinaryParser () -> Value a -> Value a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Value a
decoder
  where
    numOfComponents :: BinaryParser ()
numOfComponents =
      Int -> BinaryParser ()
unitOfSize Int
4

-- |
-- Lift a value 'Value' into 'Composite'.
{-# INLINE nullableValueComposite #-}
nullableValueComposite :: Value a -> Composite ( Maybe a )
nullableValueComposite :: Value a -> Composite (Maybe a)
nullableValueComposite Value a
valueValue =
  Value (Maybe a) -> Composite (Maybe a)
forall a. Value a -> Composite a
Composite (BinaryParser ()
skipOid BinaryParser () -> Value (Maybe a) -> Value (Maybe a)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Value a -> Value (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 :: Value a -> Composite a
valueComposite Value a
valueValue =
  Value a -> Composite a
forall a. Value a -> Composite a
Composite (BinaryParser ()
skipOid BinaryParser () -> BinaryParser (Maybe a) -> BinaryParser (Maybe a)
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 (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 (m :: * -> *) a. Monad m => a -> m a
return)
  where
    skipOid :: BinaryParser ()
skipOid =
      Int -> BinaryParser ()
unitOfSize Int
4


-- * 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 ( a -> Array b -> Array a
(a -> b) -> Array a -> Array b
(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
<$ :: a -> Array b -> Array a
$c<$ :: forall a b. a -> Array b -> Array a
fmap :: (a -> b) -> Array a -> Array b
$cfmap :: forall a b. (a -> b) -> Array a -> Array b
Functor )

-- |
-- Unlift an 'Array' to a value 'Value'.
{-# INLINE array #-}
array :: Array a -> Value a
array :: Array a -> Value a
array (Array [Word32] -> Value a
decoder) =
  do
    Int
dimensionsAmount <- Int -> Value Int
forall a. (Integral a, Bits a) => Int -> Value a
intOfSize Int
4
    if Int
dimensionsAmount Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0
      then do
        Int -> BinaryParser ()
unitOfSize (Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4)
        [Word32]
dimensionSizes <- Int -> BinaryParser Word32 -> BinaryParser [Word32]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
dimensionsAmount BinaryParser Word32
forall a. (Integral a, Bits a) => Value a
dimensionSize
        [Word32] -> Value a
decoder [Word32]
dimensionSizes
      else [Word32] -> Value a
decoder [Word32
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 (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 (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 :: 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 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 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 :: 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 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 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 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 (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 (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 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 :: (Text -> Maybe a) -> Value a
enum Text -> Maybe a
mapping =
  BinaryParser Text
text_strict BinaryParser Text -> (Text -> Value a) -> Value a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Value a
onText
  where
    onText :: Text -> Value a
onText Text
text =
      Value a -> (a -> Value a) -> Maybe a -> Value a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Value a
onNothing a -> Value a
forall (f :: * -> *) a. Applicative f => a -> f a
onJust (Text -> Maybe a
mapping Text
text)
      where
        onNothing :: Value a
onNothing =
          Text -> Value 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 (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 :: (a -> Either Text b) -> Value a -> Value b
refine a -> Either Text b
fn Value a
m = Value a
m Value a -> (a -> Value b) -> Value b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ((Text -> Value b) -> (b -> Value b) -> Either Text b -> Value b
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Text -> Value b
forall a. Text -> BinaryParser a
failure b -> Value b
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text b -> Value b) -> (a -> Either Text b) -> a -> Value b
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)