postgresql-binary 0.13 → 0.13.1
raw patch · 23 files changed
+989/−976 lines, 23 files
Files
- decoding/Main.hs +28/−49
- encoding/Main.hs +22/−43
- library/PostgreSQL/Binary/BuilderPrim.hs +1/−2
- library/PostgreSQL/Binary/Decoding.hs +122/−132
- library/PostgreSQL/Binary/Encoding.hs +114/−98
- library/PostgreSQL/Binary/Encoding/Builders.hs +87/−102
- library/PostgreSQL/Binary/Inet.hs +0/−1
- library/PostgreSQL/Binary/Integral.hs +4/−5
- library/PostgreSQL/Binary/Interval.hs +10/−11
- library/PostgreSQL/Binary/Numeric.hs +7/−8
- library/PostgreSQL/Binary/Prelude.hs +37/−74
- library/PostgreSQL/Binary/Time.hs +32/−32
- postgresql-binary.cabal +3/−2
- tasty/Main.hs +179/−209
- tasty/Main/Apx.hs +13/−16
- tasty/Main/Composite.hs +75/−0
- tasty/Main/DB.hs +30/−32
- tasty/Main/Gens.hs +33/−25
- tasty/Main/IO.hs +24/−25
- tasty/Main/PTI.hs +139/−75
- tasty/Main/Prelude.hs +8/−17
- tasty/Main/Properties.hs +15/−11
- tasty/Main/TextEncoder.hs +6/−7
decoding/Main.hs view
@@ -1,60 +1,39 @@ module Main where -import Prelude import Criterion import Criterion.Main-import qualified PostgreSQL.Binary.Encoding as E import qualified PostgreSQL.Binary.Decoding as D-+import qualified PostgreSQL.Binary.Encoding as E+import Prelude main = defaultMain- [- b "bool" D.bool ((E.encodingBytes . E.bool) True)- ,- b "int2" (D.int :: D.Value Int16) ((E.encodingBytes . E.int2_int16) 1000)- ,- b "int4" (D.int :: D.Value Int32) ((E.encodingBytes . E.int4_int32) 1000)- ,- b "int8" (D.int :: D.Value Int64) ((E.encodingBytes . E.int8_int64) 1000)- ,- b "float4" D.float4 ((E.encodingBytes . E.float4) 12.65468468)- ,- b "float8" D.float8 ((E.encodingBytes . E.float8) 12.65468468)- ,- b "numeric" D.numeric ((E.encodingBytes . E.numeric) (read "20.213290183"))- ,- b "char" D.char ((E.encodingBytes . E.char_utf8) 'Я')- ,- b "text" D.text_strict ((E.encodingBytes . E.text_strict) "alsdjflskjдывлоаы оады")- ,- b "bytea" D.bytea_strict ((E.encodingBytes . E.bytea_strict) "alskdfj;dasjfl;dasjflksdj")- ,- b "date" D.date ((E.encodingBytes . E.date) (read "2000-01-19"))- ,- b "time" D.time_int ((E.encodingBytes . E.time_int) (read "10:41:06"))- ,- b "timetz" D.timetz_int ((E.encodingBytes . E.timetz_int) (read "(10:41:06, +0300)"))- ,- b "timestamp" D.timestamp_int ((E.encodingBytes . E.timestamp_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.encodingBytes . E.interval_int) (secondsToDiffTime 23472391128374))- ,- b "uuid" D.uuid ((E.encodingBytes . E.uuid) (read "550e8400-e29b-41d4-a716-446655440000"))- ,- let- encoder =- E.array 23 . E.dimensionArray foldl' (E.encodingArray . E.int4_int32)- decoder =- D.array $- D.dimensionArray replicateM $- D.valueArray $- (D.int :: D.Value Int32)- in- b "array" decoder (E.encodingBytes (encoder [1,2,3,4]))+ [ b "bool" D.bool ((E.encodingBytes . E.bool) True),+ b "int2" (D.int :: D.Value Int16) ((E.encodingBytes . E.int2_int16) 1000),+ b "int4" (D.int :: D.Value Int32) ((E.encodingBytes . E.int4_int32) 1000),+ b "int8" (D.int :: D.Value Int64) ((E.encodingBytes . E.int8_int64) 1000),+ b "float4" D.float4 ((E.encodingBytes . E.float4) 12.65468468),+ b "float8" D.float8 ((E.encodingBytes . E.float8) 12.65468468),+ b "numeric" D.numeric ((E.encodingBytes . E.numeric) (read "20.213290183")),+ b "char" D.char ((E.encodingBytes . E.char_utf8) 'Я'),+ b "text" D.text_strict ((E.encodingBytes . E.text_strict) "alsdjflskjдывлоаы оады"),+ b "bytea" D.bytea_strict ((E.encodingBytes . E.bytea_strict) "alskdfj;dasjfl;dasjflksdj"),+ b "date" D.date ((E.encodingBytes . E.date) (read "2000-01-19")),+ b "time" D.time_int ((E.encodingBytes . E.time_int) (read "10:41:06")),+ b "timetz" D.timetz_int ((E.encodingBytes . E.timetz_int) (read "(10:41:06, +0300)")),+ b "timestamp" D.timestamp_int ((E.encodingBytes . E.timestamp_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.encodingBytes . E.interval_int) (secondsToDiffTime 23472391128374)),+ b "uuid" D.uuid ((E.encodingBytes . E.uuid) (read "550e8400-e29b-41d4-a716-446655440000")),+ let encoder =+ E.array 23 . E.dimensionArray foldl' (E.encodingArray . E.int4_int32)+ decoder =+ D.array $+ D.dimensionArray replicateM $+ D.valueArray $+ (D.int :: D.Value Int32)+ in b "array" decoder (E.encodingBytes (encoder [1, 2, 3, 4])) ] where- b name decoder value = + b name decoder value = bench name $ nf (D.valueParser decoder) value
encoding/Main.hs view
@@ -1,54 +1,33 @@ module Main where -import Prelude import Criterion import Criterion.Main import qualified PostgreSQL.Binary.Encoding as E-+import Prelude main = defaultMain- [- value "bool" E.bool True- ,- value "int2" E.int2_int16 1000- ,- value "int4" E.int4_int32 1000- ,- value "int8" E.int8_int64 1000- ,- value "float4" E.float4 12.65468468- ,- value "float8" E.float8 12.65468468- ,- value "numeric" E.numeric (read "20.213290183")- ,- value "char_utf8" E.char_utf8 'Я'- ,- value "text" E.text_strict "alsdjflskjдывлоаы оады"- ,- value "bytea" E.bytea_strict "alskdfj;dasjfl;dasjflksdj"- ,- value "date" E.date (read "2000-01-19")- ,- value "time" E.time_int (read "10:41:06")- ,- value "timetz" E.timetz_int (read "(10:41:06, +0300)")- ,- value "timestamp" E.timestamp_int (read "2000-01-19 10:41:06")- ,- value "timestamptz" E.timestamptz_int (read "2000-01-19 10:41:06")- ,- value "interval" E.interval_int (secondsToDiffTime 23472391128374)- ,- value "uuid" E.uuid (read "550e8400-e29b-41d4-a716-446655440000")- ,- let- encoder =- E.array 23 . E.dimensionArray foldl' (E.encodingArray . E.int4_int32)- in- value "array" encoder [1,2,3,4]+ [ value "bool" E.bool True,+ value "int2" E.int2_int16 1000,+ value "int4" E.int4_int32 1000,+ value "int8" E.int8_int64 1000,+ value "float4" E.float4 12.65468468,+ value "float8" E.float8 12.65468468,+ value "numeric" E.numeric (read "20.213290183"),+ value "char_utf8" E.char_utf8 'Я',+ value "text" E.text_strict "alsdjflskjдывлоаы оады",+ value "bytea" E.bytea_strict "alskdfj;dasjfl;dasjflksdj",+ value "date" E.date (read "2000-01-19"),+ value "time" E.time_int (read "10:41:06"),+ value "timetz" E.timetz_int (read "(10:41:06, +0300)"),+ value "timestamp" E.timestamp_int (read "2000-01-19 10:41:06"),+ value "timestamptz" E.timestamptz_int (read "2000-01-19 10:41:06"),+ value "interval" E.interval_int (secondsToDiffTime 23472391128374),+ value "uuid" E.uuid (read "550e8400-e29b-41d4-a716-446655440000"),+ let encoder =+ E.array 23 . E.dimensionArray foldl' (E.encodingArray . E.int4_int32)+ in value "array" encoder [1, 2, 3, 4] ] where- value name encoder value = + value name encoder value = bench name $ nf (E.encodingBytes . encoder) value
library/PostgreSQL/Binary/BuilderPrim.hs view
@@ -1,8 +1,7 @@ module PostgreSQL.Binary.BuilderPrim where -import PostgreSQL.Binary.Prelude import qualified Data.ByteString.Builder.Prim as A-+import PostgreSQL.Binary.Prelude {-# INLINE nullByteIgnoringBoundedPrim #-} nullByteIgnoringBoundedPrim :: A.BoundedPrim Word8
library/PostgreSQL/Binary/Decoding.hs view
@@ -1,68 +1,68 @@ 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,-)+ ( 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.Aeson as Aeson import qualified Data.ByteString as ByteString import qualified Data.ByteString.Lazy as LazyByteString import qualified Data.Text as Text@@ -70,9 +70,14 @@ 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 Data.Vector as Vector import qualified Network.IP.Addr as IPAddr-+import qualified PostgreSQL.Binary.Inet as Inet+import qualified PostgreSQL.Binary.Integral as Integral+import qualified PostgreSQL.Binary.Interval as Interval+import qualified PostgreSQL.Binary.Numeric as Numeric+import PostgreSQL.Binary.Prelude hiding (bool, drop, fail, failure, state, take)+import qualified PostgreSQL.Binary.Time as Time type Value = BinaryParser@@ -82,7 +87,6 @@ BinaryParser.run -- * Helpers-------------------------- -- | -- Any int number of a limited byte-size.@@ -91,18 +95,18 @@ intOfSize x = fmap Integral.pack (bytesOfSize x) -{-# INLINABLE onContent #-}-onContent :: Value a -> Value ( Maybe a )+{-# INLINEABLE onContent #-}+onContent :: Value a -> Value (Maybe a) onContent decoder =- size >>=- \case- (-1) -> pure Nothing- n -> fmap Just (sized (fromIntegral n) decoder)+ size+ >>= \case+ (-1) -> pure Nothing+ n -> fmap Just (sized (fromIntegral n) decoder) where size = intOfSize 4 :: Value Int32 -{-# INLINABLE content #-}+{-# INLINEABLE content #-} content :: Value (Maybe ByteString) content = intOfSize 4 >>= \case@@ -114,9 +118,7 @@ nonNull = maybe (failure "Unexpected NULL") return - -- * Primitive-------------------------- -- | -- Lifts a custom decoder implementation.@@ -154,7 +156,7 @@ components <- Vector.replicateM componentsAmount (intOfSize 2) either failure return (Numeric.scientific pointIndex signCode components) -{-# INLINABLE uuid #-}+{-# INLINEABLE uuid #-} uuid :: Value UUID uuid = UUID.fromWords <$> intOfSize 4 <*> intOfSize 4 <*> intOfSize 4 <*> intOfSize 4@@ -169,25 +171,28 @@ ip6 = IPAddr.ip6FromWords <$> intOfSize 2 <*> intOfSize 2 <*> intOfSize 2 <*> intOfSize 2 <*> intOfSize 2 <*> intOfSize 2 <*> intOfSize 2 <*> intOfSize 2 -{-# INLINABLE inet #-}+{-# INLINEABLE inet #-} inet :: Value (IPAddr.NetAddr IPAddr.IP) inet = do af <- intOfSize 1 netmask <- intOfSize 1 isCidr <- intOfSize 1 ipSize <- intOfSize 1- if | af == Inet.inetAddressFamily ->- do ip <- ip4- return $ inetFromBytes af netmask isCidr ipSize (IPAddr.IPv4 ip)- | af == Inet.inet6AddressFamily ->- do ip <- ip6- return $ inetFromBytes af netmask isCidr ipSize (IPAddr.IPv6 ip)- | otherwise -> BinaryParser.failure ("Unknown address family: " <> fromString (show af))+ if+ | af == Inet.inetAddressFamily ->+ do+ ip <- ip4+ return $ inetFromBytes af netmask isCidr ipSize (IPAddr.IPv4 ip)+ | af == Inet.inet6AddressFamily ->+ do+ ip <- ip6+ return $ inetFromBytes af netmask isCidr ipSize (IPAddr.IPv6 ip)+ | otherwise -> BinaryParser.failure ("Unknown address family: " <> fromString (show af)) where inetFromBytes :: Word8 -> Word8 -> Word8 -> Int8 -> IPAddr.IP -> IPAddr.NetAddr IPAddr.IP inetFromBytes _ netmask _ _ ip = IPAddr.netAddr ip netmask -{-# INLINABLE json_ast #-}+{-# INLINEABLE json_ast #-} json_ast :: Value Aeson.Value json_ast = bytea_strict >>= either (BinaryParser.failure . fromString) pure . Aeson.eitherDecodeStrict'@@ -195,7 +200,7 @@ -- | -- Given a function, which parses a plain UTF-8 JSON string encoded as a byte-array, -- produces a decoder.-{-# INLINABLE json_bytes #-}+{-# INLINEABLE json_bytes #-} json_bytes :: (ByteString -> Either Text a) -> Value a json_bytes cont = getAllBytes >>= parseJSON@@ -205,7 +210,7 @@ parseJSON = either BinaryParser.failure return . cont -{-# INLINABLE jsonb_ast #-}+{-# INLINEABLE jsonb_ast #-} jsonb_ast :: Value Aeson.Value jsonb_ast = jsonb_bytes $ mapLeft fromString . Aeson.eitherDecodeStrict'@@ -213,11 +218,11 @@ -- | -- 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 #-}+{-# INLINEABLE jsonb_bytes #-} jsonb_bytes :: (ByteString -> Either Text a) -> Value a jsonb_bytes cont = getAllBytes >>= trimBytes >>= parseJSON@@ -225,18 +230,17 @@ getAllBytes = BinaryParser.remainders trimBytes =- maybe (BinaryParser.failure "Empty input") return .- fmap snd . ByteString.uncons+ maybe (BinaryParser.failure "Empty input") return+ . fmap snd+ . ByteString.uncons parseJSON = either BinaryParser.failure return . cont - -- ** Textual-------------------------- -- | -- A UTF-8-decoded char.-{-# INLINABLE char #-}+{-# INLINEABLE char #-} char :: Value Char char = fmap Text.uncons text_strict >>= \case@@ -247,7 +251,7 @@ -- | -- Any of the variable-length character types: -- BPCHAR, VARCHAR, NAME and TEXT.-{-# INLINABLE text_strict #-}+{-# INLINEABLE text_strict #-} text_strict :: Value Text text_strict = do@@ -262,12 +266,12 @@ -- | -- Any of the variable-length character types: -- BPCHAR, VARCHAR, NAME and TEXT.-{-# INLINABLE text_lazy #-}+{-# INLINEABLE text_lazy #-} text_lazy :: Value LazyText text_lazy = do input <- bytea_lazy- either (failure . exception input ) return (LazyText.decodeUtf8' input)+ either (failure . exception input) return (LazyText.decodeUtf8' input) where exception input = \case@@ -288,9 +292,7 @@ bytea_lazy = fmap LazyByteString.fromStrict remainders - -- * Date and Time-------------------------- -- | -- @DATE@ values decoding.@@ -366,38 +368,35 @@ interval_float :: Value DiffTime interval_float = do- u <- sized 8 (fmap (round . (*(10^6)) . toRational) float8)+ u <- sized 8 (fmap (round . (* (10 ^ 6)) . toRational) float8) d <- sized 4 int m <- int return $ Interval.toDiffTime $ Interval.Interval u d m - -- * Exotic-------------------------- -- | -- A function for generic in place parsing of an HStore value.--- +-- -- Accepts:--- +-- -- * An implementation of the @replicateM@ function -- (@Control.Monad.'Control.Monad.replicateM'@, @Data.Vector.'Data.Vector.replicateM'@), -- which determines how to produce the final datastructure from the rows.--- +-- -- * A decoder for keys.--- +-- -- * A decoder for values.--- +-- -- Here's how you can use it to produce a parser to list:--- +-- -- @ -- hstoreAsList :: Value [ ( Text , Maybe Text ) ] -- hstoreAsList = -- hstore replicateM text text -- @--- -{-# INLINABLE hstore #-}-hstore :: ( forall m. Monad m => Int -> m ( k , Maybe v ) -> m r ) -> Value k -> Value v -> Value r+{-# INLINEABLE hstore #-}+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@@ -411,13 +410,11 @@ value = onContent valueContent - -- * Composite-------------------------- -newtype Composite a =- Composite ( Value a )- deriving ( Functor , Applicative , Monad , MonadFail )+newtype Composite a+ = Composite (Value a)+ deriving (Functor, Applicative, Monad, MonadFail) -- | -- Unlift a 'Composite' to a value 'Value'.@@ -432,7 +429,7 @@ -- | -- Lift a value 'Value' into 'Composite'. {-# INLINE nullableValueComposite #-}-nullableValueComposite :: Value a -> Composite ( Maybe a )+nullableValueComposite :: Value a -> Composite (Maybe a) nullableValueComposite valueValue = Composite (skipOid *> onContent valueValue) where@@ -449,25 +446,22 @@ skipOid = unitOfSize 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 ( Functor )+newtype Array a+ = Array ([Word32] -> Value a)+ deriving (Functor) -- | -- Unlift an 'Array' to a value 'Value'.@@ -489,17 +483,16 @@ -- | -- 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 replicateM (Array component) = Array $ \case head : tail -> replicateM (fromIntegral head) (component tail)@@ -508,7 +501,7 @@ -- | -- 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 = Array . const . onContent @@ -519,9 +512,7 @@ valueArray = Array . const . join . fmap (maybe (failure "Unexpected NULL") return) . onContent - -- * Enum-------------------------- -- | -- Given a partial mapping from text to value,@@ -540,7 +531,6 @@ pure -- * Refining values-------------------------- -- | Given additional constraints when -- using an existing value decoder, produces
library/PostgreSQL/Binary/Encoding.hs view
@@ -1,76 +1,81 @@ module PostgreSQL.Binary.Encoding-(- -- * Encoding- Encoding,- encodingBytes,+ ( -- * Encoding+ Encoding,+ encodingBytes,+ composite,+ array,+ array_foldable,+ array_vector,+ nullableArray_vector,+ hStore_foldable,+ hStore_hashMap,+ hStore_map, - -- * - 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, - -- * 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_bytes_lazy,- json_ast,- jsonb_bytes,- jsonb_bytes_lazy,- jsonb_ast,+ -- ** Time - -- * Array- Array,- encodingArray,- nullArray,- dimensionArray,-)+ -- | 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_bytes_lazy,+ json_ast,+ jsonb_bytes,+ jsonb_bytes_lazy,+ jsonb_ast,++ -- * Array+ Array,+ encodingArray,+ nullArray,+ dimensionArray,++ -- * Composite+ Composite,+ field,+ nullField,+ ) 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.Aeson as R 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 Data.Vector as A import qualified Network.IP.Addr as G-+import qualified PostgreSQL.Binary.Encoding.Builders as B+import PostgreSQL.Binary.Prelude hiding (bool, length) type Encoding = C.Builder@@ -80,73 +85,67 @@ encodingBytes = C.builderBytes - -- * Values-------------------------- -{-|-Turn an array builder into final value.-The first parameter is OID of the element type.--}+{-# INLINE composite #-}+composite :: Composite -> Encoding+composite (Composite size fields) =+ B.int4_int size <> fields++-- |+-- 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.--}+-- |+-- 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.--}+-- |+-- 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.--}+-- |+-- 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.--}+-- |+-- 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.--}+-- |+-- @HSTORE@ encoder from HashMap. {-# INLINE hStore_hashMap #-} hStore_hashMap :: HashMap Text (Maybe Text) -> Encoding hStore_hashMap = B.hStore_hashMap -{-|-@HSTORE@ encoder from Map.--}+-- |+-- @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@@ -323,15 +322,12 @@ jsonb_ast = B.jsonb_ast - -- * Array-------------------------- -{-|-Abstraction for encoding into multidimensional array.--}-data Array =- Array !Encoding ![Int32] !Bool+-- |+-- Abstraction for encoding into multidimensional array.+data Array+ = Array !Encoding ![Int32] !Bool encodingArray :: Encoding -> Array encodingArray value =@@ -357,3 +353,23 @@ where Array elementBuilder elementDimensions elementNulls = elementArray element++-- * Composite++data Composite+ = Composite !Int !Encoding++instance Semigroup Composite where+ Composite lSize lFields <> Composite rSize rFields =+ Composite (lSize + rSize) (lFields <> rFields)++instance Monoid Composite where+ mempty = Composite 0 mempty++field :: Word32 -> Encoding -> Composite+field oid value =+ Composite 1 (B.int4_word32 oid <> B.sized value)++nullField :: Word32 -> Composite+nullField oid =+ Composite 1 (B.int4_word32 oid <> B.null4)
library/PostgreSQL/Binary/Encoding/Builders.hs view
@@ -1,30 +1,27 @@-module PostgreSQL.Binary.Encoding.Builders-where+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.Aeson as R import qualified Data.ByteString.Builder as M import qualified Data.ByteString.Lazy as N+import qualified Data.HashMap.Strict as F+import qualified Data.Map.Strict as Q+import qualified Data.Scientific as D 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 Data.UUID as E+import qualified Data.Vector as A 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.Inet as H import qualified PostgreSQL.Binary.Interval as P-+import qualified PostgreSQL.Binary.Numeric as C+import PostgreSQL.Binary.Prelude hiding (bool)+import qualified PostgreSQL.Binary.Prelude as B+import qualified PostgreSQL.Binary.Time as O -- * Helpers-------------------------- {-# NOINLINE null4 #-} null4 :: Builder@@ -34,8 +31,8 @@ {-# INLINE sized #-} sized :: Builder -> Builder sized payload =- int4_int (builderLength payload) <>- payload+ int4_int (builderLength payload)+ <> payload {-# INLINE sizedMaybe #-} sizedMaybe :: (element -> Builder) -> Maybe element -> Builder@@ -62,9 +59,7 @@ false4 = int4_word32 0 - -- * Primitives-------------------------- {-# INLINE bool #-} bool :: Bool -> Builder@@ -116,22 +111,22 @@ float8 = int8_int64 . unsafeCoerce -{-# INLINABLE numeric #-}+{-# INLINEABLE numeric #-} numeric :: Scientific -> Builder numeric x =- word16BE (fromIntegral componentsAmount) <>- word16BE (fromIntegral pointIndex) <>- signCode <>- word16BE (fromIntegral trimmedExponent) <>- foldMap word16BE components+ word16BE (fromIntegral componentsAmount)+ <> word16BE (fromIntegral pointIndex)+ <> signCode+ <> word16BE (fromIntegral trimmedExponent)+ <> foldMap word16BE components where- componentsAmount = + componentsAmount = length components coefficient = D.coefficient x- exponent = + exponent = D.base10Exponent x- components = + components = C.extractComponents tunedCoefficient pointIndex = componentsAmount + (tunedExponent `div` 4) - 1@@ -164,31 +159,34 @@ case E.toWords uuid of (w1, w2, w3, w4) -> int4_word32 w1 <> int4_word32 w2 <> int4_word32 w3 <> int4_word32 w4 -{-# INLINABLE ip4 #-}+{-# INLINEABLE 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 #-}+{-# INLINEABLE 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+ 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 #-}+{-# INLINEABLE 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+ where+ netLength =+ word8 (G.netLength i)+ isCidr =+ false1 {-# NOINLINE inetAddressFamily #-} inetAddressFamily :: Builder@@ -210,18 +208,16 @@ 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 = +char_utf8 = utf8Char {-# INLINE text_strict #-}@@ -249,30 +245,26 @@ bytea_lazyBuilder = lazyBytes . M.toLazyByteString - -- * Time-------------------------- {-# INLINE date #-} date :: Day -> Builder date = int4_int32 . fromIntegral . O.dayToPostgresJulian -{-# INLINABLE time_int #-}+{-# INLINEABLE 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))+ 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 #-}+{-# INLINEABLE 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)))+ 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@@ -287,7 +279,7 @@ {-# INLINE tz #-} tz :: TimeZone -> Builder tz =- int4_int . (*60) . negate . timeZoneMinutes+ int4_int . (* 60) . negate . timeZoneMinutes {-# INLINE timestamp_int #-} timestamp_int :: LocalTime -> Builder@@ -309,33 +301,31 @@ timestamptz_float = float8 . O.utcToSecs -{-# INLINABLE interval_int #-}+{-# INLINEABLE interval_int #-} interval_int :: DiffTime -> Builder interval_int x =- int64BE u <>- int32BE d <>- int32BE m+ int64BE u+ <> int32BE d+ <> int32BE m where- P.Interval u d m = + P.Interval u d m = fromMaybe (error ("Too large DiffTime value for an interval " <> show x)) $- P.fromDiffTime x+ P.fromDiffTime x -{-# INLINABLE interval_float #-}+{-# INLINEABLE interval_float #-} interval_float :: DiffTime -> Builder interval_float x =- float8 s <>- int32BE d <>- int32BE m+ float8 s+ <> int32BE d+ <> int32BE m where- P.Interval u d m = + P.Interval u d m = fromMaybe (error ("Too large DiffTime value for an interval " <> show x)) $- P.fromDiffTime x+ P.fromDiffTime x s =- fromIntegral u / (10^6)-+ fromIntegral u / (10 ^ 6) -- * JSON-------------------------- {-# INLINE json_bytes #-} json_bytes :: ByteString -> Builder@@ -367,9 +357,7 @@ jsonb_ast = mappend "\1" . json_ast - -- * Array-------------------------- {-# INLINE array_vector #-} array_vector :: Word32 -> (element -> Builder) -> Vector element -> Builder@@ -391,42 +379,39 @@ payload = foldMap (sizedMaybe elementBuilder) vector -{-# INLINABLE array #-}+{-# INLINEABLE 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+ 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 #-}+-- |+-- 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'+-- @+{-# INLINEABLE hStoreUsingFoldl #-} hStoreUsingFoldl :: (forall a. (a -> (Text, Maybe Text) -> a) -> a -> b -> a) -> b -> Builder hStoreUsingFoldl foldl = exit . foldl progress enter@@ -456,11 +441,11 @@ {-# 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+ 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+ int4_int (Q.size input)+ <> Q.foldlWithKey' (\payload key value -> payload <> hStoreRow key value) mempty input
library/PostgreSQL/Binary/Inet.hs view
@@ -2,7 +2,6 @@ import PostgreSQL.Binary.Prelude - -- | Address family AF_INET inetAddressFamily :: Word8 inetAddressFamily =
library/PostgreSQL/Binary/Integral.hs view
@@ -2,11 +2,10 @@ -- Utils for dealing with integer numbers. module PostgreSQL.Binary.Integral where -import PostgreSQL.Binary.Prelude import qualified Data.ByteString as B-+import PostgreSQL.Binary.Prelude -{-# INLINABLE pack #-}+{-# INLINEABLE pack #-} pack :: (Bits a, Num a) => B.ByteString -> a pack = B.foldl' (\n h -> shiftL n 8 .|. fromIntegral h) 0@@ -14,7 +13,7 @@ {-# INLINE unpackBySize #-} unpackBySize :: (Bits a, Integral a) => Int -> a -> B.ByteString unpackBySize n x =- B.pack $ map f $ reverse [0..n - 1]- where + B.pack $ map f $ reverse [0 .. n - 1]+ where f s = fromIntegral $ shiftR x (8 * s)
library/PostgreSQL/Binary/Interval.hs view
@@ -3,21 +3,19 @@ import PostgreSQL.Binary.Prelude hiding (months) import qualified PostgreSQL.Binary.Time as Time --data Interval = - Interval {- micros :: Int64,+data Interval = Interval+ { micros :: Int64, days :: Int32, months :: Int32- } + } deriving (Show, Eq) - -- | -- Oddly enough despite a claim of support of up to 178000000 years in -- <http://www.postgresql.org/docs/9.3/static/datatype-datetime.html Postgres' docs> -- in practice it starts behaving unpredictably after a smaller limit. maxDiffTime :: DiffTime = 1780000 * Time.microsToDiffTime Time.yearMicros+ minDiffTime :: DiffTime = negate maxDiffTime fromDiffTime :: DiffTime -> Maybe Interval@@ -29,7 +27,7 @@ fromPicosUnsafe :: Integer -> Interval fromPicosUnsafe = evalState $ do- modify $ flip div (10^6)+ modify $ flip div (10 ^ 6) u <- state $ swap . flip divMod (10 ^ 6 * 60 * 60 * 24) d <- state $ swap . flip divMod (31) m <- get@@ -37,7 +35,8 @@ toDiffTime :: Interval -> DiffTime toDiffTime x =- picosecondsToDiffTime $ - (10 ^ 6) *- (fromIntegral (micros x) + - 10 ^ 6 * 60 * 60 * 24 * (fromIntegral (days x + 31 * months x)))+ picosecondsToDiffTime $+ (10 ^ 6)+ * ( fromIntegral (micros x)+ + 10 ^ 6 * 60 * 60 * 24 * (fromIntegral (days x + 31 * months x))+ )
library/PostgreSQL/Binary/Numeric.hs view
@@ -1,9 +1,8 @@ module PostgreSQL.Binary.Numeric where -import PostgreSQL.Binary.Prelude-import qualified Data.Vector as Vector import qualified Data.Scientific as Scientific-+import qualified Data.Vector as Vector+import PostgreSQL.Binary.Prelude {-# INLINE posSignCode #-} posSignCode :: Word16@@ -27,12 +26,12 @@ {-# INLINE mergeComponents #-} mergeComponents :: Integral a => Vector a -> Integer-mergeComponents = +mergeComponents = Vector.foldl' (\l r -> l * 10000 + fromIntegral r) 0 {-# INLINE mergeDigits #-} mergeDigits :: Integral a => Vector a -> a-mergeDigits = +mergeDigits = Vector.foldl' (\l r -> l * 10 + r) 0 -- |@@ -47,13 +46,13 @@ d <- get return $ [a, b, c, d] -{-# INLINABLE componentsReplicateM #-}+{-# INLINEABLE componentsReplicateM #-} componentsReplicateM :: (Integral a, Applicative m) => Int -> m a -> m a-componentsReplicateM amount component = +componentsReplicateM amount component = foldl' folder (pure 0) (replicate amount component) where folder acc component =- liftA2 (+) (fmap (*10000) acc) component+ liftA2 (+) (fmap (* 10000) acc) component {-# INLINE signer #-} signer :: Integral a => Word16 -> Either Text (a -> a)
library/PostgreSQL/Binary/Prelude.hs view
@@ -1,31 +1,33 @@ module PostgreSQL.Binary.Prelude-( - module Exports,- LazyByteString,- ByteStringBuilder,- LazyText,- TextBuilder,- mapLeft,- joinMap,-)+ ( module Exports,+ LazyByteString,+ ByteStringBuilder,+ LazyText,+ TextBuilder,+ mapLeft,+ joinMap,+ ) where ---- base-------------------------- import Control.Applicative as Exports import Control.Arrow as Exports hiding (first, second) import Control.Category as Exports import Control.Concurrent as Exports import Control.Exception as Exports-import Control.Monad as Exports hiding (fail, mapM_, sequence_, forM_, msum, mapM, sequence, forM)-import Control.Monad.IO.Class as Exports+import Control.Monad as Exports hiding (fail, forM, forM_, mapM, mapM_, msum, sequence, sequence_) import Control.Monad.Fail as Exports import Control.Monad.Fix as Exports hiding (fix)+import Control.Monad.IO.Class as Exports import Control.Monad.ST as Exports+import Control.Monad.Trans.Class as Exports+import Control.Monad.Trans.Reader as Exports hiding (liftCallCC, liftCatch)+import Control.Monad.Trans.State.Strict as Exports hiding (liftCallCC, liftCatch) import Data.Bifunctor as Exports import Data.Bits as Exports import Data.Bool as Exports+import Data.ByteString as Exports (ByteString)+import qualified Data.ByteString.Builder+import qualified Data.ByteString.Lazy import Data.Char as Exports import Data.Coerce as Exports import Data.Complex as Exports@@ -37,22 +39,31 @@ import Data.Function as Exports hiding (id, (.)) import Data.Functor as Exports import Data.Functor.Identity as Exports-import Data.Int as Exports+import Data.HashMap.Strict as Exports (HashMap) import Data.IORef as Exports+import Data.Int as Exports import Data.Ix as Exports-import Data.List as Exports hiding (sortOn, isSubsequenceOf, uncons, concat, foldr, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, find, maximumBy, minimumBy, mapAccumL, mapAccumR, foldl')-import Data.List.NonEmpty as Exports (NonEmpty(..))+import Data.List as Exports hiding (all, and, any, concat, concatMap, elem, find, foldl, foldl', foldl1, foldr, foldr1, isSubsequenceOf, mapAccumL, mapAccumR, maximum, maximumBy, minimum, minimumBy, notElem, or, product, sortOn, sum, uncons)+import Data.List.NonEmpty as Exports (NonEmpty (..))+import Data.Map.Strict as Exports (Map) import Data.Maybe as Exports-import Data.Monoid as Exports hiding (Last(..), First(..), (<>))+import Data.Monoid as Exports hiding (First (..), Last (..), (<>)) import Data.Ord as Exports import Data.Proxy as Exports import Data.Ratio as Exports-import Data.Semigroup as Exports import Data.STRef as Exports+import Data.Scientific as Exports (Scientific)+import Data.Semigroup as Exports import Data.String as Exports+import Data.Text as Exports (Text)+import qualified Data.Text.Lazy+import qualified Data.Text.Lazy.Builder+import Data.Time as Exports import Data.Traversable as Exports import Data.Tuple as Exports+import Data.UUID as Exports (UUID) import Data.Unique as Exports+import Data.Vector as Exports (Vector) import Data.Version as Exports import Data.Void as Exports import Data.Word as Exports@@ -60,13 +71,12 @@ import Foreign.ForeignPtr as Exports import Foreign.Ptr as Exports import Foreign.StablePtr as Exports-import Foreign.Storable as Exports hiding (sizeOf, alignment)-import GHC.Conc as Exports hiding (orElse, withMVar, threadWaitWriteSTM, threadWaitWrite, threadWaitReadSTM, threadWaitRead)-import GHC.Exts as Exports (lazy, inline, sortWith, groupWith, IsList(fromList, Item))+import Foreign.Storable as Exports hiding (alignment, sizeOf)+import GHC.Conc as Exports hiding (orElse, threadWaitRead, threadWaitReadSTM, threadWaitWrite, threadWaitWriteSTM, withMVar)+import GHC.Exts as Exports (IsList (Item, fromList), groupWith, inline, lazy, sortWith) import GHC.Generics as Exports (Generic, Generic1) import GHC.IO.Exception as Exports import Numeric as Exports-import Prelude as Exports hiding (fail, concat, foldr, mapM_, sequence_, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, mapM, sequence, id, (.)) import System.Environment as Exports import System.Exit as Exports import System.IO as Exports@@ -76,57 +86,11 @@ import System.Mem.StableName as Exports import System.Timeout as Exports import Text.ParserCombinators.ReadP as Exports (ReadP, ReadS, readP_to_S, readS_to_P)-import Text.ParserCombinators.ReadPrec as Exports (ReadPrec, readPrec_to_P, readP_to_Prec, readPrec_to_S, readS_to_Prec)-import Text.Printf as Exports (printf, hPrintf)-import Text.Read as Exports (Read(..), readMaybe, readEither)+import Text.ParserCombinators.ReadPrec as Exports (ReadPrec, readP_to_Prec, readPrec_to_P, readPrec_to_S, readS_to_Prec)+import Text.Printf as Exports (hPrintf, printf)+import Text.Read as Exports (Read (..), readEither, readMaybe) import Unsafe.Coerce as Exports---- transformers---------------------------import Control.Monad.Trans.State.Strict as Exports hiding (liftCallCC, liftCatch)-import Control.Monad.Trans.Reader as Exports hiding (liftCallCC, liftCatch)-import Control.Monad.Trans.Class as Exports-import Data.Functor.Identity as Exports---- bytestring---------------------------import Data.ByteString as Exports (ByteString)---- text---------------------------import Data.Text as Exports (Text)---- vector---------------------------import Data.Vector as Exports (Vector)---- scientific---------------------------import Data.Scientific as Exports (Scientific)---- uuid---------------------------import Data.UUID as Exports (UUID)---- time---------------------------import Data.Time as Exports---- unordered-containers---------------------------import Data.HashMap.Strict as Exports (HashMap)---- containers---------------------------import Data.Map.Strict as Exports (Map)---- custom---------------------------import qualified Data.ByteString.Lazy-import qualified Data.ByteString.Builder-import qualified Data.Text.Lazy-import qualified Data.Text.Lazy.Builder-+import Prelude as Exports hiding (all, and, any, concat, concatMap, elem, fail, foldl, foldl1, foldr, foldr1, id, mapM, mapM_, maximum, minimum, notElem, or, product, sequence, sequence_, sum, (.)) type LazyByteString = Data.ByteString.Lazy.ByteString@@ -139,7 +103,6 @@ type TextBuilder = Data.Text.Lazy.Builder.Builder- {-# INLINE mapLeft #-} mapLeft :: (a -> b) -> Either a x -> Either b x
library/PostgreSQL/Binary/Time.hs view
@@ -1,20 +1,19 @@ module PostgreSQL.Binary.Time where -import PostgreSQL.Binary.Prelude hiding (second) import Data.Time.Calendar.Julian-+import PostgreSQL.Binary.Prelude hiding (second) -{-# INLINABLE dayToPostgresJulian #-}+{-# INLINEABLE dayToPostgresJulian #-} dayToPostgresJulian :: Day -> Integer dayToPostgresJulian = (+ (2400001 - 2451545)) . toModifiedJulianDay -{-# INLINABLE postgresJulianToDay #-}+{-# INLINEABLE postgresJulianToDay #-} postgresJulianToDay :: Integral a => a -> Day postgresJulianToDay = ModifiedJulianDay . fromIntegral . subtract (2400001 - 2451545) -{-# INLINABLE microsToTimeOfDay #-}+{-# INLINEABLE microsToTimeOfDay #-} microsToTimeOfDay :: Int64 -> TimeOfDay microsToTimeOfDay = evalState $ do@@ -24,35 +23,35 @@ return $ TimeOfDay (fromIntegral h) (fromIntegral m) (microsToPico u) -{-# INLINABLE microsToUTC #-}+{-# INLINEABLE microsToUTC #-} microsToUTC :: Int64 -> UTCTime microsToUTC = evalState $ do- d <- state $ flip divMod $ 10^6 * 60 * 60 * 24+ d <- state $ flip divMod $ 10 ^ 6 * 60 * 60 * 24 u <- get return $ UTCTime (postgresJulianToDay d) (microsToDiffTime u) -{-# INLINABLE microsToPico #-}+{-# INLINEABLE microsToPico #-} microsToPico :: Int64 -> Pico microsToPico =- unsafeCoerce . (* (10^6)) . (fromIntegral :: Int64 -> Integer)+ unsafeCoerce . (* (10 ^ 6)) . (fromIntegral :: Int64 -> Integer) -{-# INLINABLE microsToDiffTime #-}+{-# INLINEABLE microsToDiffTime #-} microsToDiffTime :: Int64 -> DiffTime microsToDiffTime = unsafeCoerce microsToPico -{-# INLINABLE microsToLocalTime #-}+{-# INLINEABLE microsToLocalTime #-} microsToLocalTime :: Int64 -> LocalTime microsToLocalTime = evalState $ do- d <- state $ flip divMod $ 10^6 * 60 * 60 * 24+ d <- state $ flip divMod $ 10 ^ 6 * 60 * 60 * 24 u <- get return $ LocalTime (postgresJulianToDay d) (microsToTimeOfDay u) -{-# INLINABLE secsToTimeOfDay #-}+{-# INLINEABLE secsToTimeOfDay #-} secsToTimeOfDay :: Double -> TimeOfDay secsToTimeOfDay = evalState $ do@@ -62,7 +61,7 @@ return $ TimeOfDay (fromIntegral h) (fromIntegral m) (secsToPico s) -{-# INLINABLE secsToUTC #-}+{-# INLINEABLE secsToUTC #-} secsToUTC :: Double -> UTCTime secsToUTC = evalState $ do@@ -71,7 +70,7 @@ return $ UTCTime (postgresJulianToDay d) (secsToDiffTime s) -{-# INLINABLE secsToLocalTime #-}+{-# INLINEABLE secsToLocalTime #-} secsToLocalTime :: Double -> LocalTime secsToLocalTime = evalState $ do@@ -80,55 +79,56 @@ return $ LocalTime (postgresJulianToDay d) (secsToTimeOfDay s) -{-# INLINABLE secsToPico #-}+{-# INLINEABLE secsToPico #-} secsToPico :: Double -> Pico secsToPico s = unsafeCoerce (truncate $ toRational s * 10 ^ 12 :: Integer) -{-# INLINABLE secsToDiffTime #-}+{-# INLINEABLE secsToDiffTime #-} secsToDiffTime :: Double -> DiffTime secsToDiffTime = unsafeCoerce secsToPico -{-# INLINABLE localTimeToMicros #-}+{-# INLINEABLE localTimeToMicros #-} localTimeToMicros :: LocalTime -> Int64 localTimeToMicros (LocalTime dayX timeX) = let d = dayToPostgresJulian dayX p = unsafeCoerce $ timeOfDayToTime timeX- in 10^6 * 60 * 60 * 24 * fromIntegral d + fromIntegral (div p (10^6))+ in 10 ^ 6 * 60 * 60 * 24 * fromIntegral d + fromIntegral (div p (10 ^ 6)) -{-# INLINABLE localTimeToSecs #-}+{-# INLINEABLE localTimeToSecs #-} localTimeToSecs :: LocalTime -> Double localTimeToSecs (LocalTime dayX timeX) = let d = dayToPostgresJulian dayX p = unsafeCoerce $ timeOfDayToTime timeX- in 60 * 60 * 24 * fromIntegral d + fromRational (p % (10^12))+ in 60 * 60 * 24 * fromIntegral d + fromRational (p % (10 ^ 12)) -{-# INLINABLE utcToMicros #-}+{-# INLINEABLE utcToMicros #-} utcToMicros :: UTCTime -> Int64 utcToMicros (UTCTime dayX diffTimeX) = let d = dayToPostgresJulian dayX p = unsafeCoerce diffTimeX- in 10^6 * 60 * 60 * 24 * fromIntegral d + fromIntegral (div p (10^6))+ in 10 ^ 6 * 60 * 60 * 24 * fromIntegral d + fromIntegral (div p (10 ^ 6)) -{-# INLINABLE utcToSecs #-}+{-# INLINEABLE utcToSecs #-} utcToSecs :: UTCTime -> Double utcToSecs (UTCTime dayX diffTimeX) = let d = dayToPostgresJulian dayX p = unsafeCoerce diffTimeX- in 60 * 60 * 24 * fromIntegral d + fromRational (p % (10^12))-+ in 60 * 60 * 24 * fromIntegral d + fromRational (p % (10 ^ 12)) -- * Constants in microseconds according to Julian dates standard--------------------------+ -- According to -- http://www.postgresql.org/docs/9.1/static/datatype-datetime.html -- Postgres uses Julian dates internally-------------------------- -yearMicros :: Int64 = truncate (365.2425 * fromIntegral dayMicros :: Rational)-dayMicros :: Int64 = 24 * hourMicros-hourMicros :: Int64 = 60 * minuteMicros+yearMicros :: Int64 = truncate (365.2425 * fromIntegral dayMicros :: Rational)++dayMicros :: Int64 = 24 * hourMicros++hourMicros :: Int64 = 60 * minuteMicros+ minuteMicros :: Int64 = 60 * secondMicros-secondMicros :: Int64 = 10 ^ 6 +secondMicros :: Int64 = 10 ^ 6
postgresql-binary.cabal view
@@ -1,7 +1,7 @@ name: postgresql-binary version:- 0.13+ 0.13.1 synopsis: Encoders and decoders for the PostgreSQL's binary format description:@@ -89,7 +89,8 @@ main-is: Main.hs other-modules:- Main.TextEncoder + Main.Composite + Main.TextEncoder Main.DB Main.Apx Main.IO
tasty/Main.hs view
@@ -1,25 +1,25 @@ module Main where -import Main.Prelude hiding (assert, isRight, isLeft, select) import Control.Monad.IO.Class-import Test.QuickCheck.Instances-import Test.Tasty-import qualified Test.Tasty.HUnit as HUnit-import qualified Test.Tasty.QuickCheck as QuickCheck-import qualified Test.QuickCheck as QuickCheck-import qualified PostgreSQL.Binary.Encoding as A-import qualified PostgreSQL.Binary.Decoding as B import qualified Data.ByteString as ByteString+import qualified Data.Text.Lazy as TextLazy+import qualified Database.PostgreSQL.LibPQ as LibPQ+import Main.Apx (Apx (..))+import qualified Main.Composite as Composite import qualified Main.DB as DB import qualified Main.Gens as Gens-import qualified Main.Properties as Properties import qualified Main.IO as IO import qualified Main.PTI as PTI+import Main.Prelude hiding (assert, isLeft, isRight, select)+import qualified Main.Properties as Properties import qualified Main.TextEncoder as TextEncoder-import qualified Database.PostgreSQL.LibPQ as LibPQ-import qualified Data.Text.Lazy as TextLazy-import Main.Apx (Apx(..))-+import qualified PostgreSQL.Binary.Decoding as B+import qualified PostgreSQL.Binary.Encoding as A+import qualified Test.QuickCheck as QuickCheck+import Test.QuickCheck.Instances+import Test.Tasty+import Test.Tasty.HUnit as HUnit+import Test.Tasty.QuickCheck as QuickCheck main = defaultMain (testGroup "" [binary, textual])@@ -35,61 +35,56 @@ then [primitiveRoundtrip "jsonb" Gens.aeson PTI.jsonb A.jsonb_ast B.jsonb_ast] else [] other =- [- select "select (234 :: int8)" (const B.int) (234 :: Int32)- ,- select "select (-234 :: int8)" (const B.int) (-234 :: Int32)- ,- select "select (0 :: int8)" (const B.int) (0 :: Int32)- ,- let- sql =- "select (1, 'a')"- decoder _ =- B.composite ((,) <$> B.valueComposite B.int <*> B.valueComposite B.char)- expected =- (1 :: Int64, 'a')- in select sql decoder expected- ,- let- sql =- "select (1, null)"- decoder _ =- 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 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 B.interval_float B.interval_int)- (10 :: DiffTime)- ,+ [ testProperty ("Composite roundtrip") $ \value ->+ Composite.decodingProperty value (Composite.encodeToByteString value),+ select "select (234 :: int8)" (const B.int) (234 :: Int32),+ select "select (-234 :: int8)" (const B.int) (-234 :: Int32),+ select "select (0 :: int8)" (const B.int) (0 :: Int32),+ let sql =+ "select (1, 'a')"+ decoder _ =+ B.composite ((,) <$> B.valueComposite B.int <*> B.valueComposite B.char)+ expected =+ (1 :: Int64, 'a')+ in select sql decoder expected,+ let sql =+ "select (1, null)"+ decoder _ =+ 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 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 B.interval_float B.interval_int)+ (10 :: DiffTime), HUnit.testCase "Interval encoder: 10 seconds" $- let- pti =- PTI.interval- encoder integerDatetimes =- (bool A.interval_float A.interval_int integerDatetimes)- decoder =- (bool B.interval_float B.interval_int)- value =- (10 :: DiffTime)- in- HUnit.assertEqual "" (Right value) =<<- IO.roundtrip (PTI.oidPQ (PTI.ptiOID pti)) encoder decoder value- ,- timeRoundtrip "interval" Gens.intervalDiffTime PTI.interval- (bool A.interval_float A.interval_int)- (bool B.interval_float B.interval_int)- ,- timeRoundtrip "timestamp" (fmap Apx Gens.auto) PTI.timestamp- ((. unApx) . bool A.timestamp_float A.timestamp_int)- (fmap Apx . bool B.timestamp_float B.timestamp_int)- ,+ let pti =+ PTI.interval+ encoder integerDatetimes =+ (bool A.interval_float A.interval_int integerDatetimes)+ decoder =+ (bool B.interval_float B.interval_int)+ value =+ (10 :: DiffTime)+ in HUnit.assertEqual "" (Right value)+ =<< IO.roundtrip (PTI.oidPQ (PTI.ptiOID pti)) encoder decoder value,+ timeRoundtrip+ "interval"+ Gens.intervalDiffTime+ PTI.interval+ (bool A.interval_float A.interval_int)+ (bool B.interval_float B.interval_int),+ timeRoundtrip+ "timestamp"+ (fmap Apx Gens.auto)+ PTI.timestamp+ ((. 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@@ -99,9 +94,11 @@ 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))- ((A.encodingBytes . encoder) x) - (LibPQ.Binary)+ let p =+ (,,)+ (PTI.oidPQ (PTI.ptiOID PTI.timestamptz))+ ((A.encodingBytes . encoder) x)+ (LibPQ.Binary) x = read "2011-09-28 00:17:25Z" DB.unit "insert into a (b) values ($1)" [Just p] DB.unit "set timezone to 'Europe/Stockholm'" []@@ -109,172 +106,145 @@ 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:25Z")) decoded- ,- timeRoundtrip "timestamptz" (fmap Apx Gens.auto) PTI.timestamptz- ((. 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 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 A.time_float A.time_int)- (fmap Apx . bool B.time_float B.time_int)- ,- primitiveRoundtrip "numeric" Gens.scientific PTI.numeric A.numeric B.numeric- ,- select "SELECT -1234560.789 :: numeric" (const B.numeric) (read "-1234560.789")- ,- select "SELECT -0.0789 :: numeric" (const B.numeric) (read "-0.0789")- ,- select "SELECT 10000 :: numeric" (const B.numeric) (read "10000")- ,- primitiveRoundtrip "float4" Gens.auto PTI.float4 A.float4 B.float4- ,- primitiveRoundtrip "float8" Gens.auto PTI.float8 A.float8 B.float8- ,- primitiveRoundtrip "char" Gens.char PTI.text A.char_utf8 B.char- ,- primitiveRoundtrip "text_strict" Gens.text PTI.text A.text_strict B.text_strict- ,- primitiveRoundtrip "text_lazy" (fmap TextLazy.fromStrict Gens.text) PTI.text A.text_lazy B.text_lazy- ,- primitiveRoundtrip "bytea_strict" Gens.auto PTI.bytea A.bytea_strict B.bytea_strict- ,- primitiveRoundtrip "bytea_lazy" Gens.auto PTI.bytea A.bytea_lazy B.bytea_lazy- ,- primitiveRoundtrip "uuid" Gens.uuid PTI.uuid A.uuid B.uuid- ,- primitiveRoundtrip "inet" Gens.inet PTI.inet A.inet B.inet- ,- primitiveRoundtrip "int2_int16" Gens.auto PTI.int2 A.int2_int16 B.int- ,- primitiveRoundtrip "int2_word16" Gens.auto PTI.int2 A.int2_word16 B.int- ,- primitiveRoundtrip "int4_int32" Gens.auto PTI.int4 A.int4_int32 B.int- ,- primitiveRoundtrip "int4_word32" Gens.auto PTI.int4 A.int4_word32 B.int- ,- primitiveRoundtrip "int8_int64" Gens.auto PTI.int8 A.int8_int64 B.int- ,- primitiveRoundtrip "int8_word64" Gens.auto PTI.int8 A.int8_word64 B.int- ,- primitiveRoundtrip "bool" Gens.auto PTI.bool A.bool B.bool- ,- primitiveRoundtrip "date" Gens.auto PTI.date A.date B.date- ,- let- decoder =- 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 =- 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 =- B.array $- B.dimensionArray replicateM $- B.dimensionArray replicateM $- B.dimensionArray replicateM $- B.valueArray $- B.int- in- arrayCodec (Gens.array3 Gens.auto) encoder decoder- ,- let- pti =- PTI.text- encoder =- 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 =- 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+ HUnit.assertEqual "" (Right (read "2011-09-28 00:17:25Z")) decoded,+ timeRoundtrip+ "timestamptz"+ (fmap Apx Gens.auto)+ PTI.timestamptz+ ((. 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 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 A.time_float A.time_int)+ (fmap Apx . bool B.time_float B.time_int),+ primitiveRoundtrip "numeric" Gens.scientific PTI.numeric A.numeric B.numeric,+ select "SELECT -1234560.789 :: numeric" (const B.numeric) (read "-1234560.789"),+ select "SELECT -0.0789 :: numeric" (const B.numeric) (read "-0.0789"),+ select "SELECT 10000 :: numeric" (const B.numeric) (read "10000"),+ primitiveRoundtrip "float4" Gens.auto PTI.float4 A.float4 B.float4,+ primitiveRoundtrip "float8" Gens.auto PTI.float8 A.float8 B.float8,+ primitiveRoundtrip "char" Gens.char PTI.text A.char_utf8 B.char,+ primitiveRoundtrip "text_strict" Gens.text PTI.text A.text_strict B.text_strict,+ primitiveRoundtrip "text_lazy" (fmap TextLazy.fromStrict Gens.text) PTI.text A.text_lazy B.text_lazy,+ primitiveRoundtrip "bytea_strict" Gens.auto PTI.bytea A.bytea_strict B.bytea_strict,+ primitiveRoundtrip "bytea_lazy" Gens.auto PTI.bytea A.bytea_lazy B.bytea_lazy,+ primitiveRoundtrip "uuid" Gens.uuid PTI.uuid A.uuid B.uuid,+ primitiveRoundtrip "inet" Gens.inet PTI.inet A.inet B.inet,+ primitiveRoundtrip "int2_int16" Gens.auto PTI.int2 A.int2_int16 B.int,+ primitiveRoundtrip "int2_word16" Gens.auto PTI.int2 A.int2_word16 B.int,+ primitiveRoundtrip "int4_int32" Gens.auto PTI.int4 A.int4_int32 B.int,+ primitiveRoundtrip "int4_word32" Gens.auto PTI.int4 A.int4_word32 B.int,+ primitiveRoundtrip "int8_int64" Gens.auto PTI.int8 A.int8_int64 B.int,+ primitiveRoundtrip "int8_word64" Gens.auto PTI.int8 A.int8_word64 B.int,+ primitiveRoundtrip "bool" Gens.auto PTI.bool A.bool B.bool,+ primitiveRoundtrip "date" Gens.auto PTI.date A.date B.date,+ let decoder =+ 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 =+ 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 =+ B.array $+ B.dimensionArray replicateM $+ B.dimensionArray replicateM $+ B.dimensionArray replicateM $+ B.valueArray $+ B.int+ in arrayCodec (Gens.array3 Gens.auto) encoder decoder,+ let pti =+ PTI.text+ encoder =+ 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 =+ 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 ] textual = testGroup "Textual format" $- [- test "numeric" Gens.scientific PTI.numeric TextEncoder.numeric (const B.numeric)- ,- test "float4" Gens.auto PTI.float4 TextEncoder.float4 (const B.float4)- ,- test "float8" Gens.auto PTI.float8 TextEncoder.float8 (const B.float8)- ,- test "uuid" Gens.uuid PTI.uuid TextEncoder.uuid (const B.uuid)- ,- test "int2_int16" Gens.auto PTI.int2 TextEncoder.int2_int16 (const B.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 B.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 B.int)- ,- test "int8_word64" Gens.postgresInt PTI.int8 TextEncoder.int8_word64 (const B.int)- ,- test "bool" Gens.auto PTI.bool TextEncoder.bool (const B.bool)- ]+ [ test "numeric" Gens.scientific PTI.numeric TextEncoder.numeric (const B.numeric),+ test "float4" Gens.auto PTI.float4 TextEncoder.float4 (const B.float4),+ test "float8" Gens.auto PTI.float8 TextEncoder.float8 (const B.float8),+ test "uuid" Gens.uuid PTI.uuid TextEncoder.uuid (const B.uuid),+ test "int2_int16" Gens.auto PTI.int2 TextEncoder.int2_int16 (const B.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 B.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 B.int),+ test "int8_word64" Gens.postgresInt PTI.int8 TextEncoder.int8_word64 (const B.int),+ test "bool" Gens.auto PTI.bool TextEncoder.bool (const B.bool)+ ] where test typeName gen pti encoder decoder = QuickCheck.testProperty (typeName <> " roundtrip") $- QuickCheck.forAll gen $ Properties.textRoundtrip (PTI.oidPQ (PTI.ptiOID pti)) encoder decoder+ QuickCheck.forAll gen $ Properties.textRoundtrip (PTI.oidPQ (PTI.ptiOID pti)) encoder decoder arrayCodec gen encoder decoder = QuickCheck.testProperty ("Array codec") $- QuickCheck.forAll gen $- \value -> (QuickCheck.===) (Right value) (B.valueParser decoder ((A.encodingBytes . encoder) value))+ QuickCheck.forAll gen $+ \value -> (QuickCheck.===) (Right value) (B.valueParser decoder ((A.encodingBytes . encoder) value)) arrayRoundtrip gen pti encoder decoder = QuickCheck.testProperty ("Array roundtrip") $- QuickCheck.forAll gen $ Properties.stdRoundtrip (PTI.oidPQ (fromJust (PTI.ptiArrayOID pti))) encoder decoder+ QuickCheck.forAll gen $ Properties.stdRoundtrip (PTI.oidPQ (fromJust (PTI.ptiArrayOID pti))) encoder decoder +stdRoundtrip ::+ (Eq a, Show a) =>+ TestName ->+ QuickCheck.Gen a ->+ PTI.PTI ->+ (a -> A.Encoding) ->+ B.Value a ->+ TestTree stdRoundtrip typeName gen pti encoder decoder = QuickCheck.testProperty (typeName <> " roundtrip") $- QuickCheck.forAll gen $ Properties.stdRoundtrip (PTI.oidPQ (PTI.ptiOID pti)) encoder decoder+ 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)) (\x -> encoder x) decoder+ QuickCheck.forAll gen $ Properties.roundtrip (PTI.oidPQ (PTI.ptiOID pti)) (\x -> encoder x) decoder select statement decoder value = HUnit.testCase (show statement) $- HUnit.assertEqual "" (Right value) $- unsafePerformIO $ IO.parameterlessStatement statement decoder value+ HUnit.assertEqual "" (Right value) $+ unsafePerformIO $ IO.parameterlessStatement statement decoder value {-# NOINLINE version #-} version :: Int version = either (error . show) id $- unsafePerformIO $- DB.session $- DB.serverVersion + unsafePerformIO $+ DB.session $+ DB.serverVersion
tasty/Main/Apx.hs view
@@ -2,33 +2,31 @@ import Main.Prelude - -- | -- A wrapper which provides a type-specific 'Eq' instance -- with approximate comparison.-newtype Apx a =- Apx { unApx :: a }+newtype Apx a = Apx {unApx :: a} deriving (Show) instance (Eq (Apx a), Eq (Apx b)) => Eq (Apx (a, b)) where (==) (Apx (a1, a2)) (Apx (b1, b2)) =- Apx a1 == Apx b1 &&- Apx a2 == Apx b2+ Apx a1 == Apx b1+ && Apx a2 == Apx b2 instance Eq (Apx LocalTime) where (==) (Apx a) (Apx b) =- Apx (localTimeToSeconds a) ==- Apx (localTimeToSeconds b)+ Apx (localTimeToSeconds a)+ == Apx (localTimeToSeconds b) instance Eq (Apx UTCTime) where (==) (Apx a) (Apx b) =- Apx (utcTimeToSeconds a) ==- Apx (utcTimeToSeconds b)+ Apx (utcTimeToSeconds a)+ == Apx (utcTimeToSeconds b) instance Eq (Apx TimeOfDay) where (==) (Apx a) (Apx b) =- Apx (timeOfDayToSeconds a) ==- Apx (timeOfDayToSeconds b)+ Apx (timeOfDayToSeconds a)+ == Apx (timeOfDayToSeconds b) instance Eq (Apx TimeZone) where (==) (Apx a) (Apx b) =@@ -40,13 +38,12 @@ instance Eq (Apx Rational) where (==) (Apx a) (Apx b) =- a + error >= b &&- a - error <= b+ a + error >= b+ && a - error <= b where error = 10 ^^ negate 3 - utcTimeToSeconds :: UTCTime -> Rational utcTimeToSeconds (UTCTime days diffTime) = dayToSeconds days + diffTimeToSeconds diffTime@@ -61,8 +58,8 @@ localTimeToSeconds :: LocalTime -> Rational localTimeToSeconds (LocalTime day tod) =- dayToSeconds day +- timeOfDayToSeconds tod+ dayToSeconds day+ + timeOfDayToSeconds tod timeOfDayToSeconds :: TimeOfDay -> Rational timeOfDayToSeconds (TimeOfDay h m s) =
+ tasty/Main/Composite.hs view
@@ -0,0 +1,75 @@+module Main.Composite where++import qualified Data.Aeson as Aeson+import qualified Data.Aeson.Key as AesonKey+import qualified Data.Aeson.KeyMap as AesonKeyMap+import qualified Data.HashMap.Strict as HashMap+import qualified Data.Scientific as Scientific+import qualified Data.Text as Text+import qualified Data.UUID as UUID+import qualified Data.Vector as Vector+import qualified Main.Gens as Gens+import Main.Prelude hiding (assert, choose, isLeft, isRight)+import qualified Network.IP.Addr as IPAddr+import qualified PostgreSQL.Binary.Decoding as Decoding+import qualified PostgreSQL.Binary.Encoding as Encoding+import Test.QuickCheck hiding (vector)+import Test.QuickCheck.Instances++newtype Composite = Composite [CompositeFieldValue]+ deriving (Show, Eq, Ord)++instance Arbitrary Composite where+ arbitrary = Composite <$> listOf arbitrary++data CompositeFieldValue+ = Int4CompositeFieldValue !(Maybe Int32)+ | TextCompositeFieldValue !(Maybe Text)+ | JsonbCompositeFieldValue !(Maybe Aeson.Value)+ deriving (Show, Eq, Ord)++instance Arbitrary CompositeFieldValue where+ arbitrary =+ oneof+ [ Int4CompositeFieldValue <$> arbitrary,+ TextCompositeFieldValue <$> Gens.maybeOf Gens.text,+ JsonbCompositeFieldValue <$> Gens.maybeOf Gens.aeson+ ]++encodeToByteString :: Composite -> ByteString+encodeToByteString = Encoding.encodingBytes . encodeComposite++encodeComposite :: Composite -> Encoding.Encoding+encodeComposite (Composite fields) =+ Encoding.composite $ foldMap compositeField fields+ where+ compositeField = \case+ Int4CompositeFieldValue z -> fieldEncoder 23 Encoding.int4_int32 z+ TextCompositeFieldValue z -> fieldEncoder 25 Encoding.text_strict z+ JsonbCompositeFieldValue z -> fieldEncoder 3802 Encoding.jsonb_ast z+ where+ fieldEncoder oid encoder = \case+ Nothing -> Encoding.nullField oid+ Just value -> Encoding.field oid $ encoder value++decodingProperty :: Composite -> ByteString -> Property+decodingProperty composite input =+ case Decoding.valueParser (decoder composite) input of+ Right p -> p+ Left err -> counterexample (Text.unpack err) False++decoder :: Composite -> Decoding.Value Property+decoder (Composite fields) =+ conjoin <$> Decoding.composite (traverse field fields)+ where+ field = \case+ Int4CompositeFieldValue z -> expect z Decoding.int+ TextCompositeFieldValue z -> expect z Decoding.text_strict+ JsonbCompositeFieldValue z -> expect z Decoding.jsonb_ast+ where+ expect expectedValue decoder =+ case expectedValue of+ Just expectedValue ->+ Decoding.valueComposite decoder <&> (===) expectedValue+ Nothing ->+ Decoding.nullableValueComposite decoder <&> (===) Nothing
tasty/Main/DB.hs view
@@ -1,19 +1,18 @@ module Main.DB-(- session,- oneRow,- unit,- integerDatetimes,- serverVersion,-)+ ( session,+ oneRow,+ unit,+ integerDatetimes,+ serverVersion,+ ) where -import Main.Prelude hiding (unit)-import Control.Monad.Trans.Reader import Control.Monad.IO.Class+import Control.Monad.Trans.Reader+import Data.ByteString (ByteString)+import qualified Data.ByteString as ByteString import qualified Database.PostgreSQL.LibPQ as LibPQ-import qualified Data.ByteString as ByteString; import Data.ByteString (ByteString)-+import Main.Prelude hiding (unit) type Session = ExceptT ByteString (ReaderT LibPQ.Connection IO)@@ -47,13 +46,14 @@ checkResult :: Maybe LibPQ.Result -> Session () checkResult result =- ExceptT $ ReaderT $ \connection -> do- case result of- Just result -> do- LibPQ.resultErrorField result LibPQ.DiagMessagePrimary >>= maybe (return (Right ())) (return . Left)- Nothing -> do- m <- LibPQ.errorMessage connection- return $ Left $ maybe "Fatal PQ error" (\m -> "Fatal PQ error: " <> m) m+ ExceptT $+ ReaderT $ \connection -> do+ case result of+ Just result -> do+ LibPQ.resultErrorField result LibPQ.DiagMessagePrimary >>= maybe (return (Right ())) (return . Left)+ Nothing -> do+ m <- LibPQ.errorMessage connection+ return $ Left $ maybe "Fatal PQ error" (\m -> "Fatal PQ error: " <> m) m integerDatetimes :: Session Bool integerDatetimes =@@ -63,19 +63,15 @@ serverVersion = lift (ReaderT LibPQ.serverVersion) --- *--------------------------- connect :: IO LibPQ.Connection connect = LibPQ.connectdb bs where- bs = + bs = ByteString.intercalate " " components where- components = - [- "host=" <> host,+ components =+ [ "host=" <> host, "port=" <> (fromString . show) port, "user=" <> user, "password=" <> password,@@ -90,18 +86,20 @@ initConnection :: LibPQ.Connection -> IO () initConnection c =- void $ LibPQ.exec c $ mconcat $ map (<> ";") $ - [ - "SET client_min_messages TO WARNING",- "SET client_encoding = 'UTF8'",- "SET intervalstyle = 'postgres'"- ]+ void $+ LibPQ.exec c $+ mconcat $+ map (<> ";") $+ [ "SET client_min_messages TO WARNING",+ "SET client_encoding = 'UTF8'",+ "SET intervalstyle = 'postgres'"+ ] getIntegerDatetimes :: LibPQ.Connection -> IO Bool getIntegerDatetimes c = fmap parseResult $ LibPQ.parameterStatus c "integer_datetimes" where- parseResult = + parseResult = \case Just "on" -> True _ -> False
tasty/Main/Gens.hs view
@@ -1,23 +1,25 @@ module Main.Gens where -import Main.Prelude hiding (assert, isRight, isLeft, choose)-import Test.QuickCheck hiding (vector)-import Test.QuickCheck.Instances-import qualified Main.PTI as PTI+import qualified Data.Aeson as Aeson+import qualified Data.Aeson.Key as AesonKey+import qualified Data.Aeson.KeyMap as AesonKeyMap+import qualified Data.HashMap.Strict as HashMap import qualified Data.Scientific as Scientific+import qualified Data.Text as Text import qualified Data.UUID as UUID import qualified Data.Vector as Vector-import qualified Data.HashMap.Strict as HashMap-import qualified PostgreSQL.Binary.Encoding as Encoder-import qualified Data.Text as Text-import qualified Data.Aeson as Aeson-import qualified Data.Aeson.KeyMap as AesonKeyMap-import qualified Data.Aeson.Key as AesonKey+import qualified Main.PTI as PTI+import Main.Prelude hiding (assert, choose, isLeft, isRight) import qualified Network.IP.Addr as IPAddr+import qualified PostgreSQL.Binary.Encoding as Encoder+import Test.QuickCheck hiding (vector)+import Test.QuickCheck.Instances +maybeOf :: Gen a -> Gen (Maybe a)+maybeOf gen =+ oneof [Just <$> gen, pure Nothing] -- * Generators-------------------------- auto :: Arbitrary a => Gen a auto =@@ -95,11 +97,13 @@ microsTimeOfDay :: Gen TimeOfDay microsTimeOfDay =- fmap timeToTimeOfDay $ fmap picosecondsToDiffTime $ fmap (* (10^6)) $ - choose (0, (10^6)*24*60*60)+ fmap timeToTimeOfDay $+ fmap picosecondsToDiffTime $+ fmap (* (10 ^ 6)) $+ choose (0, (10 ^ 6) * 24 * 60 * 60) microsLocalTime :: Gen LocalTime-microsLocalTime = +microsLocalTime = LocalTime <$> arbitrary <*> microsTimeOfDay microsUTCTime :: Gen UTCTime@@ -108,14 +112,14 @@ intervalDiffTime :: Gen DiffTime intervalDiffTime = do- unsafeCoerce ((* (10^6)) <$> choose (uMin, uMax) :: Gen Integer)+ unsafeCoerce ((* (10 ^ 6)) <$> choose (uMin, uMax) :: Gen Integer) where- uMin = unsafeCoerce minInterval `div` 10^6- uMax = unsafeCoerce maxInterval `div` 10^6+ uMin = unsafeCoerce minInterval `div` 10 ^ 6+ uMax = unsafeCoerce maxInterval `div` 10 ^ 6 timeZone :: Gen TimeZone timeZone =- minutesToTimeZone <$> choose (- 60 * 12 + 1, 60 * 12)+ minutesToTimeZone <$> choose (-60 * 12 + 1, 60 * 12) timetz :: Gen (TimeOfDay, TimeZone) timetz =@@ -129,8 +133,14 @@ inet = do ipv6 <- choose (True, False) if ipv6- then IPAddr.netAddr <$> (IPAddr.IPv6 <$> (IPAddr.ip6FromWords <$>- arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary)) <*> choose (0, 128)+ then+ IPAddr.netAddr+ <$> ( IPAddr.IPv6+ <$> ( IPAddr.ip6FromWords+ <$> 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) array3 :: Gen a -> Gen [[[a]]]@@ -141,13 +151,11 @@ width3 <- choose (1, 10) replicateM width1 (replicateM width2 (replicateM width3 gen)) - -- * Constants-------------------------- -maxInterval :: DiffTime = - unsafeCoerce $ +maxInterval :: DiffTime =+ unsafeCoerce $ (truncate (1780000 * 365.2425 * 24 * 60 * 60 * 10 ^ 12 :: Rational) :: Integer) -minInterval :: DiffTime = +minInterval :: DiffTime = negate maxInterval
tasty/Main/IO.hs view
@@ -2,33 +2,32 @@ -- Specific IO Actions module Main.IO where -import Main.Prelude hiding (assert, isRight, isLeft)-import Test.QuickCheck-import Test.QuickCheck.Instances-import qualified Main.PTI as PTI-import qualified Main.DB as DB-import qualified Main.TextEncoder as TextEncoder +import qualified Data.ByteString.Builder as ByteStringBuilder+import qualified Data.ByteString.Lazy as ByteStringLazy import qualified Data.Scientific as Scientific+import qualified Data.Text.Encoding as Text import qualified Data.UUID as UUID import qualified Data.Vector as Vector-import qualified Data.Text.Encoding as Text+import qualified Database.PostgreSQL.LibPQ as LibPQ+import qualified Main.DB as DB+import qualified Main.PTI as PTI+import Main.Prelude hiding (assert, isLeft, isRight)+import qualified Main.TextEncoder as TextEncoder import qualified PostgreSQL.Binary.Decoding as A import qualified PostgreSQL.Binary.Encoding as B-import qualified Database.PostgreSQL.LibPQ as LibPQ-import qualified Data.ByteString.Builder as ByteStringBuilder-import qualified Data.ByteString.Lazy as ByteStringLazy-+import Test.QuickCheck+import Test.QuickCheck.Instances 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 $ A.valueParser (decoder integerDatetimes) bytes+ DB.session $ do+ integerDatetimes <- DB.integerDatetimes+ bytes <- DB.oneRow "SELECT $1" (params integerDatetimes) LibPQ.Binary+ return $ A.valueParser (decoder integerDatetimes) bytes where params integerDatetimes =- [ Just ( oid , bytes , LibPQ.Text ) ]+ [Just (oid, bytes, LibPQ.Text)] where bytes = (ByteStringLazy.toStrict . ByteStringBuilder.toLazyByteString . encoder) value@@ -36,13 +35,13 @@ 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 $ A.valueParser (decoder integerDatetimes) bytes+ DB.session $ do+ integerDatetimes <- DB.integerDatetimes+ bytes <- DB.oneRow "SELECT $1" (params integerDatetimes) LibPQ.Binary+ return $ A.valueParser (decoder integerDatetimes) bytes where params integerDatetimes =- [ Just ( oid , bytes , LibPQ.Binary ) ]+ [Just (oid, bytes, LibPQ.Binary)] where bytes = (B.encodingBytes . encoder integerDatetimes) value@@ -50,7 +49,7 @@ 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 $ A.valueParser (decoder integerDatetimes) bytes+ DB.session $ do+ integerDatetimes <- DB.integerDatetimes+ bytes <- DB.oneRow statement [] LibPQ.Binary+ return $ A.valueParser (decoder integerDatetimes) bytes
tasty/Main/PTI.hs view
@@ -1,14 +1,13 @@ module Main.PTI where -import Main.Prelude hiding (bool) import qualified Database.PostgreSQL.LibPQ as LibPQ-+import Main.Prelude hiding (bool) -- | A Postgresql type info-data PTI = PTI { ptiOID :: !OID, ptiArrayOID :: !(Maybe OID) }+data PTI = PTI {ptiOID :: !OID, ptiArrayOID :: !(Maybe OID)} -- | A Word32 and a LibPQ representation of an OID-data OID = OID { oidWord32 :: !Word32, oidPQ :: !LibPQ.Oid }+data OID = OID {oidWord32 :: !Word32, oidPQ :: !LibPQ.Oid} mkOID :: Word32 -> OID mkOID x =@@ -18,77 +17,142 @@ mkPTI oid arrayOID = PTI (mkOID oid) (fmap mkOID arrayOID) - -- * Constants-------------------------- -abstime = mkPTI 702 (Just 1023)-aclitem = mkPTI 1033 (Just 1034)-bit = mkPTI 1560 (Just 1561)-bool = mkPTI 16 (Just 1000)-box = mkPTI 603 (Just 1020)-bpchar = mkPTI 1042 (Just 1014)-bytea = mkPTI 17 (Just 1001)-char = mkPTI 18 (Just 1002)-cid = mkPTI 29 (Just 1012)-cidr = mkPTI 650 (Just 651)-circle = mkPTI 718 (Just 719)-cstring = mkPTI 2275 (Just 1263)-date = mkPTI 1082 (Just 1182)-daterange = mkPTI 3912 (Just 3913)-float4 = mkPTI 700 (Just 1021)-float8 = mkPTI 701 (Just 1022)-gtsvector = mkPTI 3642 (Just 3644)-inet = mkPTI 869 (Just 1041)-int2 = mkPTI 21 (Just 1005)-int2vector = mkPTI 22 (Just 1006)-int4 = mkPTI 23 (Just 1007)-int4range = mkPTI 3904 (Just 3905)-int8 = mkPTI 20 (Just 1016)-int8range = mkPTI 3926 (Just 3927)-interval = mkPTI 1186 (Just 1187)-json = mkPTI 114 (Just 199)-jsonb = mkPTI 3802 (Just 3807)-line = mkPTI 628 (Just 629)-lseg = mkPTI 601 (Just 1018)-macaddr = mkPTI 829 (Just 1040)-money = mkPTI 790 (Just 791)-name = mkPTI 19 (Just 1003)-numeric = mkPTI 1700 (Just 1231)-numrange = mkPTI 3906 (Just 3907)-oid = mkPTI 26 (Just 1028)-oidvector = mkPTI 30 (Just 1013)-path = mkPTI 602 (Just 1019)-point = mkPTI 600 (Just 1017)-polygon = mkPTI 604 (Just 1027)-record = mkPTI 2249 (Just 2287)-refcursor = mkPTI 1790 (Just 2201)-regclass = mkPTI 2205 (Just 2210)-regconfig = mkPTI 3734 (Just 3735)-regdictionary = mkPTI 3769 (Just 3770)-regoper = mkPTI 2203 (Just 2208)-regoperator = mkPTI 2204 (Just 2209)-regproc = mkPTI 24 (Just 1008)-regprocedure = mkPTI 2202 (Just 2207)-regtype = mkPTI 2206 (Just 2211)-reltime = mkPTI 703 (Just 1024)-text = mkPTI 25 (Just 1009)-tid = mkPTI 27 (Just 1010)-time = mkPTI 1083 (Just 1183)-timestamp = mkPTI 1114 (Just 1115)-timestamptz = mkPTI 1184 (Just 1185)-timetz = mkPTI 1266 (Just 1270)-tinterval = mkPTI 704 (Just 1025)-tsquery = mkPTI 3615 (Just 3645)-tsrange = mkPTI 3908 (Just 3909)-tstzrange = mkPTI 3910 (Just 3911)-tsvector = mkPTI 3614 (Just 3643)-txid_snapshot = mkPTI 2970 (Just 2949)-unknown = mkPTI 705 Nothing-uuid = mkPTI 2950 (Just 2951)-varbit = mkPTI 1562 (Just 1563)-varchar = mkPTI 1043 (Just 1015)-void = mkPTI 2278 Nothing-xid = mkPTI 28 (Just 1011)-xml = mkPTI 142 (Just 143)+abstime = mkPTI 702 (Just 1023) +aclitem = mkPTI 1033 (Just 1034)++bit = mkPTI 1560 (Just 1561)++bool = mkPTI 16 (Just 1000)++box = mkPTI 603 (Just 1020)++bpchar = mkPTI 1042 (Just 1014)++bytea = mkPTI 17 (Just 1001)++char = mkPTI 18 (Just 1002)++cid = mkPTI 29 (Just 1012)++cidr = mkPTI 650 (Just 651)++circle = mkPTI 718 (Just 719)++cstring = mkPTI 2275 (Just 1263)++date = mkPTI 1082 (Just 1182)++daterange = mkPTI 3912 (Just 3913)++float4 = mkPTI 700 (Just 1021)++float8 = mkPTI 701 (Just 1022)++gtsvector = mkPTI 3642 (Just 3644)++inet = mkPTI 869 (Just 1041)++int2 = mkPTI 21 (Just 1005)++int2vector = mkPTI 22 (Just 1006)++int4 = mkPTI 23 (Just 1007)++int4range = mkPTI 3904 (Just 3905)++int8 = mkPTI 20 (Just 1016)++int8range = mkPTI 3926 (Just 3927)++interval = mkPTI 1186 (Just 1187)++json = mkPTI 114 (Just 199)++jsonb = mkPTI 3802 (Just 3807)++line = mkPTI 628 (Just 629)++lseg = mkPTI 601 (Just 1018)++macaddr = mkPTI 829 (Just 1040)++money = mkPTI 790 (Just 791)++name = mkPTI 19 (Just 1003)++numeric = mkPTI 1700 (Just 1231)++numrange = mkPTI 3906 (Just 3907)++oid = mkPTI 26 (Just 1028)++oidvector = mkPTI 30 (Just 1013)++path = mkPTI 602 (Just 1019)++point = mkPTI 600 (Just 1017)++polygon = mkPTI 604 (Just 1027)++record = mkPTI 2249 (Just 2287)++refcursor = mkPTI 1790 (Just 2201)++regclass = mkPTI 2205 (Just 2210)++regconfig = mkPTI 3734 (Just 3735)++regdictionary = mkPTI 3769 (Just 3770)++regoper = mkPTI 2203 (Just 2208)++regoperator = mkPTI 2204 (Just 2209)++regproc = mkPTI 24 (Just 1008)++regprocedure = mkPTI 2202 (Just 2207)++regtype = mkPTI 2206 (Just 2211)++reltime = mkPTI 703 (Just 1024)++text = mkPTI 25 (Just 1009)++tid = mkPTI 27 (Just 1010)++time = mkPTI 1083 (Just 1183)++timestamp = mkPTI 1114 (Just 1115)++timestamptz = mkPTI 1184 (Just 1185)++timetz = mkPTI 1266 (Just 1270)++tinterval = mkPTI 704 (Just 1025)++tsquery = mkPTI 3615 (Just 3645)++tsrange = mkPTI 3908 (Just 3909)++tstzrange = mkPTI 3910 (Just 3911)++tsvector = mkPTI 3614 (Just 3643)++txid_snapshot = mkPTI 2970 (Just 2949)++unknown = mkPTI 705 Nothing++uuid = mkPTI 2950 (Just 2951)++varbit = mkPTI 1562 (Just 1563)++varchar = mkPTI 1043 (Just 1015)++void = mkPTI 2278 Nothing++xid = mkPTI 28 (Just 1011)++xml = mkPTI 142 (Just 143)
tasty/Main/Prelude.hs view
@@ -1,25 +1,17 @@ module Main.Prelude-( - module Exports,- LazyByteString,- ByteStringBuilder,- LazyText,- TextBuilder,-)+ ( module Exports,+ LazyByteString,+ ByteStringBuilder,+ LazyText,+ TextBuilder,+ ) where ---- rerebase---------------------------import Prelude as Exports hiding (assert, Data, fail, check)---- custom---------------------------import qualified Data.ByteString.Lazy import qualified Data.ByteString.Builder+import qualified Data.ByteString.Lazy import qualified Data.Text.Lazy import qualified Data.Text.Lazy.Builder-+import Prelude as Exports hiding (Data, assert, check, fail) type LazyByteString = Data.ByteString.Lazy.ByteString@@ -32,4 +24,3 @@ type TextBuilder = Data.Text.Lazy.Builder.Builder-
tasty/Main/Properties.hs view
@@ -1,22 +1,26 @@ module Main.Properties where -import Main.Prelude hiding (assert, isRight, isLeft)-import Test.QuickCheck-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.Decoding as A-import qualified PostgreSQL.Binary.Encoding as B-import qualified Main.TextEncoder as C -import qualified Main.PTI as PTI+import qualified Database.PostgreSQL.LibPQ as LibPQ import qualified Main.DB as DB import qualified Main.IO as IO-import qualified Database.PostgreSQL.LibPQ as LibPQ-+import qualified Main.PTI as PTI+import Main.Prelude hiding (assert, isLeft, isRight)+import qualified Main.TextEncoder as C+import qualified PostgreSQL.Binary.Decoding as A+import qualified PostgreSQL.Binary.Encoding as B+import Test.QuickCheck+import Test.QuickCheck.Instances -roundtrip :: (Show a, Eq a) => - LibPQ.Oid -> (Bool -> (a -> B.Encoding)) -> (Bool -> A.Value a) -> a -> Property+roundtrip ::+ (Show a, Eq a) =>+ 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)
tasty/Main/TextEncoder.hs view
@@ -1,12 +1,12 @@ -- | -- Encoders to text format.-module Main.TextEncoder where+module Main.TextEncoder where -import Main.Prelude hiding (maybe, bool) import Data.ByteString.Builder import qualified Data.ByteString.Builder.Scientific import qualified Data.Text.Encoding import qualified Data.UUID+import Main.Prelude hiding (bool, maybe) import qualified Main.Prelude as Prelude type Encoder a =@@ -19,11 +19,11 @@ int2_int16 :: Encoder Int16 int2_int16 = int16Dec- + int4_int32 :: Encoder Int32 int4_int32 = int32Dec- + int8_int64 :: Encoder Int64 int8_int64 = int64Dec@@ -31,11 +31,11 @@ int2_word16 :: Encoder Word16 int2_word16 = word16Dec- + int4_word32 :: Encoder Word32 int4_word32 = word32Dec- + int8_word64 :: Encoder Word64 int8_word64 = word64Dec@@ -59,4 +59,3 @@ bytea_strict :: Encoder ByteString bytea_strict = byteString-