summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorNikitaVolkov <>2017-03-20 22:29:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2017-03-20 22:29:00 (GMT)
commit4a75b53da912bb8fe4475cb9ab0380f5875fe889 (patch)
treeddad22faf097343cd8f9534385b5655b1b639ede
parent214c1358189b76bf06729cb1dca19c2c26b751a3 (diff)
version 0.12.1HEAD0.12.1master
-rw-r--r--decoding/Main.hs53
-rw-r--r--encoding/Main.hs47
-rw-r--r--library/PostgreSQL/Binary/Data.hs83
-rw-r--r--library/PostgreSQL/Binary/Decoding.hs (renamed from library/PostgreSQL/Binary/Decoder.hs)235
-rw-r--r--library/PostgreSQL/Binary/Encoder.hs576
-rw-r--r--library/PostgreSQL/Binary/Encoding.hs347
-rw-r--r--library/PostgreSQL/Binary/Encoding/Builders.hs456
-rw-r--r--library/PostgreSQL/Binary/Numeric.hs2
-rw-r--r--library/PostgreSQL/Binary/Prelude.hs8
-rw-r--r--postgresql-binary.cabal17
-rw-r--r--tasty/Main.hs179
-rw-r--r--tasty/Main/Gens.hs31
-rw-r--r--tasty/Main/IO.hs19
-rw-r--r--tasty/Main/Properties.hs13
14 files changed, 1095 insertions, 971 deletions
diff --git a/decoding/Main.hs b/decoding/Main.hs
index 9a3735b..0a3acaa 100644
--- a/decoding/Main.hs
+++ b/decoding/Main.hs
@@ -3,61 +3,58 @@ module Main where
import Prelude
import Criterion
import Criterion.Main
-import qualified PostgreSQL.Binary.Encoder as E
-import qualified PostgreSQL.Binary.Decoder as D
+import qualified PostgreSQL.Binary.Encoding as E
+import qualified PostgreSQL.Binary.Decoding as D
main =
defaultMain
[
- b "bool" D.bool (E.run E.bool True)
+ b "bool" D.bool ((E.encodingBytes . E.bool) True)
,
- b "int2" (D.int :: D.Decoder Int16) (E.run E.int2_int16 1000)
+ b "int2" (D.int :: D.Value Int16) ((E.encodingBytes . E.int2_int16) 1000)
,
- b "int4" (D.int :: D.Decoder Int32) (E.run E.int4_int32 1000)
+ b "int4" (D.int :: D.Value Int32) ((E.encodingBytes . E.int4_int32) 1000)
,
- b "int8" (D.int :: D.Decoder Int64) (E.run E.int8_int64 1000)
+ b "int8" (D.int :: D.Value Int64) ((E.encodingBytes . E.int8_int64) 1000)
,
- b "float4" D.float4 (E.run E.float4 12.65468468)
+ b "float4" D.float4 ((E.encodingBytes . E.float4) 12.65468468)
,
- b "float8" D.float8 (E.run E.float8 12.65468468)
+ b "float8" D.float8 ((E.encodingBytes . E.float8) 12.65468468)
,
- b "numeric" D.numeric (E.run E.numeric (read "20.213290183"))
+ b "numeric" D.numeric ((E.encodingBytes . E.numeric) (read "20.213290183"))
,
- b "char" D.char (E.run E.char 'Я')
+ b "char" D.char ((E.encodingBytes . E.char_utf8) 'Я')
,
- b "text" D.text_strict (E.run E.text_strict "alsdjflskjдывлоаы оады")
+ b "text" D.text_strict ((E.encodingBytes . E.text_strict) "alsdjflskjдывлоаы оады")
,
- b "bytea" D.bytea_strict (E.run E.bytea_strict "alskdfj;dasjfl;dasjflksdj")
+ b "bytea" D.bytea_strict ((E.encodingBytes . E.bytea_strict) "alskdfj;dasjfl;dasjflksdj")
,
- b "date" D.date (E.run E.date (read "2000-01-19"))
+ b "date" D.date ((E.encodingBytes . E.date) (read "2000-01-19"))
,
- b "time" D.time_int (E.run E.time_int (read "10:41:06"))
+ b "time" D.time_int ((E.encodingBytes . E.time_int) (read "10:41:06"))
,
- b "timetz" D.timetz_int (E.run E.timetz_int (read "(10:41:06, +0300)"))
+ b "timetz" D.timetz_int ((E.encodingBytes . E.timetz_int) (read "(10:41:06, +0300)"))
,
- b "timestamp" D.timestamp_int (E.run E.timestamp_int (read "2000-01-19 10:41:06"))
+ b "timestamp" D.timestamp_int ((E.encodingBytes . E.timestamp_int) (read "2000-01-19 10:41:06"))
,
- b "timestamptz" D.timestamptz_int (E.run E.timestamptz_int (read "2000-01-19 10:41:06"))
+ b "timestamptz" D.timestamptz_int ((E.encodingBytes . E.timestamptz_int) (read "2000-01-19 10:41:06"))
,
- b "interval" D.interval_int (E.run E.interval_int (secondsToDiffTime 23472391128374))
+ b "interval" D.interval_int ((E.encodingBytes . E.interval_int) (secondsToDiffTime 23472391128374))
,
- b "uuid" D.uuid (E.run E.uuid (read "550e8400-e29b-41d4-a716-446655440000"))
+ b "uuid" D.uuid ((E.encodingBytes . E.uuid) (read "550e8400-e29b-41d4-a716-446655440000"))
,
let
encoder =
- E.array 23 $
- E.arrayDimension foldl' $
- E.arrayValue $
- E.int4_int32
+ E.array 23 . E.dimensionArray foldl' (E.encodingArray . E.int4_int32)
decoder =
D.array $
- D.arrayDimension replicateM $
- D.arrayNonNullValue $
- (D.int :: D.Decoder Int32)
+ D.dimensionArray replicateM $
+ D.valueArray $
+ (D.int :: D.Value Int32)
in
- b "array" decoder (E.run encoder [1,2,3,4])
+ b "array" decoder (E.encodingBytes (encoder [1,2,3,4]))
]
where
b name decoder value =
- bench name $ nf (D.run decoder) value
+ bench name $ nf (D.valueParser decoder) value
diff --git a/encoding/Main.hs b/encoding/Main.hs
index ed6a982..dba32f3 100644
--- a/encoding/Main.hs
+++ b/encoding/Main.hs
@@ -3,55 +3,52 @@ module Main where
import Prelude
import Criterion
import Criterion.Main
-import qualified PostgreSQL.Binary.Encoder as E
+import qualified PostgreSQL.Binary.Encoding as E
main =
defaultMain
[
- b "bool" E.bool True
+ value "bool" E.bool True
,
- b "int2" E.int2_int16 1000
+ value "int2" E.int2_int16 1000
,
- b "int4" E.int4_int32 1000
+ value "int4" E.int4_int32 1000
,
- b "int8" E.int8_int64 1000
+ value "int8" E.int8_int64 1000
,
- b "float4" E.float4 12.65468468
+ value "float4" E.float4 12.65468468
,
- b "float8" E.float8 12.65468468
+ value "float8" E.float8 12.65468468
,
- b "numeric" E.numeric (read "20.213290183")
+ value "numeric" E.numeric (read "20.213290183")
,
- b "char" E.char 'Я'
+ value "char_utf8" E.char_utf8 'Я'
,
- b "text" E.text_strict "alsdjflskjдывлоаы оады"
+ value "text" E.text_strict "alsdjflskjдывлоаы оады"
,
- b "bytea" E.bytea_strict "alskdfj;dasjfl;dasjflksdj"
+ value "bytea" E.bytea_strict "alskdfj;dasjfl;dasjflksdj"
,
- b "date" E.date (read "2000-01-19")
+ value "date" E.date (read "2000-01-19")
,
- b "time" E.time_int (read "10:41:06")
+ value "time" E.time_int (read "10:41:06")
,
- b "timetz" E.timetz_int (read "(10:41:06, +0300)")
+ value "timetz" E.timetz_int (read "(10:41:06, +0300)")
,
- b "timestamp" E.timestamp_int (read "2000-01-19 10:41:06")
+ value "timestamp" E.timestamp_int (read "2000-01-19 10:41:06")
,
- b "timestamptz" E.timestamptz_int (read "2000-01-19 10:41:06")
+ value "timestamptz" E.timestamptz_int (read "2000-01-19 10:41:06")
,
- b "interval" E.interval_int (secondsToDiffTime 23472391128374)
+ value "interval" E.interval_int (secondsToDiffTime 23472391128374)
,
- b "uuid" E.uuid (read "550e8400-e29b-41d4-a716-446655440000")
+ value "uuid" E.uuid (read "550e8400-e29b-41d4-a716-446655440000")
,
let
encoder =
- E.array 23 $
- E.arrayDimension foldl' $
- E.arrayValue $
- E.int4_int32
+ E.array 23 . E.dimensionArray foldl' (E.encodingArray . E.int4_int32)
in
- b "array" encoder [1,2,3,4]
+ value "array" encoder [1,2,3,4]
]
where
- b name encoder value =
- bench name $ nf (E.run encoder) value
+ value name encoder value =
+ bench name $ nf (E.encodingBytes . encoder) value
diff --git a/library/PostgreSQL/Binary/Data.hs b/library/PostgreSQL/Binary/Data.hs
index 32ae20b..d963113 100644
--- a/library/PostgreSQL/Binary/Data.hs
+++ b/library/PostgreSQL/Binary/Data.hs
@@ -1,58 +1,25 @@
--- |
--- Models of supported data structures according to the serialisation format.
-module PostgreSQL.Binary.Data where
-
-import PostgreSQL.Binary.Prelude
-import qualified Network.IP.Addr as IPAddr
-
--- |
--- A representation of a data serializable to the PostgreSQL array binary format.
---
--- Consists of a vector of dimensions, a vector of encoded elements,
--- a flag specifying, whether it contains any nulls, and an oid.
-type Array =
- (Vector ArrayDimension, Vector Content, Bool, OID)
-
--- |
--- A width and a lower bound.
---
--- Currently the lower bound is only allowed to have a value of @1@.
-type ArrayDimension =
- (Word32, Word32)
-
--- |
--- An encoded value. 'Nothing' if it represents a @NULL@.
-type Content =
- Maybe ByteString
-
--- |
--- A Postgres OID of a type.
-type OID =
- Word32
-
--- |
--- A representation of a composite Postgres data (Record or Row).
-type Composite =
- Vector (OID, Content)
-
--- |
--- HStore.
-type HStore =
- Vector (ByteString, Content)
-
--- |
--- The four components of UUID.
-type UUID =
- (Word32, Word32, Word32, Word32)
-
--- |
--- Representation of the PostgreSQL Numeric encoding.
---
--- Consists of the following components:
---
--- * Point index
--- * Sign code
--- * Components
---
-type Numeric =
- (Int16, Word16, Vector Int16)
+{-|
+Reexports of all the data-types that this API supports.
+Useful for the reduction of dependencies in the \"postgresql-binary\" dependent libraries.
+-}
+module PostgreSQL.Binary.Data
+(
+ module Data.HashMap.Strict,
+ module Data.Map.Strict,
+ module Data.Scientific,
+ module Data.Time,
+ module Data.UUID,
+ module Data.Vector,
+ module Data.Aeson,
+ module Network.IP.Addr,
+)
+where
+
+import Data.HashMap.Strict (HashMap)
+import Data.Map.Strict (Map)
+import Data.Scientific (Scientific)
+import Data.Time (Day, TimeOfDay, TimeZone, LocalTime, UTCTime, DiffTime)
+import Data.UUID (UUID)
+import Data.Vector (Vector)
+import Data.Aeson (Value)
+import Network.IP.Addr (IP, NetAddr)
diff --git a/library/PostgreSQL/Binary/Decoder.hs b/library/PostgreSQL/Binary/Decoding.hs
index 9c56e77..2237f1b 100644
--- a/library/PostgreSQL/Binary/Decoder.hs
+++ b/library/PostgreSQL/Binary/Decoding.hs
@@ -1,7 +1,8 @@
-module PostgreSQL.Binary.Decoder
+module PostgreSQL.Binary.Decoding
(
- Decoder,
- run,
+ valueParser,
+ --
+ Value,
-- * Primitive
int,
float4,
@@ -36,16 +37,16 @@ module PostgreSQL.Binary.Decoder
interval_float,
-- * Exotic
-- ** Array
- ArrayDecoder,
+ Array,
array,
- arrayDimension,
- arrayValue,
- arrayNonNullValue,
+ valueArray,
+ nullableValueArray,
+ dimensionArray,
-- ** Composite
- CompositeDecoder,
+ Composite,
composite,
- compositeValue,
- compositeNonNullValue,
+ valueComposite,
+ nullableValueComposite,
-- ** HStore
hstore,
-- **
@@ -55,7 +56,6 @@ where
import PostgreSQL.Binary.Prelude hiding (take, bool, drop, state, fail, failure)
import BinaryParser
-import qualified PostgreSQL.Binary.Data as Data
import qualified PostgreSQL.Binary.Integral as Integral
import qualified PostgreSQL.Binary.Interval as Interval
import qualified PostgreSQL.Binary.Numeric as Numeric
@@ -73,9 +73,12 @@ import qualified Data.Aeson as Aeson
import qualified Network.IP.Addr as IPAddr
-type Decoder =
+type Value =
BinaryParser
+valueParser :: Value a -> ByteString -> Either Text a
+valueParser =
+ BinaryParser.run
-- * Helpers
-------------------------
@@ -83,12 +86,12 @@ type Decoder =
-- |
-- Any int number of a limited byte-size.
{-# INLINE intOfSize #-}
-intOfSize :: (Integral a, Bits a) => Int -> Decoder a
+intOfSize :: (Integral a, Bits a) => Int -> Value a
intOfSize x =
fmap Integral.pack (bytesOfSize x)
{-# INLINABLE onContent #-}
-onContent :: Decoder a -> Decoder ( Maybe a )
+onContent :: Value a -> Value ( Maybe a )
onContent decoder =
size >>=
\case
@@ -96,17 +99,17 @@ onContent decoder =
n -> fmap Just (sized (fromIntegral n) decoder)
where
size =
- intOfSize 4 :: Decoder Int32
+ intOfSize 4 :: Value Int32
{-# INLINABLE content #-}
-content :: Decoder (Maybe ByteString)
+content :: Value (Maybe ByteString)
content =
intOfSize 4 >>= \case
(-1) -> pure Nothing
n -> fmap Just (bytesOfSize n)
{-# INLINE nonNull #-}
-nonNull :: Maybe a -> Decoder a
+nonNull :: Maybe a -> Value a
nonNull =
maybe (failure "Unexpected NULL") return
@@ -117,30 +120,30 @@ nonNull =
-- |
-- Lifts a custom decoder implementation.
{-# INLINE fn #-}
-fn :: (ByteString -> Either Text a) -> Decoder a
+fn :: (ByteString -> Either Text a) -> Value a
fn fn =
BinaryParser.remainders >>= either BinaryParser.failure return . fn
{-# INLINE int #-}
-int :: (Integral a, Bits a) => Decoder a
+int :: (Integral a, Bits a) => Value a
int =
fmap Integral.pack remainders
-float4 :: Decoder Float
+float4 :: Value Float
float4 =
- unsafeCoerce (int :: Decoder Int32)
+ unsafeCoerce (int :: Value Int32)
-float8 :: Decoder Double
+float8 :: Value Double
float8 =
- unsafeCoerce (int :: Decoder Int64)
+ unsafeCoerce (int :: Value Int64)
{-# INLINE bool #-}
-bool :: Decoder Bool
+bool :: Value Bool
bool =
fmap (== 1) byte
{-# NOINLINE numeric #-}
-numeric :: Decoder Scientific
+numeric :: Value Scientific
numeric =
do
componentsAmount <- intOfSize 2
@@ -151,22 +154,22 @@ numeric =
either failure return (Numeric.scientific pointIndex signCode components)
{-# INLINABLE uuid #-}
-uuid :: Decoder UUID
+uuid :: Value UUID
uuid =
UUID.fromWords <$> intOfSize 4 <*> intOfSize 4 <*> intOfSize 4 <*> intOfSize 4
{-# INLINE ip4 #-}
-ip4 :: Decoder IPAddr.IP4
+ip4 :: Value IPAddr.IP4
ip4 =
IPAddr.ip4FromOctets <$> intOfSize 1 <*> intOfSize 1 <*> intOfSize 1 <*> intOfSize 1
{-# INLINE ip6 #-}
-ip6 :: Decoder IPAddr.IP6
+ip6 :: Value IPAddr.IP6
ip6 =
IPAddr.ip6FromWords <$> intOfSize 2 <*> intOfSize 2 <*> intOfSize 2 <*> intOfSize 2 <*> intOfSize 2 <*> intOfSize 2 <*> intOfSize 2 <*> intOfSize 2
{-# INLINABLE inet #-}
-inet :: Decoder (IPAddr.NetAddr IPAddr.IP)
+inet :: Value (IPAddr.NetAddr IPAddr.IP)
inet = do
af <- intOfSize 1
netmask <- intOfSize 1
@@ -184,7 +187,7 @@ inet = do
inetFromBytes _ netmask _ _ ip = IPAddr.netAddr ip netmask
{-# INLINABLE json_ast #-}
-json_ast :: Decoder Aeson.Value
+json_ast :: Value Aeson.Value
json_ast =
bytea_strict >>= either (BinaryParser.failure . fromString) pure . Aeson.eitherDecodeStrict'
@@ -192,7 +195,7 @@ json_ast =
-- 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) -> Decoder a
+json_bytes :: (ByteString -> Either Text a) -> Value a
json_bytes cont =
getAllBytes >>= parseJSON
where
@@ -202,7 +205,7 @@ json_bytes cont =
either BinaryParser.failure return . cont
{-# INLINABLE jsonb_ast #-}
-jsonb_ast :: Decoder Aeson.Value
+jsonb_ast :: Value Aeson.Value
jsonb_ast =
jsonb_bytes $ mapLeft fromString . Aeson.eitherDecodeStrict'
@@ -214,7 +217,7 @@ jsonb_ast =
-- 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) -> Decoder a
+jsonb_bytes :: (ByteString -> Either Text a) -> Value a
jsonb_bytes cont =
getAllBytes >>= trimBytes >>= parseJSON
where
@@ -233,7 +236,7 @@ jsonb_bytes cont =
-- |
-- A UTF-8-decoded char.
{-# INLINABLE char #-}
-char :: Decoder Char
+char :: Value Char
char =
fmap Text.uncons text_strict >>= \case
Just (c, "") -> return c
@@ -244,7 +247,7 @@ char =
-- Any of the variable-length character types:
-- BPCHAR, VARCHAR, NAME and TEXT.
{-# INLINABLE text_strict #-}
-text_strict :: Decoder Text
+text_strict :: Value Text
text_strict =
remainders >>= either (failure . exception) return . Text.decodeUtf8'
where
@@ -257,7 +260,7 @@ text_strict =
-- Any of the variable-length character types:
-- BPCHAR, VARCHAR, NAME and TEXT.
{-# INLINABLE text_lazy #-}
-text_lazy :: Decoder LazyText
+text_lazy :: Value LazyText
text_lazy =
bytea_lazy >>= either (failure . exception) return . LazyText.decodeUtf8'
where
@@ -269,14 +272,14 @@ text_lazy =
-- |
-- BYTEA or any other type in its undecoded form.
{-# INLINE bytea_strict #-}
-bytea_strict :: Decoder ByteString
+bytea_strict :: Value ByteString
bytea_strict =
remainders
-- |
-- BYTEA or any other type in its undecoded form.
{-# INLINE bytea_lazy #-}
-bytea_lazy :: Decoder LazyByteString
+bytea_lazy :: Value LazyByteString
bytea_lazy =
fmap LazyByteString.fromStrict remainders
@@ -286,66 +289,66 @@ bytea_lazy =
-- |
-- @DATE@ values decoding.
-date :: Decoder Day
+date :: Value Day
date =
- fmap (Time.postgresJulianToDay . fromIntegral) (int :: Decoder Int32)
+ fmap (Time.postgresJulianToDay . fromIntegral) (int :: Value Int32)
-- |
-- @TIME@ values decoding for servers, which have @integer_datetimes@ enabled.
-time_int :: Decoder TimeOfDay
+time_int :: Value TimeOfDay
time_int =
fmap Time.microsToTimeOfDay int
-- |
-- @TIME@ values decoding for servers, which don't have @integer_datetimes@ enabled.
-time_float :: Decoder TimeOfDay
+time_float :: Value TimeOfDay
time_float =
fmap Time.secsToTimeOfDay float8
-- |
-- @TIMETZ@ values decoding for servers, which have @integer_datetimes@ enabled.
-timetz_int :: Decoder (TimeOfDay, TimeZone)
+timetz_int :: Value (TimeOfDay, TimeZone)
timetz_int =
(,) <$> sized 8 time_int <*> tz
-- |
-- @TIMETZ@ values decoding for servers, which don't have @integer_datetimes@ enabled.
-timetz_float :: Decoder (TimeOfDay, TimeZone)
+timetz_float :: Value (TimeOfDay, TimeZone)
timetz_float =
(,) <$> sized 8 time_float <*> tz
{-# INLINE tz #-}
-tz :: Decoder TimeZone
+tz :: Value TimeZone
tz =
- fmap (minutesToTimeZone . negate . (flip div 60) . fromIntegral) (int :: Decoder Int32)
+ fmap (minutesToTimeZone . negate . (flip div 60) . fromIntegral) (int :: Value Int32)
-- |
-- @TIMESTAMP@ values decoding for servers, which have @integer_datetimes@ enabled.
-timestamp_int :: Decoder LocalTime
+timestamp_int :: Value LocalTime
timestamp_int =
fmap Time.microsToLocalTime int
-- |
-- @TIMESTAMP@ values decoding for servers, which don't have @integer_datetimes@ enabled.
-timestamp_float :: Decoder LocalTime
+timestamp_float :: Value LocalTime
timestamp_float =
fmap Time.secsToLocalTime float8
-- |
-- @TIMESTAMP@ values decoding for servers, which have @integer_datetimes@ enabled.
-timestamptz_int :: Decoder UTCTime
+timestamptz_int :: Value UTCTime
timestamptz_int =
fmap Time.microsToUTC int
-- |
-- @TIMESTAMP@ values decoding for servers, which don't have @integer_datetimes@ enabled.
-timestamptz_float :: Decoder UTCTime
+timestamptz_float :: Value UTCTime
timestamptz_float =
fmap Time.secsToUTC float8
-- |
-- @INTERVAL@ values decoding for servers, which don't have @integer_datetimes@ enabled.
-interval_int :: Decoder DiffTime
+interval_int :: Value DiffTime
interval_int =
do
u <- sized 8 int
@@ -355,7 +358,7 @@ interval_int =
-- |
-- @INTERVAL@ values decoding for servers, which have @integer_datetimes@ enabled.
-interval_float :: Decoder DiffTime
+interval_float :: Value DiffTime
interval_float =
do
u <- sized 8 (fmap (round . (*(10^6)) . toRational) float8)
@@ -368,41 +371,6 @@ interval_float =
-------------------------
-- |
--- A lower-level array data parser,
--- which aggregates the intermediate data representation as per the Postgres format.
---
--- Only use this if 'array' doesn't fit your case.
-{-# INLINABLE arrayRep #-}
-arrayRep :: Decoder Data.Array
-arrayRep =
- do
- dimensionsAmount <- intOfSize 4
- nullsValue <- nulls
- oid <- intOfSize 4
- dimensions <- Vector.replicateM dimensionsAmount dimension
- let valuesAmount = (Vector.product . Vector.map fst) dimensions
- values <- Vector.replicateM (fromIntegral valuesAmount) content
- return (dimensions, values, nullsValue, oid)
- where
- dimension =
- (,) <$> intOfSize 4 <*> intOfSize 4
- nulls =
- intOfSize 4 >>= \(x :: Word32) -> case x of
- 0 -> return False
- 1 -> return True
- w -> failure $ "Invalid value: " <> (fromString . show) w
-
-{-# INLINABLE compositeRep #-}
-compositeRep :: Decoder Data.Composite
-compositeRep =
- do
- componentsAmount <- intOfSize 4
- Vector.replicateM componentsAmount component
- where
- component =
- (,) <$> intOfSize 4 <*> content
-
--- |
-- A function for generic in place parsing of an HStore value.
--
-- Accepts:
@@ -418,13 +386,13 @@ compositeRep =
-- Here's how you can use it to produce a parser to list:
--
-- @
--- hstoreAsList :: Decoder [ ( Text , Maybe Text ) ]
+-- hstoreAsList :: Value [ ( Text , Maybe Text ) ]
-- hstoreAsList =
-- hstore replicateM text text
-- @
--
{-# INLINABLE hstore #-}
-hstore :: ( forall m. Monad m => Int -> m ( k , Maybe v ) -> m r ) -> Decoder k -> Decoder v -> Decoder r
+hstore :: ( forall m. Monad m => Int -> m ( k , Maybe v ) -> m r ) -> Value k -> Value v -> Value r
hstore replicateM keyContent valueContent =
do
componentsAmount <- intOfSize 4
@@ -438,53 +406,40 @@ hstore replicateM keyContent valueContent =
value =
onContent valueContent
-{-# INLINABLE hstoreRep #-}
-hstoreRep :: Decoder Data.HStore
-hstoreRep =
- do
- componentsAmount <- intOfSize 4
- Vector.replicateM componentsAmount component
- where
- component =
- (,) <$> key <*> content
- where
- key =
- intOfSize 4 >>= bytesOfSize
-
-- * Composite
-------------------------
-newtype CompositeDecoder a =
- CompositeDecoder ( Decoder a )
+newtype Composite a =
+ Composite ( Value a )
deriving ( Functor , Applicative , Monad )
-- |
--- Unlift a 'CompositeDecoder' to a value 'Decoder'.
+-- Unlift a 'Composite' to a value 'Value'.
{-# INLINE composite #-}
-composite :: CompositeDecoder a -> Decoder a
-composite (CompositeDecoder decoder) =
+composite :: Composite a -> Value a
+composite (Composite decoder) =
numOfComponents *> decoder
where
numOfComponents =
unitOfSize 4
-- |
--- Lift a value 'Decoder' into 'CompositeDecoder'.
-{-# INLINE compositeValue #-}
-compositeValue :: Decoder a -> CompositeDecoder ( Maybe a )
-compositeValue valueDecoder =
- CompositeDecoder (skipOid *> onContent valueDecoder)
+-- Lift a value 'Value' into 'Composite'.
+{-# INLINE nullableValueComposite #-}
+nullableValueComposite :: Value a -> Composite ( Maybe a )
+nullableValueComposite valueValue =
+ Composite (skipOid *> onContent valueValue)
where
skipOid =
unitOfSize 4
-- |
--- Lift a non-nullable value 'Decoder' into 'CompositeDecoder'.
-{-# INLINE compositeNonNullValue #-}
-compositeNonNullValue :: Decoder a -> CompositeDecoder a
-compositeNonNullValue valueDecoder =
- CompositeDecoder (skipOid *> onContent valueDecoder >>= maybe (failure "Unexpected NULL") return)
+-- Lift a non-nullable value 'Value' into 'Composite'.
+{-# INLINE valueComposite #-}
+valueComposite :: Value a -> Composite a
+valueComposite valueValue =
+ Composite (skipOid *> onContent valueValue >>= maybe (failure "Unexpected NULL") return)
where
skipOid =
unitOfSize 4
@@ -500,20 +455,20 @@ compositeNonNullValue valueDecoder =
-- Here's how you can use it to produce a specific array value decoder:
--
-- @
--- x :: Decoder [ [ Text ] ]
+-- x :: Value [ [ Text ] ]
-- x =
--- array (arrayDimension replicateM (fmap catMaybes (arrayDimension replicateM (arrayValue text))))
+-- array (dimensionArray replicateM (fmap catMaybes (dimensionArray replicateM (nullableValueArray text))))
-- @
--
-newtype ArrayDecoder a =
- ArrayDecoder ( [ Word32 ] -> Decoder a )
+newtype Array a =
+ Array ( [ Word32 ] -> Value a )
deriving ( Functor )
-- |
--- Unlift an 'ArrayDecoder' to a value 'Decoder'.
+-- Unlift an 'Array' to a value 'Value'.
{-# INLINE array #-}
-array :: ArrayDecoder a -> Decoder a
-array (ArrayDecoder decoder) =
+array :: Array a -> Value a
+array (Array decoder) =
do
dimensionsAmount <- intOfSize 4
if dimensionsAmount /= 0
@@ -536,28 +491,28 @@ array (ArrayDecoder decoder) =
-- (@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 'arrayDimension' or 'arrayValue'.
+-- * A decoder of its components, which can be either another 'dimensionArray' or 'nullableValueArray'.
--
-{-# INLINE arrayDimension #-}
-arrayDimension :: ( forall m. Monad m => Int -> m a -> m b ) -> ArrayDecoder a -> ArrayDecoder b
-arrayDimension replicateM (ArrayDecoder component) =
- ArrayDecoder $ \case
+{-# INLINE dimensionArray #-}
+dimensionArray :: ( forall m. Monad m => Int -> m a -> m b ) -> Array a -> Array b
+dimensionArray replicateM (Array component) =
+ Array $ \case
head : tail -> replicateM (fromIntegral head) (component tail)
_ -> failure "A missing dimension length"
-- |
--- Lift a value 'Decoder' into 'ArrayDecoder' for parsing of nullable leaf values.
-{-# INLINE arrayValue #-}
-arrayValue :: Decoder a -> ArrayDecoder ( Maybe a )
-arrayValue =
- ArrayDecoder . const . onContent
+-- Lift a value 'Value' into 'Array' for parsing of nullable leaf values.
+{-# INLINE nullableValueArray #-}
+nullableValueArray :: Value a -> Array ( Maybe a )
+nullableValueArray =
+ Array . const . onContent
-- |
--- Lift a value 'Decoder' into 'ArrayDecoder' for parsing of non-nullable leaf values.
-{-# INLINE arrayNonNullValue #-}
-arrayNonNullValue :: Decoder a -> ArrayDecoder a
-arrayNonNullValue =
- ArrayDecoder . const . join . fmap (maybe (failure "Unexpected NULL") return) . onContent
+-- Lift a value 'Value' into 'Array' for parsing of non-nullable leaf values.
+{-# INLINE valueArray #-}
+valueArray :: Value a -> Array a
+valueArray =
+ Array . const . join . fmap (maybe (failure "Unexpected NULL") return) . onContent
-- * Enum
@@ -567,7 +522,7 @@ arrayNonNullValue =
-- Given a partial mapping from text to value,
-- produces a decoder of that value.
{-# INLINE enum #-}
-enum :: (Text -> Maybe a) -> Decoder a
+enum :: (Text -> Maybe a) -> Value a
enum mapping =
text_strict >>= onText
where
diff --git a/library/PostgreSQL/Binary/Encoder.hs b/library/PostgreSQL/Binary/Encoder.hs
deleted file mode 100644
index 3ea606e..0000000
--- a/library/PostgreSQL/Binary/Encoder.hs
+++ /dev/null
@@ -1,576 +0,0 @@
-{-# LANGUAGE CPP #-}
-module PostgreSQL.Binary.Encoder
-(
- run,
- -- * Value encoder
- Encoder,
- int2_int16,
- int2_word16,
- int4_int32,
- int4_word32,
- int8_int64,
- int8_word64,
- float4,
- float8,
- composite,
- bool,
- numeric,
- uuid,
- inet,
- json_ast,
- json_bytes,
- jsonb_ast,
- jsonb_bytes,
- char,
- text_strict,
- text_lazy,
- bytea_strict,
- bytea_lazy,
- date,
- time_int,
- time_float,
- timetz_int,
- timetz_float,
- timestamp_int,
- timestamp_float,
- timestamptz_int,
- timestamptz_float,
- interval_int,
- interval_float,
- hstore,
- hstoreRep,
- array,
- -- * Array encoder
- ArrayEncoder,
- arrayValue,
- arrayNullableValue,
- arrayDimension,
- arrayRep,
- -- * Enum
- enum,
-)
-where
-
-import PostgreSQL.Binary.Prelude hiding (take, bool, maybe)
-import Data.ByteString.Builder (Builder)
-import qualified Data.ByteString.Builder as Builder
-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.Lazy as LazyText
-import qualified Data.Text.Lazy.Encoding as LazyText
-import qualified Data.Vector as Vector
-import qualified Data.Scientific as Scientific
-import qualified Data.Aeson as Aeson
-import qualified Data.UUID as UUID
-import qualified PostgreSQL.Binary.Data as Data
-import qualified PostgreSQL.Binary.Integral as Integral
-import qualified PostgreSQL.Binary.Numeric as Numeric
-import qualified PostgreSQL.Binary.Time as Time
-import qualified PostgreSQL.Binary.Interval as Interval
-import qualified PostgreSQL.Binary.BuilderPrim as BuilderPrim
-import qualified PostgreSQL.Binary.Inet as Inet
-import qualified Control.Foldl as Foldl
-import qualified Network.IP.Addr as IPAddr
-
-
-type Encoder a =
- a -> Builder
-
-{-# INLINE run #-}
-run :: Encoder a -> a -> ByteString
-run encoder =
- LazyByteString.toStrict . Builder.toLazyByteString . encoder
-
-{-# INLINE tuple2 #-}
-tuple2 :: Encoder a -> Encoder b -> Encoder (a, b)
-tuple2 e1 e2 =
- \(v1, v2) -> e1 v1 <> e2 v2
-
-{-# INLINE tuple3 #-}
-tuple3 :: Encoder a -> Encoder b -> Encoder c -> Encoder (a, b, c)
-tuple3 e1 e2 e3 =
- \(v1, v2, v3) -> e1 v1 <> e2 v2 <> e3 v3
-
-{-# INLINE tuple4 #-}
-tuple4 :: Encoder a -> Encoder b -> Encoder c -> Encoder d -> Encoder (a, b, c, d)
-tuple4 e1 e2 e3 e4 =
- \(v1, v2, v3, v4) -> e1 v1 <> e2 v2 <> e3 v3 <> e4 v4
-
-{-# INLINE tuple5 #-}
-tuple5 :: Encoder a -> Encoder b -> Encoder c -> Encoder d -> Encoder e -> Encoder (a, b, c, d, e)
-tuple5 e1 e2 e3 e4 e5 (v1, v2, v3, v4, v5) = e1 v1 <> e2 v2 <> e3 v3 <> e4 v4 <> e5 v5
-
-{-# INLINE tuple8 #-}
-tuple8 :: Encoder a -> Encoder b -> Encoder c -> Encoder d -> Encoder e -> Encoder f -> Encoder g -> Encoder h -> Encoder (a, b, c, d, e, f, g, h)
-tuple8 e1 e2 e3 e4 e5 e6 e7 e8 (v1, v2, v3, v4, v5, v6, v7, v8) = e1 v1 <> e2 v2 <> e3 v3 <> e4 v4 <> e5 v5 <> e6 v6 <> e7 v7 <> e8 v8
-
-{-# INLINE premap #-}
-premap :: (a -> b) -> Encoder b -> Encoder a
-premap f e =
- e . f
-
-{-# INLINE int_int8 #-}
-int_int8 :: Encoder Int8
-int_int8 =
- Builder.int8
-
-{-# INLINE int_word8 #-}
-int_word8 :: Encoder Word8
-int_word8 =
- Builder.word8
-
-{-# INLINE int2_int16 #-}
-int2_int16 :: Encoder Int16
-int2_int16 =
- Builder.int16BE
-
-{-# INLINE int2_word16 #-}
-int2_word16 :: Encoder Word16
-int2_word16 =
- Builder.word16BE
-
-{-# INLINE int4_int32 #-}
-int4_int32 :: Encoder Int32
-int4_int32 =
- Builder.int32BE
-
-{-# INLINE int4_word32 #-}
-int4_word32 :: Encoder Word32
-int4_word32 =
- Builder.word32BE
-
-{-# INLINE int4_int #-}
-int4_int :: Encoder Int
-int4_int =
- int4_int32 . fromIntegral
-
-{-# INLINE int8_int64 #-}
-int8_int64 :: Encoder Int64
-int8_int64 =
- Builder.int64BE
-
-{-# INLINE int8_word64 #-}
-int8_word64 :: Encoder Word64
-int8_word64 =
- Builder.word64BE
-
-{-# INLINE float4 #-}
-float4 :: Encoder Float
-float4 =
- int4_int32 . unsafeCoerce
-
-{-# INLINE float8 #-}
-float8 :: Encoder Double
-float8 =
- int8_int64 . unsafeCoerce
-
-{-# INLINE null4 #-}
-null4 :: ByteStringBuilder
-null4 =
- Builder.string7 "\255\255\255\255"
-
-{-# INLINABLE composite #-}
-composite :: Encoder Data.Composite
-composite vector =
- int4_int (Vector.length vector) <>
- foldMap component vector
- where
- component (oid, theContent) =
- int4_word32 oid <> content theContent
-
-{-# INLINABLE content #-}
-content :: Encoder Data.Content
-content =
- \case
- Nothing ->
- null4
- Just content ->
- int4_int (ByteString.length content) <>
- Builder.byteString content
-
-{-# INLINABLE maybe #-}
-maybe :: Encoder a -> Encoder (Maybe a)
-maybe encoder =
- \case
- Nothing ->
- null4
- Just value ->
- run encoder value & \bytes -> int4_int (ByteString.length bytes) <> Builder.byteString bytes
-
-{-# INLINE bool #-}
-bool :: Encoder Bool
-bool =
- \case
- True -> Builder.word8 1
- False -> Builder.word8 0
-
-{-# INLINABLE numeric #-}
-numeric :: Encoder Scientific
-numeric x =
- int2_int16 (fromIntegral componentsAmount) <>
- int2_int16 (fromIntegral pointIndex) <>
- int2_word16 signCode <>
- int2_int16 (fromIntegral trimmedExponent) <>
- foldMap int2_int16 components
- where
- componentsAmount =
- length components
- coefficient =
- Scientific.coefficient x
- exponent =
- Scientific.base10Exponent x
- components =
- Numeric.extractComponents tunedCoefficient
- pointIndex =
- componentsAmount + (tunedExponent `div` 4) - 1
- (tunedCoefficient, tunedExponent) =
- case mod exponent 4 of
- 0 -> (coefficient, exponent)
- x -> (coefficient * 10 ^ x, exponent - x)
- trimmedExponent =
- if tunedExponent >= 0
- then 0
- else negate tunedExponent
- signCode =
- if coefficient < 0
- then Numeric.negSignCode
- else Numeric.posSignCode
-
-{-# INLINABLE uuid #-}
-uuid :: Encoder UUID
-uuid =
- premap UUID.toWords (tuple4 int4_word32 int4_word32 int4_word32 int4_word32)
-
-{-# INLINABLE ip4 #-}
-ip4 :: Encoder IPAddr.IP4
-ip4 =
- premap IPAddr.ip4ToOctets (tuple4 int_word8 int_word8 int_word8 int_word8)
-
-{-# INLINABLE ip6 #-}
-ip6 :: Encoder IPAddr.IP6
-ip6 =
- premap IPAddr.ip6ToWords (tuple8 int2_word16 int2_word16 int2_word16 int2_word16 int2_word16 int2_word16 int2_word16 int2_word16)
-
-{-# INLINABLE inet #-}
-inet :: Encoder (IPAddr.NetAddr IPAddr.IP)
-inet i =
- case IPAddr.netHost i of
- IPAddr.IPv4 x -> inetAddressFamily <> netLength <> isCidr <> ip4Size <> ip4 x
- IPAddr.IPv6 x -> inet6AddressFamily <> netLength <> isCidr <> ip6Size <> ip6 x
- where
- inetAddressFamily =
- int_word8 Inet.inetAddressFamily
- inet6AddressFamily =
- int_word8 Inet.inet6AddressFamily
- netLength =
- int_word8 (IPAddr.netLength i)
- isCidr =
- int_word8 0
- ip4Size =
- int_int8 4
- ip6Size =
- int_int8 16
-
-{-# INLINABLE json_ast #-}
-json_ast :: Encoder Aeson.Value
-#if MIN_VERSION_aeson(0,10,0)
-json_ast =
- Aeson.fromEncoding . Aeson.toEncoding
-#else
-json_ast =
- Builder.lazyByteString . Aeson.encode
-#endif
-
-{-# INLINABLE json_bytes #-}
-json_bytes :: Encoder ByteString
-json_bytes =
- Builder.byteString
-
-{-# INLINABLE jsonb_ast #-}
-jsonb_ast :: Encoder Aeson.Value
-jsonb_ast =
- \x -> "\1" <> json_ast x
-
-{-# INLINABLE jsonb_bytes #-}
-jsonb_bytes :: Encoder ByteString
-jsonb_bytes =
- \x -> "\1" <> Builder.byteString x
-
--- * Text
--------------------------
-
--- |
--- A UTF-8-encoded char.
---
--- Note that since it's UTF-8-encoded
--- not the \"char\" but the \"text\" OID should be used with it.
-{-# INLINABLE char #-}
-char :: Encoder Char
-char =
- Builder.charUtf8
-
-{-# INLINABLE text_strict #-}
-text_strict :: Encoder Text
-text_strict =
- Text.encodeUtf8BuilderEscaped BuilderPrim.nullByteIgnoringBoundedPrim
-
-{-# INLINABLE text_lazy #-}
-text_lazy :: Encoder LazyText.Text
-text_lazy =
- LazyText.encodeUtf8BuilderEscaped BuilderPrim.nullByteIgnoringBoundedPrim
-
-{-# INLINABLE bytea_strict #-}
-bytea_strict :: Encoder ByteString
-bytea_strict =
- Builder.byteString
-
-{-# INLINABLE bytea_lazy #-}
-bytea_lazy :: Encoder LazyByteString.ByteString
-bytea_lazy =
- Builder.lazyByteString
-
--- * Date and Time
--------------------------
-
-{-# INLINABLE date #-}
-date :: Encoder Day
-date =
- int4_int32 . fromIntegral . Time.dayToPostgresJulian
-
-{-# INLINABLE time_int #-}
-time_int :: Encoder TimeOfDay
-time_int (TimeOfDay h m s) =
- let
- p = unsafeCoerce s :: Integer
- u = p `div` (10^6)
- in int8_int64 (fromIntegral u + 10^6 * 60 * (fromIntegral m + 60 * fromIntegral h))
-
-{-# INLINABLE time_float #-}
-time_float :: Encoder TimeOfDay
-time_float (TimeOfDay h m s) =
- let
- p = unsafeCoerce s :: Integer
- u = p `div` (10^6)
- in float8 (fromIntegral u / 10^6 + 60 * (fromIntegral m + 60 * (fromIntegral h)))
-
-{-# INLINABLE timetz_int #-}
-timetz_int :: Encoder (TimeOfDay, TimeZone)
-timetz_int (timeX, tzX) =
- time_int timeX <> tz tzX
-
-{-# INLINABLE timetz_float #-}
-timetz_float :: Encoder (TimeOfDay, TimeZone)
-timetz_float (timeX, tzX) =
- time_float timeX <> tz tzX
-
-{-# INLINE tz #-}
-tz :: Encoder TimeZone
-tz =
- int4_int . (*60) . negate . timeZoneMinutes
-
-{-# INLINABLE timestamp_int #-}
-timestamp_int :: Encoder LocalTime
-timestamp_int =
- int8_int64 . Time.localTimeToMicros
-
-{-# INLINABLE timestamp_float #-}
-timestamp_float :: Encoder LocalTime
-timestamp_float =
- float8 . Time.localTimeToSecs
-
-{-# INLINABLE timestamptz_int #-}
-timestamptz_int :: Encoder UTCTime
-timestamptz_int =
- int8_int64 . Time.utcToMicros
-
-{-# INLINABLE timestamptz_float #-}
-timestamptz_float :: Encoder UTCTime
-timestamptz_float =
- float8 . Time.utcToSecs
-
-{-# INLINABLE interval_int #-}
-interval_int :: Encoder DiffTime
-interval_int x =
- Builder.int64BE u <>
- Builder.int32BE d <>
- Builder.int32BE m
- where
- Interval.Interval u d m =
- fromMaybe (error ("Too large DiffTime value for an interval " <> show x)) $
- Interval.fromDiffTime x
-
-{-# INLINABLE interval_float #-}
-interval_float :: Encoder DiffTime
-interval_float x =
- Builder.doubleBE s <>
- Builder.int32BE d <>
- Builder.int32BE m
- where
- Interval.Interval u d m =
- fromMaybe (error ("Too large DiffTime value for an interval " <> show x)) $
- Interval.fromDiffTime x
- s =
- fromIntegral u / (10^6)
-
-
--- * Array
--------------------------
-
-newtype ArrayEncoder a =
- ArrayEncoder (a -> (Builder, [Int32], Bool))
-
-{-# INLINABLE array #-}
-array :: Word32 -> ArrayEncoder a -> Encoder a
-array oid (ArrayEncoder encoder) =
- \value ->
- let
- (valuesBuilder, dimensions, nulls) =
- encoder value
- (dimensionsAmount, dimensionsBuilder) =
- let
- step (amount, builder) dimension =
- (succ amount, builder <> Builder.int32BE dimension <> Builder.word32BE 1)
- init =
- (0, mempty)
- in
- foldl' step init dimensions
- nullsBuilder =
- Builder.word32BE (if nulls then 1 else 0)
- in
- Builder.word32BE dimensionsAmount <> nullsBuilder <> Builder.word32BE oid <> dimensionsBuilder <> valuesBuilder
-
-{-# INLINABLE arrayValue #-}
-arrayValue :: Encoder a -> ArrayEncoder a
-arrayValue encoder =
- ArrayEncoder $ \value ->
- let
- bytes =
- run encoder value
- builder =
- Builder.word32BE (fromIntegral (ByteString.length bytes)) <>
- Builder.byteString bytes
- in
- (builder, [], False)
-
-{-# INLINABLE arrayNullableValue #-}
-arrayNullableValue :: Encoder a -> ArrayEncoder (Maybe a)
-arrayNullableValue encoder =
- ArrayEncoder $ \case
- Nothing ->
- (int4_int32 (-1), [], True)
- Just value ->
- let
- bytes =
- run encoder value
- builder =
- Builder.word32BE (fromIntegral (ByteString.length bytes)) <>
- Builder.byteString bytes
- in
- (builder, [], False)
-
-{-# INLINABLE arrayDimension #-}
-arrayDimension :: (forall a. (a -> b -> a) -> a -> c -> a) -> ArrayEncoder b -> ArrayEncoder c
-arrayDimension foldl (ArrayEncoder encoder) =
- ArrayEncoder $ \value ->
- let
- step (builder, _, length, nulls) value =
- let
- (valueBuilder, valueDimensions, valueNulls) = encoder value
- in
- (builder <> valueBuilder, valueDimensions, succ length, nulls || valueNulls)
- init =
- (mempty, [], 0, False)
- (foldedBuilder, foldedDimensions, foldedLength, foldedNulls) =
- foldl step init value
- resultDimensions =
- foldedLength : foldedDimensions
- in
- (foldedBuilder, resultDimensions, foldedNulls)
-
-
--- * Array rep
--------------------------
-
-{-# INLINABLE arrayRep #-}
-arrayRep :: Encoder Data.Array
-arrayRep (dimensionsV, valuesV, nullsV, oidV) =
- dimensionsLength <> nulls <> oid <> dimensions <> values
- where
- dimensionsLength =
- int4_word32 $ fromIntegral $ Vector.length dimensionsV
- nulls =
- int4_word32 $ if nullsV then 1 else 0
- oid =
- int4_word32 oidV
- dimensions =
- foldMap dimension dimensionsV
- values =
- foldMap value valuesV
- dimension (w, l) =
- int4_word32 w <> int4_word32 l
- value =
- \case
- Nothing -> int4_int32 (-1)
- Just b -> int4_int32 (fromIntegral (ByteString.length b)) <> Builder.byteString b
-
-
--- * HStore
--------------------------
-
--- |
--- A polymorphic in-place @HSTORE@ encoder.
---
--- Accepts:
---
--- * An implementation of the @foldl@ function
--- (e.g., @Data.Foldable.'foldl''@),
--- which determines the input value.
---
--- Here's how you can use it to produce a specific encoder:
---
--- @
--- hashMapHStore :: Encoder (Data.HashMap.Strict.HashMap Text (Maybe Text))
--- hashMapHStore =
--- hstore foldl'
--- @
---
-{-# INLINABLE hstore #-}
-hstore :: (forall a. (a -> (Text, Maybe Text) -> a) -> a -> b -> a) -> Encoder b
-hstore foldl =
- fold & \(Foldl.Fold step init fin) -> fin . foldl step init
- where
- fold =
- (<>) <$> componentsAmount <*> components
- where
- componentsAmount =
- fmap int4_int Foldl.length
- components =
- Foldl.foldMap componentBuilder id
- where
- componentBuilder (key, value) =
- text_strict key <> maybe text_strict value
-
-{-# INLINABLE hstoreRep #-}
-hstoreRep :: Encoder Data.HStore
-hstoreRep vector =
- int4_int32 (fromIntegral (Vector.length vector)) <>
- foldMap component vector
- where
- component (key, value) =
- Builder.byteString key <> content value
-
-
--- * Enum
--------------------------
-
--- |
--- Given a function,
--- which maps the value into the textual enum label from the DB side,
--- produces an encoder of that value
---
-{-# INLINE enum #-}
-enum :: (a -> Text) -> Encoder a
-enum asText =
- text_strict . asText
diff --git a/library/PostgreSQL/Binary/Encoding.hs b/library/PostgreSQL/Binary/Encoding.hs
new file mode 100644
index 0000000..c9caf0f
--- /dev/null
+++ b/library/PostgreSQL/Binary/Encoding.hs
@@ -0,0 +1,347 @@
+module PostgreSQL.Binary.Encoding
+(
+ -- * Encoding
+ Encoding,
+ encodingBytes,
+
+ -- *
+ array,
+ array_foldable,
+ array_vector,
+ nullableArray_vector,
+ hStore_foldable,
+ hStore_hashMap,
+ hStore_map,
+
+ -- * Primitives
+ bool,
+ int2_int16,
+ int2_word16,
+ int4_int32,
+ int4_word32,
+ int8_int64,
+ int8_word64,
+ float4,
+ float8,
+ numeric,
+ uuid,
+ inet,
+ char_utf8,
+ text_strict,
+ text_lazy,
+ bytea_strict,
+ bytea_lazy,
+ -- ** Time
+ -- | Some of the functions in this section are distinguished based
+ -- on the @integer_datetimes@ setting of the server.
+ date,
+ time_int,
+ time_float,
+ timetz_int,
+ timetz_float,
+ timestamp_int,
+ timestamp_float,
+ timestamptz_int,
+ timestamptz_float,
+ interval_int,
+ interval_float,
+ -- ** JSON
+ json_bytes,
+ json_ast,
+ jsonb_bytes,
+ jsonb_ast,
+
+ -- * Array
+ Array,
+ encodingArray,
+ nullArray,
+ dimensionArray,
+)
+where
+
+import PostgreSQL.Binary.Prelude hiding (bool, length)
+import qualified ByteString.StrictBuilder as C
+import qualified Data.Vector as A
+import qualified PostgreSQL.Binary.Encoding.Builders as B
+import qualified Data.ByteString.Builder as M
+import qualified Data.ByteString.Lazy as N
+import qualified Data.Text.Lazy as L
+import qualified Data.Aeson as R
+import qualified Network.IP.Addr as G
+
+
+type Encoding =
+ C.Builder
+
+{-# INLINE encodingBytes #-}
+encodingBytes :: Encoding -> ByteString
+encodingBytes =
+ C.builderBytes
+
+
+-- * Values
+-------------------------
+
+{-|
+Turn an array builder into final value.
+The first parameter is OID of the element type.
+-}
+{-# INLINE array #-}
+array :: Word32 -> Array -> Encoding
+array oid (Array payload dimensions nulls) =
+ B.array oid dimensions nulls payload
+
+{-|
+A helper for encoding of arrays of single dimension from foldables.
+The first parameter is OID of the element type.
+-}
+{-# INLINE array_foldable #-}
+array_foldable :: Foldable foldable => Word32 -> (element -> Maybe Encoding) -> foldable element -> Encoding
+array_foldable oid elementBuilder =
+ array oid . dimensionArray foldl' (maybe nullArray encodingArray . elementBuilder)
+
+{-|
+A helper for encoding of arrays of single dimension from vectors.
+The first parameter is OID of the element type.
+-}
+{-# INLINE array_vector #-}
+array_vector :: Word32 -> (element -> Encoding) -> Vector element -> Encoding
+array_vector oid elementBuilder vector =
+ B.array_vector oid elementBuilder vector
+
+{-|
+A helper for encoding of arrays of single dimension from vectors.
+The first parameter is OID of the element type.
+-}
+{-# INLINE nullableArray_vector #-}
+nullableArray_vector :: Word32 -> (element -> Encoding) -> Vector (Maybe element) -> Encoding
+nullableArray_vector oid elementBuilder vector =
+ B.nullableArray_vector oid elementBuilder vector
+
+{-|
+A polymorphic @HSTORE@ encoder.
+-}
+{-# INLINE hStore_foldable #-}
+hStore_foldable :: Foldable foldable => foldable (Text, Maybe Text) -> Encoding
+hStore_foldable =
+ B.hStoreUsingFoldl foldl
+
+{-|
+@HSTORE@ encoder from HashMap.
+-}
+{-# INLINE hStore_hashMap #-}
+hStore_hashMap :: HashMap Text (Maybe Text) -> Encoding
+hStore_hashMap =
+ B.hStore_hashMap
+
+{-|
+@HSTORE@ encoder from Map.
+-}
+{-# INLINE hStore_map #-}
+hStore_map :: Map Text (Maybe Text) -> Encoding
+hStore_map =
+ B.hStore_map
+
+
+-- * Primitive
+-------------------------
+
+{-# INLINE bool #-}
+bool :: Bool -> Encoding
+bool =
+ B.bool
+
+{-# INLINE int2_int16 #-}
+int2_int16 :: Int16 -> Encoding
+int2_int16 =
+ B.int2_int16
+
+{-# INLINE int2_word16 #-}
+int2_word16 :: Word16 -> Encoding
+int2_word16 =
+ B.int2_word16
+
+{-# INLINE int4_int32 #-}
+int4_int32 :: Int32 -> Encoding
+int4_int32 =
+ B.int4_int32
+
+{-# INLINE int4_word32 #-}
+int4_word32 :: Word32 -> Encoding
+int4_word32 =
+ B.int4_word32
+
+{-# INLINE int8_int64 #-}
+int8_int64 :: Int64 -> Encoding
+int8_int64 =
+ B.int8_int64
+
+{-# INLINE int8_word64 #-}
+int8_word64 :: Word64 -> Encoding
+int8_word64 =
+ B.int8_word64
+
+{-# INLINE float4 #-}
+float4 :: Float -> Encoding
+float4 =
+ B.float4
+
+{-# INLINE float8 #-}
+float8 :: Double -> Encoding
+float8 =
+ B.float8
+
+{-# INLINE numeric #-}
+numeric :: Scientific -> Encoding
+numeric =
+ B.numeric
+
+{-# INLINE uuid #-}
+uuid :: UUID -> Encoding
+uuid =
+ B.uuid
+
+{-# INLINE inet #-}
+inet :: G.NetAddr G.IP -> Encoding
+inet =
+ B.inet
+
+{-# INLINE char_utf8 #-}
+char_utf8 :: Char -> Encoding
+char_utf8 =
+ B.char_utf8
+
+{-# INLINE text_strict #-}
+text_strict :: Text -> Encoding
+text_strict =
+ B.text_strict
+
+{-# INLINE text_lazy #-}
+text_lazy :: L.Text -> Encoding
+text_lazy =
+ B.text_lazy
+
+{-# INLINE bytea_strict #-}
+bytea_strict :: ByteString -> Encoding
+bytea_strict =
+ B.bytea_strict
+
+{-# INLINE bytea_lazy #-}
+bytea_lazy :: N.ByteString -> Encoding
+bytea_lazy =
+ B.bytea_lazy
+
+{-# INLINE bytea_lazyBuilder #-}
+bytea_lazyBuilder :: M.Builder -> Encoding
+bytea_lazyBuilder =
+ B.bytea_lazyBuilder
+
+{-# INLINE date #-}
+date :: Day -> Encoding
+date =
+ B.date
+
+{-# INLINE time_int #-}
+time_int :: TimeOfDay -> Encoding
+time_int =
+ B.time_int
+
+{-# INLINE time_float #-}
+time_float :: TimeOfDay -> Encoding
+time_float =
+ B.time_float
+
+{-# INLINE timetz_int #-}
+timetz_int :: (TimeOfDay, TimeZone) -> Encoding
+timetz_int =
+ B.timetz_int
+
+{-# INLINE timetz_float #-}
+timetz_float :: (TimeOfDay, TimeZone) -> Encoding
+timetz_float =
+ B.timetz_float
+
+{-# INLINE timestamp_int #-}
+timestamp_int :: LocalTime -> Encoding
+timestamp_int =
+ B.timestamp_int
+
+{-# INLINE timestamp_float #-}
+timestamp_float :: LocalTime -> Encoding
+timestamp_float =
+ B.timestamp_float
+
+{-# INLINE timestamptz_int #-}
+timestamptz_int :: UTCTime -> Encoding
+timestamptz_int =
+ B.timestamptz_int
+
+{-# INLINE timestamptz_float #-}
+timestamptz_float :: UTCTime -> Encoding
+timestamptz_float =
+ B.timestamptz_float
+
+{-# INLINE interval_int #-}
+interval_int :: DiffTime -> Encoding
+interval_int =
+ B.interval_int
+
+{-# INLINE interval_float #-}
+interval_float :: DiffTime -> Encoding
+interval_float =
+ B.interval_float
+
+{-# INLINE json_bytes #-}
+json_bytes :: ByteString -> Encoding
+json_bytes =
+ B.json_bytes
+
+{-# INLINE json_ast #-}
+json_ast :: R.Value -> Encoding
+json_ast =
+ B.json_ast
+
+{-# INLINE jsonb_bytes #-}
+jsonb_bytes :: ByteString -> Encoding
+jsonb_bytes =
+ B.jsonb_bytes
+
+{-# INLINE jsonb_ast #-}
+jsonb_ast :: R.Value -> Encoding
+jsonb_ast =
+ B.jsonb_ast
+
+
+-- * Array
+-------------------------
+
+{-|
+Abstraction for encoding into multidimensional array.
+-}
+data Array =
+ Array !Encoding ![Int32] !Bool
+
+encodingArray :: Encoding -> Array
+encodingArray value =
+ Array (B.sized value) [] False
+
+nullArray :: Array
+nullArray =
+ Array B.null4 [] True
+
+dimensionArray :: (forall b. (b -> a -> b) -> b -> c -> b) -> (a -> Array) -> c -> Array
+dimensionArray foldl' elementArray input =
+ Array builder dimensions nulls
+ where
+ dimensions =
+ foldedLength : foldedDimensions
+ (builder, foldedDimensions, foldedLength, nulls) =
+ foldl' step init input
+ where
+ init =
+ (mempty, [], 0, False)
+ step (!builder, _, !length, !nulls) element =
+ (builder <> elementBuilder, elementDimensions, succ length, nulls || elementNulls)
+ where
+ Array elementBuilder elementDimensions elementNulls =
+ elementArray element
diff --git a/library/PostgreSQL/Binary/Encoding/Builders.hs b/library/PostgreSQL/Binary/Encoding/Builders.hs
new file mode 100644
index 0000000..e166c90
--- /dev/null
+++ b/library/PostgreSQL/Binary/Encoding/Builders.hs
@@ -0,0 +1,456 @@
+module PostgreSQL.Binary.Encoding.Builders
+where
+
+import PostgreSQL.Binary.Prelude hiding (bool)
+import ByteString.StrictBuilder
+import qualified Data.Vector as A
+import qualified Data.Scientific as D
+import qualified Data.UUID as E
+import qualified Data.ByteString.Builder as M
+import qualified Data.ByteString.Lazy as N
+import qualified Data.Text.Encoding as J
+import qualified Data.Text.Lazy as L
+import qualified Data.Text.Lazy.Encoding as K
+import qualified Data.HashMap.Strict as F
+import qualified Data.Map.Strict as Q
+import qualified Data.Aeson as R
+import qualified Network.IP.Addr as G
+import qualified PostgreSQL.Binary.Prelude as B
+import qualified PostgreSQL.Binary.Numeric as C
+import qualified PostgreSQL.Binary.Inet as H
+import qualified PostgreSQL.Binary.BuilderPrim as I
+import qualified PostgreSQL.Binary.Time as O
+import qualified PostgreSQL.Binary.Interval as P
+
+
+-- * Helpers
+-------------------------
+
+{-# NOINLINE null4 #-}
+null4 :: Builder
+null4 =
+ int4_int (-1)
+
+{-# INLINE sized #-}
+sized :: Builder -> Builder
+sized payload =
+ int4_int (builderLength payload) <>
+ payload
+
+{-# INLINE sizedMaybe #-}
+sizedMaybe :: (element -> Builder) -> Maybe element -> Builder
+sizedMaybe elementBuilder =
+ B.maybe null4 (sized . elementBuilder)
+
+{-# NOINLINE true1 #-}
+true1 :: Builder
+true1 =
+ word8 1
+
+{-# NOINLINE false1 #-}
+false1 :: Builder
+false1 =
+ word8 0
+
+{-# NOINLINE true4 #-}
+true4 :: Builder
+true4 =
+ int4_word32 1
+
+{-# NOINLINE false4 #-}
+false4 :: Builder
+false4 =
+ int4_word32 0
+
+
+-- * Primitives
+-------------------------
+
+{-# INLINE bool #-}
+bool :: Bool -> Builder
+bool =
+ B.bool false1 true1
+
+{-# INLINE int2_int16 #-}
+int2_int16 :: Int16 -> Builder
+int2_int16 =
+ int16BE
+
+{-# INLINE int2_word16 #-}
+int2_word16 :: Word16 -> Builder
+int2_word16 =
+ word16BE
+
+{-# INLINE int4_int32 #-}
+int4_int32 :: Int32 -> Builder
+int4_int32 =
+ int32BE
+
+{-# INLINE int4_word32 #-}
+int4_word32 :: Word32 -> Builder
+int4_word32 =
+ word32BE
+
+{-# INLINE int4_int #-}
+int4_int :: Int -> Builder
+int4_int =
+ int4_int32 . fromIntegral
+
+{-# INLINE int8_int64 #-}
+int8_int64 :: Int64 -> Builder
+int8_int64 =
+ int64BE
+
+{-# INLINE int8_word64 #-}
+int8_word64 :: Word64 -> Builder
+int8_word64 =
+ word64BE
+
+{-# INLINE float4 #-}
+float4 :: Float -> Builder
+float4 =
+ int4_int32 . unsafeCoerce
+
+{-# INLINE float8 #-}
+float8 :: Double -> Builder
+float8 =
+ int8_int64 . unsafeCoerce
+
+{-# INLINABLE numeric #-}
+numeric :: Scientific -> Builder
+numeric x =
+ word16BE (fromIntegral componentsAmount) <>
+ word16BE (fromIntegral pointIndex) <>
+ signCode <>
+ word16BE (fromIntegral trimmedExponent) <>
+ foldMap word16BE components
+ where
+ componentsAmount =
+ length components
+ coefficient =
+ D.coefficient x
+ exponent =
+ D.base10Exponent x
+ components =
+ C.extractComponents tunedCoefficient
+ pointIndex =
+ componentsAmount + (tunedExponent `div` 4) - 1
+ (tunedCoefficient, tunedExponent) =
+ case mod exponent 4 of
+ 0 -> (coefficient, exponent)
+ x -> (coefficient * 10 ^ x, exponent - x)
+ trimmedExponent =
+ if tunedExponent >= 0
+ then 0
+ else negate tunedExponent
+ signCode =
+ if coefficient < 0
+ then numericNegSignCode
+ else numericPosSignCode
+
+{-# NOINLINE numericNegSignCode #-}
+numericNegSignCode :: Builder
+numericNegSignCode =
+ int2_word16 C.negSignCode
+
+{-# NOINLINE numericPosSignCode #-}
+numericPosSignCode :: Builder
+numericPosSignCode =
+ int2_word16 C.posSignCode
+
+{-# INLINE uuid #-}
+uuid :: UUID -> Builder
+uuid uuid =
+ case E.toWords uuid of
+ (w1, w2, w3, w4) -> int4_word32 w1 <> int4_word32 w2 <> int4_word32 w3 <> int4_word32 w4
+
+{-# INLINABLE ip4 #-}
+ip4 :: G.IP4 -> Builder
+ip4 x =
+ case G.ip4ToOctets x of
+ (w1, w2, w3, w4) -> word8 w1 <> word8 w2 <> word8 w3 <> word8 w4
+
+{-# INLINABLE ip6 #-}
+ip6 :: G.IP6 -> Builder
+ip6 x =
+ case G.ip6ToWords x of
+ (w1, w2, w3, w4, w5, w6, w7, w8) ->
+ int2_word16 w1 <> int2_word16 w2 <> int2_word16 w3 <> int2_word16 w4 <>
+ int2_word16 w5 <> int2_word16 w6 <> int2_word16 w7 <> int2_word16 w8
+
+{-# INLINABLE inet #-}
+inet :: G.NetAddr G.IP -> Builder
+inet i =
+ case G.netHost i of
+ G.IPv4 x -> inetAddressFamily <> netLength <> isCidr <> ip4Size <> ip4 x
+ G.IPv6 x -> inet6AddressFamily <> netLength <> isCidr <> ip6Size <> ip6 x
+ where
+ netLength =
+ word8 (G.netLength i)
+ isCidr =
+ false1
+
+{-# NOINLINE inetAddressFamily #-}
+inetAddressFamily :: Builder
+inetAddressFamily =
+ word8 H.inetAddressFamily
+
+{-# NOINLINE inet6AddressFamily #-}
+inet6AddressFamily :: Builder
+inet6AddressFamily =
+ word8 H.inet6AddressFamily
+
+{-# NOINLINE ip4Size #-}
+ip4Size :: Builder
+ip4Size =
+ word8 4
+
+{-# NOINLINE ip6Size #-}
+ip6Size :: Builder
+ip6Size =
+ word8 16
+
+
+-- * Text
+-------------------------
+
+-- |
+-- A UTF-8-encoded char.
+--
+-- Note that since it's UTF-8-encoded
+-- not the \"char\" but the \"text\" OID should be used with it.
+{-# INLINE char_utf8 #-}
+char_utf8 :: Char -> Builder
+char_utf8 =
+ utf8Char
+
+{-# INLINE text_strict #-}
+text_strict :: Text -> Builder
+text_strict =
+ bytea_lazyBuilder . J.encodeUtf8BuilderEscaped I.nullByteIgnoringBoundedPrim
+
+{-# INLINE text_lazy #-}
+text_lazy :: L.Text -> Builder
+text_lazy =
+ bytea_lazyBuilder . K.encodeUtf8BuilderEscaped I.nullByteIgnoringBoundedPrim
+
+{-# INLINE bytea_strict #-}
+bytea_strict :: ByteString -> Builder
+bytea_strict =
+ bytes
+
+{-# INLINE bytea_lazy #-}
+bytea_lazy :: N.ByteString -> Builder
+bytea_lazy =
+ lazyBytes
+
+{-# INLINE bytea_lazyBuilder #-}
+bytea_lazyBuilder :: M.Builder -> Builder
+bytea_lazyBuilder =
+ lazyBytes . M.toLazyByteString
+
+
+-- * Time
+-------------------------
+
+{-# INLINE date #-}
+date :: Day -> Builder
+date =
+ int4_int32 . fromIntegral . O.dayToPostgresJulian
+
+{-# INLINABLE time_int #-}
+time_int :: TimeOfDay -> Builder
+time_int (TimeOfDay h m s) =
+ let
+ p = unsafeCoerce s :: Integer
+ u = p `div` (10^6)
+ in int8_int64 (fromIntegral u + 10^6 * 60 * (fromIntegral m + 60 * fromIntegral h))
+
+{-# INLINABLE time_float #-}
+time_float :: TimeOfDay -> Builder
+time_float (TimeOfDay h m s) =
+ let
+ p = unsafeCoerce s :: Integer
+ u = p `div` (10^6)
+ in float8 (fromIntegral u / 10^6 + 60 * (fromIntegral m + 60 * (fromIntegral h)))
+
+{-# INLINE timetz_int #-}
+timetz_int :: (TimeOfDay, TimeZone) -> Builder
+timetz_int (timeX, tzX) =
+ time_int timeX <> tz tzX
+
+{-# INLINE timetz_float #-}
+timetz_float :: (TimeOfDay, TimeZone) -> Builder
+timetz_float (timeX, tzX) =
+ time_float timeX <> tz tzX
+
+{-# INLINE tz #-}
+tz :: TimeZone -> Builder
+tz =
+ int4_int . (*60) . negate . timeZoneMinutes
+
+{-# INLINE timestamp_int #-}
+timestamp_int :: LocalTime -> Builder
+timestamp_int =
+ int8_int64 . O.localTimeToMicros
+
+{-# INLINE timestamp_float #-}
+timestamp_float :: LocalTime -> Builder
+timestamp_float =
+ float8 . O.localTimeToSecs
+
+{-# INLINE timestamptz_int #-}
+timestamptz_int :: UTCTime -> Builder
+timestamptz_int =
+ int8_int64 . O.utcToMicros
+
+{-# INLINE timestamptz_float #-}
+timestamptz_float :: UTCTime -> Builder
+timestamptz_float =
+ float8 . O.utcToSecs
+
+{-# INLINABLE interval_int #-}
+interval_int :: DiffTime -> Builder
+interval_int x =
+ int64BE u <>
+ int32BE d <>
+ int32BE m
+ where
+ P.Interval u d m =
+ fromMaybe (error ("Too large DiffTime value for an interval " <> show x)) $
+ P.fromDiffTime x
+
+{-# INLINABLE interval_float #-}
+interval_float :: DiffTime -> Builder
+interval_float x =
+ float8 s <>
+ int32BE d <>
+ int32BE m
+ where
+ P.Interval u d m =
+ fromMaybe (error ("Too large DiffTime value for an interval " <> show x)) $
+ P.fromDiffTime x
+ s =
+ fromIntegral u / (10^6)
+
+
+-- * JSON
+-------------------------
+
+{-# INLINE json_bytes #-}
+json_bytes :: ByteString -> Builder
+json_bytes =
+ bytes
+
+{-# INLINE json_ast #-}
+json_ast :: R.Value -> Builder
+json_ast =
+ lazyBytes . R.encode
+
+{-# INLINE jsonb_bytes #-}
+jsonb_bytes :: ByteString -> Builder
+jsonb_bytes =
+ mappend "\1" . bytes
+
+{-# INLINE jsonb_ast #-}
+jsonb_ast :: R.Value -> Builder
+jsonb_ast =
+ mappend "\1" . json_ast
+
+
+-- * Array
+-------------------------
+
+{-# INLINE array_vector #-}
+array_vector :: Word32 -> (element -> Builder) -> Vector element -> Builder
+array_vector oid elementBuilder vector =
+ array oid dimensions False payload
+ where
+ dimensions =
+ [fromIntegral (A.length vector)]
+ payload =
+ foldMap (sized . elementBuilder) vector
+
+{-# INLINE nullableArray_vector #-}
+nullableArray_vector :: Word32 -> (element -> Builder) -> Vector (Maybe element) -> Builder
+nullableArray_vector oid elementBuilder vector =
+ array oid dimensions True payload
+ where
+ dimensions =
+ [fromIntegral (A.length vector)]
+ payload =
+ foldMap (sizedMaybe elementBuilder) vector
+
+{-# INLINABLE array #-}
+array :: Word32 -> [Int32] -> Bool -> Builder -> Builder
+array oid dimensions nulls payload =
+ int4_int (B.length dimensions) <>
+ B.bool false4 true4 nulls <>
+ int4_word32 oid <>
+ foldMap arrayDimension dimensions <>
+ payload
+
+{-# INLINE arrayDimension #-}
+arrayDimension :: Int32 -> Builder
+arrayDimension dimension =
+ int4_int32 dimension <> true4
+
+
+-- * HStore
+-------------------------
+
+{-|
+A polymorphic in-place @HSTORE@ encoder.
+
+Accepts:
+
+* An implementation of the @foldl@ function
+(e.g., @Data.Foldable.'foldl''@),
+which determines the input value.
+
+Here's how you can use it to produce a specific encoder:
+
+@
+hashMapHStore :: Data.HashMap.Strict.HashMap Text (Maybe Text) -> Builder
+hashMapHStore =
+ hStoreUsingFoldl foldl'
+@
+-}
+{-# INLINABLE hStoreUsingFoldl #-}
+hStoreUsingFoldl :: (forall a. (a -> (Text, Maybe Text) -> a) -> a -> b -> a) -> b -> Builder
+hStoreUsingFoldl foldl =
+ exit . foldl progress enter
+ where
+ enter =
+ (0, mempty)
+ progress (!count, !payload) (key, value) =
+ (succ count, payload <> hStoreRow key value)
+ exit (count, payload) =
+ int4_int count <> payload
+
+{-# INLINE hStoreUsingFoldMapAndSize #-}
+hStoreUsingFoldMapAndSize :: (forall a. Monoid a => ((Text, Maybe Text) -> a) -> b -> a) -> Int -> b -> Builder
+hStoreUsingFoldMapAndSize foldMap size input =
+ int4_int size <> foldMap (uncurry hStoreRow) input
+
+{-# INLINE hStoreFromFoldMapAndSize #-}
+hStoreFromFoldMapAndSize :: (forall a. Monoid a => (Text -> Maybe Text -> a) -> a) -> Int -> Builder
+hStoreFromFoldMapAndSize foldMap size =
+ int4_int size <> foldMap hStoreRow
+
+{-# INLINE hStoreRow #-}
+hStoreRow :: Text -> Maybe Text -> Builder
+hStoreRow key value =
+ sized (text_strict key) <> sizedMaybe text_strict value
+
+{-# INLINE hStore_hashMap #-}
+hStore_hashMap :: HashMap Text (Maybe Text) -> Builder
+hStore_hashMap input =
+ int4_int (F.size input) <>
+ F.foldlWithKey' (\payload key value -> payload <> hStoreRow key value) mempty input
+
+{-# INLINE hStore_map #-}
+hStore_map :: Map Text (Maybe Text) -> Builder
+hStore_map input =
+ int4_int (Q.size input) <>
+ Q.foldlWithKey' (\payload key value -> payload <> hStoreRow key value) mempty input
diff --git a/library/PostgreSQL/Binary/Numeric.hs b/library/PostgreSQL/Binary/Numeric.hs
index b396355..e97bb13 100644
--- a/library/PostgreSQL/Binary/Numeric.hs
+++ b/library/PostgreSQL/Binary/Numeric.hs
@@ -18,7 +18,7 @@ nanSignCode :: Word16
nanSignCode = 0xC000
{-# INLINE extractComponents #-}
-extractComponents :: Integral a => a -> [Int16]
+extractComponents :: Integral a => a -> [Word16]
extractComponents =
(reverse .) . (. abs) . unfoldr $ \case
0 -> Nothing
diff --git a/library/PostgreSQL/Binary/Prelude.hs b/library/PostgreSQL/Binary/Prelude.hs
index 626d768..ad521ac 100644
--- a/library/PostgreSQL/Binary/Prelude.hs
+++ b/library/PostgreSQL/Binary/Prelude.hs
@@ -48,6 +48,14 @@ import Data.UUID as Exports (UUID)
-------------------------
import Data.Time as Exports
+-- unordered-containers
+-------------------------
+import Data.HashMap.Strict as Exports (HashMap)
+
+-- containers
+-------------------------
+import Data.Map.Strict as Exports (Map)
+
-- placeholders
-------------------------
import Development.Placeholders as Exports
diff --git a/postgresql-binary.cabal b/postgresql-binary.cabal
index 82e374e..f55907f 100644
--- a/postgresql-binary.cabal
+++ b/postgresql-binary.cabal
@@ -1,7 +1,7 @@
name:
postgresql-binary
version:
- 0.10
+ 0.12.1
synopsis:
Encoders and decoders for the PostgreSQL's binary format
description:
@@ -40,14 +40,12 @@ tested-with:
GHC==7.10.1,
GHC==8.0.1
-
source-repository head
type:
git
location:
git://github.com/nikita-volkov/postgresql-binary.git
-
library
hs-source-dirs:
library
@@ -58,10 +56,11 @@ library
default-language:
Haskell2010
exposed-modules:
+ PostgreSQL.Binary.Decoding
+ PostgreSQL.Binary.Encoding
PostgreSQL.Binary.Data
- PostgreSQL.Binary.Decoder
- PostgreSQL.Binary.Encoder
other-modules:
+ PostgreSQL.Binary.Encoding.Builders
PostgreSQL.Binary.Prelude
PostgreSQL.Binary.Integral
PostgreSQL.Binary.Interval
@@ -72,6 +71,8 @@ library
build-depends:
-- parsing:
binary-parser >= 0.5 && < 0.6,
+ -- building:
+ bytestring-strict-builder >= 0.4.2 && < 0.5,
-- data:
aeson >= 0.9 && < 2,
uuid == 1.3.*,
@@ -81,16 +82,16 @@ library
text >= 1 && < 2,
vector >= 0.10 && < 0.13,
network-ip >= 0.2 && < 1,
+ unordered-containers == 0.2.*,
+ containers == 0.5.*,
-- errors:
loch-th == 0.2.*,
placeholders == 0.1.*,
-- general:
- foldl >= 1.1.1 && < 2,
transformers >= 0.3 && < 0.6,
base-prelude >= 0.1.19 && < 2,
base >= 4.6 && < 5
-
-- This test-suite must be executed in a single-thread.
test-suite tasty
type:
@@ -135,7 +136,6 @@ test-suite tasty
-- general:
rerebase >= 1.0.2 && < 2
-
benchmark encoding
type:
exitcode-stdio-1.0
@@ -159,7 +159,6 @@ benchmark encoding
-- general:
rerebase < 2
-
benchmark decoding
type:
exitcode-stdio-1.0
diff --git a/tasty/Main.hs b/tasty/Main.hs
index d75fb75..2ab51ad 100644
--- a/tasty/Main.hs
+++ b/tasty/Main.hs
@@ -8,8 +8,8 @@ import qualified Test.Tasty.HUnit as HUnit
import qualified Test.Tasty.SmallCheck as SmallCheck
import qualified Test.Tasty.QuickCheck as QuickCheck
import qualified Test.QuickCheck as QuickCheck
-import qualified PostgreSQL.Binary.Encoder as Encoder
-import qualified PostgreSQL.Binary.Decoder as Decoder
+import qualified PostgreSQL.Binary.Encoding as A
+import qualified PostgreSQL.Binary.Decoding as B
import qualified Data.ByteString as ByteString
import qualified Main.DB as DB
import qualified Main.Gens as Gens
@@ -32,7 +32,7 @@ binary =
where
jsonb =
if version >= 90400
- then [stdRoundtrip "jsonb" Gens.aeson PTI.jsonb Encoder.jsonb_ast Decoder.jsonb_ast]
+ then [primitiveRoundtrip "jsonb" Gens.aeson PTI.jsonb A.jsonb_ast B.jsonb_ast]
else []
other =
[
@@ -40,7 +40,7 @@ binary =
sql =
"select (1, 'a')"
decoder _ =
- Decoder.composite ((,) <$> Decoder.compositeNonNullValue Decoder.int <*> Decoder.compositeNonNullValue Decoder.char)
+ B.composite ((,) <$> B.valueComposite B.int <*> B.valueComposite B.char)
expected =
(1 :: Int64, 'a')
in select sql decoder expected
@@ -49,27 +49,27 @@ binary =
sql =
"select (1, null)"
decoder _ =
- Decoder.composite ((,) <$> Decoder.compositeNonNullValue Decoder.int <*> Decoder.compositeValue Decoder.char)
+ B.composite ((,) <$> B.valueComposite B.int <*> B.nullableValueComposite B.char)
expected =
(1 :: Int64, Nothing :: Maybe Char)
in select sql decoder expected
,
select "SELECT '1 year 2 months 3 days 4 hours 5 minutes 6 seconds 332211 microseconds' :: interval"
- (bool Decoder.interval_float Decoder.interval_int)
+ (bool B.interval_float B.interval_int)
(picosecondsToDiffTime (10^6 * (332211 + 10^6 * (6 + 60 * (5 + 60 * (4 + 24 * (3 + 31 * (2 + 12))))))))
,
select "SELECT '10 seconds' :: interval"
- (bool Decoder.interval_float Decoder.interval_int)
+ (bool B.interval_float B.interval_int)
(10 :: DiffTime)
,
HUnit.testCase "Interval encoder: 10 seconds" $
let
pti =
PTI.interval
- encoder =
- (bool Encoder.interval_float Encoder.interval_int)
+ encoder integerDatetimes =
+ (bool A.interval_float A.interval_int integerDatetimes)
decoder =
- (bool Decoder.interval_float Decoder.interval_int)
+ (bool B.interval_float B.interval_int)
value =
(10 :: DiffTime)
in
@@ -77,113 +77,114 @@ binary =
IO.roundtrip (PTI.oidPQ (PTI.ptiOID pti)) encoder decoder value
,
timeRoundtrip "interval" Gens.intervalDiffTime PTI.interval
- (bool Encoder.interval_float Encoder.interval_int)
- (bool Decoder.interval_float Decoder.interval_int)
+ (bool A.interval_float A.interval_int)
+ (bool B.interval_float B.interval_int)
,
timeRoundtrip "timestamp" (fmap Apx Gens.auto) PTI.timestamp
- ((. unApx) . bool Encoder.timestamp_float Encoder.timestamp_int)
- (fmap Apx . bool Decoder.timestamp_float Decoder.timestamp_int)
+ ((. unApx) . bool A.timestamp_float A.timestamp_int)
+ (fmap Apx . bool B.timestamp_float B.timestamp_int)
,
HUnit.testCase "timestamptz offset" $ do
Right (textual, decoded) <-
DB.session $ do
integerDatetimes <- DB.integerDatetimes
- let encoder = bool Encoder.timestamptz_float Encoder.timestamptz_int integerDatetimes
- decoder = bool Decoder.timestamptz_float Decoder.timestamptz_int integerDatetimes
+ let encoder = bool A.timestamptz_float A.timestamptz_int integerDatetimes
+ decoder = bool B.timestamptz_float B.timestamptz_int integerDatetimes
DB.unit "DROP TABLE IF EXISTS a" []
DB.unit "CREATE TABLE a (b TIMESTAMPTZ)" []
DB.unit "set timezone to 'America/Los_Angeles'" []
let p = (,,) (PTI.oidPQ (PTI.ptiOID PTI.timestamptz))
- (Encoder.run encoder x)
+ ((A.encodingBytes . encoder) x)
(LibPQ.Binary)
x = read "2011-09-28 00:17:25"
DB.unit "insert into a (b) values ($1)" [Just p]
DB.unit "set timezone to 'Europe/Stockholm'" []
textual <- DB.oneRow "SELECT * FROM a" [] LibPQ.Text
- decoded <- fmap (Decoder.run decoder) (DB.oneRow "SELECT * FROM a" [] LibPQ.Binary)
+ decoded <- fmap (B.valueParser decoder) (DB.oneRow "SELECT * FROM a" [] LibPQ.Binary)
return (textual, decoded)
HUnit.assertEqual "" ("2011-09-28 02:17:25+02") textual
HUnit.assertEqual "" (Right (read "2011-09-28 00:17:25")) decoded
,
timeRoundtrip "timestamptz" (fmap Apx Gens.auto) PTI.timestamptz
- ((. unApx) . bool Encoder.timestamptz_float Encoder.timestamptz_int)
- (fmap Apx . bool Decoder.timestamptz_float Decoder.timestamptz_int)
+ ((. unApx) . bool A.timestamptz_float A.timestamptz_int)
+ (fmap Apx . bool B.timestamptz_float B.timestamptz_int)
,
timeRoundtrip "timetz" (fmap Apx Gens.timetz) PTI.timetz
- ((. unApx) . bool Encoder.timetz_float Encoder.timetz_int)
- (fmap Apx . bool Decoder.timetz_float Decoder.timetz_int)
+ ((. unApx) . bool A.timetz_float A.timetz_int)
+ (fmap Apx . bool B.timetz_float B.timetz_int)
,
timeRoundtrip "time" (fmap Apx Gens.auto) PTI.time
- ((. unApx) . bool Encoder.time_float Encoder.time_int)
- (fmap Apx . bool Decoder.time_float Decoder.time_int)
+ ((. unApx) . bool A.time_float A.time_int)
+ (fmap Apx . bool B.time_float B.time_int)
,
- stdRoundtrip "numeric" Gens.scientific PTI.numeric Encoder.numeric Decoder.numeric
+ primitiveRoundtrip "numeric" Gens.scientific PTI.numeric A.numeric B.numeric
,
- select "SELECT -1234560.789 :: numeric" (const Decoder.numeric) (read "-1234560.789")
+ select "SELECT -1234560.789 :: numeric" (const B.numeric) (read "-1234560.789")
,
- select "SELECT -0.0789 :: numeric" (const Decoder.numeric) (read "-0.0789")
+ select "SELECT -0.0789 :: numeric" (const B.numeric) (read "-0.0789")
,
- select "SELECT 10000 :: numeric" (const Decoder.numeric) (read "10000")
+ select "SELECT 10000 :: numeric" (const B.numeric) (read "10000")
,
- stdRoundtrip "float4" Gens.auto PTI.float4 Encoder.float4 Decoder.float4
+ primitiveRoundtrip "float4" Gens.auto PTI.float4 A.float4 B.float4
,
- stdRoundtrip "float8" Gens.auto PTI.float8 Encoder.float8 Decoder.float8
+ primitiveRoundtrip "float8" Gens.auto PTI.float8 A.float8 B.float8
,
- stdRoundtrip "char" Gens.char PTI.text Encoder.char Decoder.char
+ primitiveRoundtrip "char" Gens.char PTI.text A.char_utf8 B.char
,
- stdRoundtrip "text_strict" Gens.text PTI.text Encoder.text_strict Decoder.text_strict
+ primitiveRoundtrip "text_strict" Gens.text PTI.text A.text_strict B.text_strict
,
- stdRoundtrip "text_lazy" (fmap convert Gens.text) PTI.text Encoder.text_lazy Decoder.text_lazy
+ primitiveRoundtrip "text_lazy" (fmap convert Gens.text) PTI.text A.text_lazy B.text_lazy
,
- stdRoundtrip "bytea_strict" Gens.auto PTI.bytea Encoder.bytea_strict Decoder.bytea_strict
+ primitiveRoundtrip "bytea_strict" Gens.auto PTI.bytea A.bytea_strict B.bytea_strict
,
- stdRoundtrip "bytea_lazy" Gens.auto PTI.bytea Encoder.bytea_lazy Decoder.bytea_lazy
+ primitiveRoundtrip "bytea_lazy" Gens.auto PTI.bytea A.bytea_lazy B.bytea_lazy
,
- stdRoundtrip "uuid" Gens.uuid PTI.uuid Encoder.uuid Decoder.uuid
+ primitiveRoundtrip "uuid" Gens.uuid PTI.uuid A.uuid B.uuid
,
- stdRoundtrip "inet" Gens.inet PTI.inet Encoder.inet Decoder.inet
+ primitiveRoundtrip "inet" Gens.inet PTI.inet A.inet B.inet
,
- stdRoundtrip "int2_int16" Gens.auto PTI.int2 Encoder.int2_int16 Decoder.int
+ primitiveRoundtrip "int2_int16" Gens.auto PTI.int2 A.int2_int16 B.int
,
- stdRoundtrip "int2_word16" Gens.auto PTI.int2 Encoder.int2_word16 Decoder.int
+ primitiveRoundtrip "int2_word16" Gens.auto PTI.int2 A.int2_word16 B.int
,
- stdRoundtrip "int4_int32" Gens.auto PTI.int4 Encoder.int4_int32 Decoder.int
+ primitiveRoundtrip "int4_int32" Gens.auto PTI.int4 A.int4_int32 B.int
,
- stdRoundtrip "int4_word32" Gens.auto PTI.int4 Encoder.int4_word32 Decoder.int
+ primitiveRoundtrip "int4_word32" Gens.auto PTI.int4 A.int4_word32 B.int
,
- stdRoundtrip "int8_int64" Gens.auto PTI.int8 Encoder.int8_int64 Decoder.int
+ primitiveRoundtrip "int8_int64" Gens.auto PTI.int8 A.int8_int64 B.int
,
- stdRoundtrip "int8_word64" Gens.auto PTI.int8 Encoder.int8_word64 Decoder.int
+ primitiveRoundtrip "int8_word64" Gens.auto PTI.int8 A.int8_word64 B.int
,
- stdRoundtrip "bool" Gens.auto PTI.bool Encoder.bool Decoder.bool
+ primitiveRoundtrip "bool" Gens.auto PTI.bool A.bool B.bool
,
- stdRoundtrip "date" Gens.auto PTI.date Encoder.date Decoder.date
+ primitiveRoundtrip "date" Gens.auto PTI.date A.date B.date
,
let
decoder =
- Decoder.array $
- Decoder.arrayDimension replicateM $
- Decoder.arrayDimension replicateM $
- Decoder.arrayNonNullValue $
- Decoder.int
+ B.array $
+ B.dimensionArray replicateM $
+ B.dimensionArray replicateM $
+ B.valueArray $
+ B.int
in
select "SELECT ARRAY[ARRAY[1,2],ARRAY[3,4]]" (const decoder) ([[1,2],[3,4]] :: [[Int]])
,
let
encoder =
- Encoder.array (PTI.oidWord32 (PTI.ptiOID PTI.int8)) $
- Encoder.arrayDimension foldl' $
- Encoder.arrayDimension foldl' $
- Encoder.arrayDimension foldl' $
- Encoder.arrayValue $
- Encoder.int8_int64
+ A.array (PTI.oidWord32 (PTI.ptiOID PTI.int8)) . arrayEncoder
+ where
+ arrayEncoder =
+ A.dimensionArray foldl' $
+ A.dimensionArray foldl' $
+ A.dimensionArray foldl' $
+ A.encodingArray . A.int8_int64
decoder =
- Decoder.array $
- Decoder.arrayDimension replicateM $
- Decoder.arrayDimension replicateM $
- Decoder.arrayDimension replicateM $
- Decoder.arrayNonNullValue $
- Decoder.int
+ B.array $
+ B.dimensionArray replicateM $
+ B.dimensionArray replicateM $
+ B.dimensionArray replicateM $
+ B.valueArray $
+ B.int
in
arrayCodec (Gens.array3 Gens.auto) encoder decoder
,
@@ -191,19 +192,20 @@ binary =
pti =
PTI.text
encoder =
- Encoder.array (PTI.oidWord32 (PTI.ptiOID pti)) $
- Encoder.arrayDimension foldl' $
- Encoder.arrayDimension foldl' $
- Encoder.arrayDimension foldl' $
- Encoder.arrayValue $
- Encoder.text_strict
+ A.array (PTI.oidWord32 (PTI.ptiOID pti)) . arrayEncoder
+ where
+ arrayEncoder =
+ A.dimensionArray foldl' $
+ A.dimensionArray foldl' $
+ A.dimensionArray foldl' $
+ A.encodingArray . A.text_strict
decoder =
- Decoder.array $
- Decoder.arrayDimension replicateM $
- Decoder.arrayDimension replicateM $
- Decoder.arrayDimension replicateM $
- Decoder.arrayNonNullValue $
- Decoder.text_strict
+ B.array $
+ B.dimensionArray replicateM $
+ B.dimensionArray replicateM $
+ B.dimensionArray replicateM $
+ B.valueArray $
+ B.text_strict
in
arrayRoundtrip (Gens.array3 Gens.text) pti encoder decoder
]
@@ -211,27 +213,27 @@ binary =
textual =
testGroup "Textual format" $
[
- test "numeric" Gens.scientific PTI.numeric TextEncoder.numeric (const Decoder.numeric)
+ test "numeric" Gens.scientific PTI.numeric TextEncoder.numeric (const B.numeric)
,
- test "float4" Gens.auto PTI.float4 TextEncoder.float4 (const Decoder.float4)
+ test "float4" Gens.auto PTI.float4 TextEncoder.float4 (const B.float4)
,
- test "float8" Gens.auto PTI.float8 TextEncoder.float8 (const Decoder.float8)
+ test "float8" Gens.auto PTI.float8 TextEncoder.float8 (const B.float8)
,
- test "uuid" Gens.uuid PTI.uuid TextEncoder.uuid (const Decoder.uuid)
+ test "uuid" Gens.uuid PTI.uuid TextEncoder.uuid (const B.uuid)
,
- test "int2_int16" Gens.auto PTI.int2 TextEncoder.int2_int16 (const Decoder.int)
+ test "int2_int16" Gens.auto PTI.int2 TextEncoder.int2_int16 (const B.int)
,
- test "int2_word16" Gens.postgresInt PTI.int2 TextEncoder.int2_word16 (const Decoder.int)
+ test "int2_word16" Gens.postgresInt PTI.int2 TextEncoder.int2_word16 (const B.int)
,
- test "int4_int32" Gens.auto PTI.int4 TextEncoder.int4_int32 (const Decoder.int)
+ test "int4_int32" Gens.auto PTI.int4 TextEncoder.int4_int32 (const B.int)
,
- test "int4_word32" Gens.postgresInt PTI.int4 TextEncoder.int4_word32 (const Decoder.int)
+ test "int4_word32" Gens.postgresInt PTI.int4 TextEncoder.int4_word32 (const B.int)
,
- test "int8_int64" Gens.auto PTI.int8 TextEncoder.int8_int64 (const Decoder.int)
+ test "int8_int64" Gens.auto PTI.int8 TextEncoder.int8_int64 (const B.int)
,
- test "int8_word64" Gens.postgresInt PTI.int8 TextEncoder.int8_word64 (const Decoder.int)
+ test "int8_word64" Gens.postgresInt PTI.int8 TextEncoder.int8_word64 (const B.int)
,
- test "bool" Gens.auto PTI.bool TextEncoder.bool (const Decoder.bool)
+ test "bool" Gens.auto PTI.bool TextEncoder.bool (const B.bool)
]
where
test typeName gen pti encoder decoder =
@@ -241,7 +243,7 @@ textual =
arrayCodec gen encoder decoder =
QuickCheck.testProperty ("Array codec") $
QuickCheck.forAll gen $
- \value -> (QuickCheck.===) (Right value) (Decoder.run decoder (Encoder.run encoder value))
+ \value -> (QuickCheck.===) (Right value) (B.valueParser decoder ((A.encodingBytes . encoder) value))
arrayRoundtrip gen pti encoder decoder =
QuickCheck.testProperty ("Array roundtrip") $
@@ -251,9 +253,12 @@ stdRoundtrip typeName gen pti encoder decoder =
QuickCheck.testProperty (typeName <> " roundtrip") $
QuickCheck.forAll gen $ Properties.stdRoundtrip (PTI.oidPQ (PTI.ptiOID pti)) encoder decoder
+primitiveRoundtrip typeName gen pti encoder decoder =
+ stdRoundtrip typeName gen pti (encoder) decoder
+
timeRoundtrip typeName gen pti encoder decoder =
QuickCheck.testProperty (typeName <> " roundtrip") $
- QuickCheck.forAll gen $ Properties.roundtrip (PTI.oidPQ (PTI.ptiOID pti)) encoder decoder
+ QuickCheck.forAll gen $ Properties.roundtrip (PTI.oidPQ (PTI.ptiOID pti)) (\x -> encoder x) decoder
select statement decoder value =
HUnit.testCase (show statement) $
diff --git a/tasty/Main/Gens.hs b/tasty/Main/Gens.hs
index f71cf31..98c9d27 100644
--- a/tasty/Main/Gens.hs
+++ b/tasty/Main/Gens.hs
@@ -9,8 +9,7 @@ import qualified Data.Scientific as Scientific
import qualified Data.UUID as UUID
import qualified Data.Vector as Vector
import qualified Data.HashMap.Strict as HashMap
-import qualified PostgreSQL.Binary.Data as Data
-import qualified PostgreSQL.Binary.Encoder as Encoder
+import qualified PostgreSQL.Binary.Encoding as Encoder
import qualified Data.Text as Text
import qualified Data.Aeson as Aeson
import qualified Network.IP.Addr as IPAddr
@@ -129,34 +128,6 @@ inet = do
arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary)) <*> choose (0, 128)
else IPAddr.netAddr <$> (IPAddr.IPv4 <$> (IPAddr.ip4FromOctets <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary)) <*> choose (0, 32)
-arrayRep :: Gen (Word32, Data.Array)
-arrayRep =
- do
- ndims <- choose (1, 4)
- dims <- Vector.replicateM ndims dimGen
- (valueGen', oid, arrayOID) <- valueGen
- values <- Vector.replicateM (dimsToNValues dims) valueGen'
- let nulls = Vector.elem Nothing values
- return (arrayOID, (dims, values, nulls, oid))
- where
- dimGen =
- (,) <$> choose (1, 7) <*> pure 1
- valueGen =
- do
- (pti, gen) <- elements [(PTI.int8, mkGen Encoder.int8_int64),
- (PTI.bool, mkGen Encoder.bool),
- (PTI.date, mkGen Encoder.date),
- (PTI.text, mkGen Encoder.text_strict),
- (PTI.bytea, mkGen Encoder.bytea_strict)]
- return (gen, PTI.oidWord32 (PTI.ptiOID pti), PTI.oidWord32 (fromJust (PTI.ptiArrayOID pti)))
- where
- mkGen renderer =
- fmap (fmap (convert . renderer)) arbitrary
- dimsToNValues =
- Vector.product . fmap dimensionWidth
- where
- dimensionWidth (x, _) = fromIntegral x
-
array3 :: Gen a -> Gen [[[a]]]
array3 gen =
do
diff --git a/tasty/Main/IO.hs b/tasty/Main/IO.hs
index 32854ad..296ec18 100644
--- a/tasty/Main/IO.hs
+++ b/tasty/Main/IO.hs
@@ -12,19 +12,18 @@ import qualified Data.Scientific as Scientific
import qualified Data.UUID as UUID
import qualified Data.Vector as Vector
import qualified Data.Text.Encoding as Text
-import qualified PostgreSQL.Binary.Data as Data
-import qualified PostgreSQL.Binary.Encoder as Encoder
-import qualified PostgreSQL.Binary.Decoder as Decoder
+import qualified PostgreSQL.Binary.Decoding as A
+import qualified PostgreSQL.Binary.Encoding as B
import qualified Database.PostgreSQL.LibPQ as LibPQ
-textRoundtrip :: LibPQ.Oid -> TextEncoder.Encoder a -> (Bool -> Decoder.Decoder a) -> a -> IO (Either Text a)
+textRoundtrip :: LibPQ.Oid -> TextEncoder.Encoder a -> (Bool -> A.Value a) -> a -> IO (Either Text a)
textRoundtrip oid encoder decoder value =
fmap (either (Left . Text.decodeUtf8) id) $
DB.session $ do
integerDatetimes <- DB.integerDatetimes
bytes <- DB.oneRow "SELECT $1" (params integerDatetimes) LibPQ.Binary
- return $ Decoder.run (decoder integerDatetimes) bytes
+ return $ A.valueParser (decoder integerDatetimes) bytes
where
params integerDatetimes =
[ Just ( oid , bytes , LibPQ.Text ) ]
@@ -32,24 +31,24 @@ textRoundtrip oid encoder decoder value =
bytes =
(convert . encoder) value
-roundtrip :: LibPQ.Oid -> (Bool -> Encoder.Encoder a) -> (Bool -> Decoder.Decoder b) -> a -> IO (Either Text b)
+roundtrip :: LibPQ.Oid -> (Bool -> a -> B.Encoding) -> (Bool -> A.Value b) -> a -> IO (Either Text b)
roundtrip oid encoder decoder value =
fmap (either (Left . Text.decodeUtf8) id) $
DB.session $ do
integerDatetimes <- DB.integerDatetimes
bytes <- DB.oneRow "SELECT $1" (params integerDatetimes) LibPQ.Binary
- return $ Decoder.run (decoder integerDatetimes) bytes
+ return $ A.valueParser (decoder integerDatetimes) bytes
where
params integerDatetimes =
[ Just ( oid , bytes , LibPQ.Binary ) ]
where
bytes =
- (convert . encoder integerDatetimes) value
+ (B.encodingBytes . encoder integerDatetimes) value
-parameterlessStatement :: ByteString -> (Bool -> Decoder.Decoder a) -> a -> IO (Either Text a)
+parameterlessStatement :: ByteString -> (Bool -> A.Value a) -> a -> IO (Either Text a)
parameterlessStatement statement decoder value =
fmap (either (Left . Text.decodeUtf8) id) $
DB.session $ do
integerDatetimes <- DB.integerDatetimes
bytes <- DB.oneRow statement [] LibPQ.Binary
- return $ Decoder.run (decoder integerDatetimes) bytes
+ return $ A.valueParser (decoder integerDatetimes) bytes
diff --git a/tasty/Main/Properties.hs b/tasty/Main/Properties.hs
index 790b5bd..6f7b34f 100644
--- a/tasty/Main/Properties.hs
+++ b/tasty/Main/Properties.hs
@@ -6,10 +6,9 @@ import Test.QuickCheck.Instances
import qualified Data.Scientific as Scientific
import qualified Data.UUID as UUID
import qualified Data.Vector as Vector
-import qualified PostgreSQL.Binary.Data as Data
-import qualified PostgreSQL.Binary.Encoder as Encoder
-import qualified PostgreSQL.Binary.Decoder as Decoder
-import qualified Main.TextEncoder as TextEncoder
+import qualified PostgreSQL.Binary.Decoding as A
+import qualified PostgreSQL.Binary.Encoding as B
+import qualified Main.TextEncoder as C
import qualified Main.PTI as PTI
import qualified Main.DB as DB
import qualified Main.IO as IO
@@ -17,14 +16,14 @@ import qualified Database.PostgreSQL.LibPQ as LibPQ
roundtrip :: (Show a, Eq a) =>
- LibPQ.Oid -> (Bool -> Encoder.Encoder a) -> (Bool -> Decoder.Decoder a) -> a -> Property
+ LibPQ.Oid -> (Bool -> (a -> B.Encoding)) -> (Bool -> A.Value a) -> a -> Property
roundtrip oid encoder decoder value =
Right value === unsafePerformIO (IO.roundtrip oid encoder decoder value)
-stdRoundtrip :: (Show a, Eq a) => LibPQ.Oid -> Encoder.Encoder a -> Decoder.Decoder a -> a -> Property
+stdRoundtrip :: (Show a, Eq a) => LibPQ.Oid -> (a -> B.Encoding) -> A.Value a -> a -> Property
stdRoundtrip oid encoder decoder value =
roundtrip oid (const encoder) (const decoder) value
-textRoundtrip :: (Show a, Eq a) => LibPQ.Oid -> TextEncoder.Encoder a -> (Bool -> Decoder.Decoder a) -> a -> Property
+textRoundtrip :: (Show a, Eq a) => LibPQ.Oid -> C.Encoder a -> (Bool -> A.Value a) -> a -> Property
textRoundtrip oid encoder decoder value =
Right value === unsafePerformIO (IO.textRoundtrip oid encoder decoder value)