From 19345cf624a6296a36a215b45e92c5ccadd4da11 Mon Sep 17 00:00:00 2001 From: Nikita Volkov Date: Mon, 20 May 2019 19:24:27 +0300 Subject: [PATCH 01/17] Redesign the encoders --- hasql.cabal | 1 + library/Hasql/Encoders.hs | 396 ++---------------------------- library/Hasql/Private/Encoders.hs | 371 ++++++++++++++++++++++++++++ library/Hasql/Private/Prelude.hs | 4 + library/Hasql/Statement.hs | 53 +++- tasty/Main.hs | 42 ++-- threads-test/Main/Statements.hs | 2 +- 7 files changed, 459 insertions(+), 410 deletions(-) create mode 100644 library/Hasql/Private/Encoders.hs diff --git a/hasql.cabal b/hasql.cabal index 9188bd8..5136b95 100644 --- a/hasql.cabal +++ b/hasql.cabal @@ -46,6 +46,7 @@ library Hasql.Private.Decoders.Row Hasql.Private.Decoders.Result Hasql.Private.Decoders.Results + Hasql.Private.Encoders Hasql.Private.Encoders.Array Hasql.Private.Encoders.Value Hasql.Private.Encoders.Params diff --git a/library/Hasql/Encoders.hs b/library/Hasql/Encoders.hs index 7f5f7e8..d2a9303 100644 --- a/library/Hasql/Encoders.hs +++ b/library/Hasql/Encoders.hs @@ -1,14 +1,25 @@ --- | --- A DSL for declaration of query parameter encoders. +{-| +A DSL for declaration of statement parameter encoders. + +For compactness of names all the types defined here imply being an encoder. +E.g., the `Array` type is an __encoder__ of arrays, not the data-structure itself. +-} module Hasql.Encoders ( - -- * Params + -- * Parameters product Params, - unit, + noParams, param, - nullableParam, - -- * Value - Value, + -- * Nullability + NullableOrNot, + nonNullable, + nullable, + -- * Param + Param, + primitive, + array, + -- * Primitive + Primitive, bool, int2, int4, @@ -31,381 +42,14 @@ module Hasql.Encoders jsonBytes, jsonb, jsonbBytes, - array, enum, unknown, -- * Array Array, element, - nullableElement, dimension, - -- ** Insert Many - -- $insertMany + foldableDimension, ) where -import Hasql.Private.Prelude hiding (bool) -import qualified PostgreSQL.Binary.Encoding as A -import qualified PostgreSQL.Binary.Data as B -import qualified Text.Builder as C -import qualified Hasql.Private.Encoders.Params as Params -import qualified Hasql.Private.Encoders.Value as Value -import qualified Hasql.Private.Encoders.Array as Array -import qualified Hasql.Private.PTI as PTI -import qualified Hasql.Private.Prelude as Prelude - --- * Parameters Product Encoder -------------------------- - --- | --- Encoder of some representation of the parameters product. --- --- Has instances of 'Contravariant', 'Divisible' and 'Monoid', --- which you can use to compose multiple parameters together. --- E.g., --- --- @ --- someParamsEncoder :: 'Params' (Int64, Maybe Text) --- someParamsEncoder = --- 'contramap' 'fst' ('param' 'int8') '<>' --- 'contramap' 'snd' ('nullableParam' 'text') --- @ --- --- As a general solution for tuples of any arity, instead of 'fst' and 'snd', --- consider the functions of the @contrazip@ family --- from the \"contravariant-extras\" package. --- E.g., here's how you can achieve the same as the above: --- --- @ --- someParamsEncoder :: 'Params' (Int64, Maybe Text) --- someParamsEncoder = --- 'contrazip2' ('param' 'int8') ('nullableParam' 'text') --- @ --- --- Here's how you can implement encoders for custom composite types: --- --- @ --- data Person = --- Person { name :: Text, gender :: Gender, age :: Int } --- --- data Gender = --- Male | Female --- --- personParams :: 'Params' Person --- personParams = --- 'contramap' name ('param' 'text') '<>' --- 'contramap' gender ('param' genderValue) '<>' --- 'contramap' (fromIntegral . age) ('param' 'int8') --- --- genderValue :: 'Value' Gender --- genderValue = --- 'contramap' genderText 'text' --- where --- genderText gender = --- case gender of --- Male -> "male" --- Female -> "female" --- @ --- -newtype Params a = - Params (Params.Params a) - deriving (Contravariant, Divisible, Decidable, Monoid, Semigroup) - --- | --- Encode no parameters. --- -{-# INLINABLE unit #-} -unit :: Params () -unit = - Params mempty - --- | --- Lift an individual value encoder to a parameters encoder. --- -{-# INLINABLE param #-} -param :: Value a -> Params a -param (Value x) = - Params (Params.value x) - --- | --- Lift an individual nullable value encoder to a parameters encoder. --- -{-# INLINABLE nullableParam #-} -nullableParam :: Value a -> Params (Maybe a) -nullableParam (Value x) = - Params (Params.nullableValue x) - - --- * Value Encoder -------------------------- - --- | --- An individual value encoder. --- Will be mapped to a single placeholder in the query. --- -newtype Value a = - Value (Value.Value a) - deriving (Contravariant) - --- | --- Encoder of @BOOL@ values. -{-# INLINABLE bool #-} -bool :: Value Bool -bool = - Value (Value.unsafePTIWithShow PTI.bool (const A.bool)) - --- | --- Encoder of @INT2@ values. -{-# INLINABLE int2 #-} -int2 :: Value Int16 -int2 = - Value (Value.unsafePTIWithShow PTI.int2 (const A.int2_int16)) - --- | --- Encoder of @INT4@ values. -{-# INLINABLE int4 #-} -int4 :: Value Int32 -int4 = - Value (Value.unsafePTIWithShow PTI.int4 (const A.int4_int32)) - --- | --- Encoder of @INT8@ values. -{-# INLINABLE int8 #-} -int8 :: Value Int64 -int8 = - Value (Value.unsafePTIWithShow PTI.int8 (const A.int8_int64)) - --- | --- Encoder of @FLOAT4@ values. -{-# INLINABLE float4 #-} -float4 :: Value Float -float4 = - Value (Value.unsafePTIWithShow PTI.float4 (const A.float4)) - --- | --- Encoder of @FLOAT8@ values. -{-# INLINABLE float8 #-} -float8 :: Value Double -float8 = - Value (Value.unsafePTIWithShow PTI.float8 (const A.float8)) - --- | --- Encoder of @NUMERIC@ values. -{-# INLINABLE numeric #-} -numeric :: Value B.Scientific -numeric = - Value (Value.unsafePTIWithShow PTI.numeric (const A.numeric)) - --- | --- Encoder of @CHAR@ values. --- Note that it supports UTF-8 values and --- identifies itself under the @TEXT@ OID because of that. -{-# INLINABLE char #-} -char :: Value Char -char = - Value (Value.unsafePTIWithShow PTI.text (const A.char_utf8)) - --- | --- Encoder of @TEXT@ values. -{-# INLINABLE text #-} -text :: Value Text -text = - Value (Value.unsafePTIWithShow PTI.text (const A.text_strict)) - --- | --- Encoder of @BYTEA@ values. -{-# INLINABLE bytea #-} -bytea :: Value ByteString -bytea = - Value (Value.unsafePTIWithShow PTI.bytea (const A.bytea_strict)) - --- | --- Encoder of @DATE@ values. -{-# INLINABLE date #-} -date :: Value B.Day -date = - Value (Value.unsafePTIWithShow PTI.date (const A.date)) - --- | --- Encoder of @TIMESTAMP@ values. -{-# INLINABLE timestamp #-} -timestamp :: Value B.LocalTime -timestamp = - Value (Value.unsafePTIWithShow PTI.timestamp (Prelude.bool A.timestamp_float A.timestamp_int)) - --- | --- Encoder of @TIMESTAMPTZ@ values. -{-# INLINABLE timestamptz #-} -timestamptz :: Value B.UTCTime -timestamptz = - Value (Value.unsafePTIWithShow PTI.timestamptz (Prelude.bool A.timestamptz_float A.timestamptz_int)) - --- | --- Encoder of @TIME@ values. -{-# INLINABLE time #-} -time :: Value B.TimeOfDay -time = - Value (Value.unsafePTIWithShow PTI.time (Prelude.bool A.time_float A.time_int)) - --- | --- Encoder of @TIMETZ@ values. -{-# INLINABLE timetz #-} -timetz :: Value (B.TimeOfDay, B.TimeZone) -timetz = - Value (Value.unsafePTIWithShow PTI.timetz (Prelude.bool A.timetz_float A.timetz_int)) - --- | --- Encoder of @INTERVAL@ values. -{-# INLINABLE interval #-} -interval :: Value B.DiffTime -interval = - Value (Value.unsafePTIWithShow PTI.interval (Prelude.bool A.interval_float A.interval_int)) - --- | --- Encoder of @UUID@ values. -{-# INLINABLE uuid #-} -uuid :: Value B.UUID -uuid = - Value (Value.unsafePTIWithShow PTI.uuid (const A.uuid)) - --- | --- Encoder of @INET@ values. -{-# INLINABLE inet #-} -inet :: Value (B.NetAddr B.IP) -inet = - Value (Value.unsafePTIWithShow PTI.inet (const A.inet)) - --- | --- Encoder of @JSON@ values from JSON AST. -{-# INLINABLE json #-} -json :: Value B.Value -json = - Value (Value.unsafePTIWithShow PTI.json (const A.json_ast)) - --- | --- Encoder of @JSON@ values from raw JSON. -{-# INLINABLE jsonBytes #-} -jsonBytes :: Value ByteString -jsonBytes = - Value (Value.unsafePTIWithShow PTI.json (const A.json_bytes)) - --- | --- Encoder of @JSONB@ values from JSON AST. -{-# INLINABLE jsonb #-} -jsonb :: Value B.Value -jsonb = - Value (Value.unsafePTIWithShow PTI.jsonb (const A.jsonb_ast)) - --- | --- Encoder of @JSONB@ values from raw JSON. -{-# INLINABLE jsonbBytes #-} -jsonbBytes :: Value ByteString -jsonbBytes = - Value (Value.unsafePTIWithShow PTI.jsonb (const A.jsonb_bytes)) - --- | --- Unlifts the 'Array' encoder to the plain 'Value' encoder. -{-# INLINABLE array #-} -array :: Array a -> Value a -array (Array (Array.Array valueOID arrayOID arrayEncoder renderer)) = - let - encoder env input = - A.array (PTI.oidWord32 valueOID) (arrayEncoder env input) - in Value (Value.Value arrayOID arrayOID encoder renderer) - --- | --- Given a function, --- which maps the value into the textual enum label from the DB side, --- produces a encoder of that value. -{-# INLINABLE enum #-} -enum :: (a -> Text) -> Value a -enum mapping = - Value (Value.unsafePTI PTI.text (const (A.text_strict . mapping)) (C.text . mapping)) - --- | --- Identifies the value with the PostgreSQL's \"unknown\" type, --- thus leaving it up to Postgres to infer the actual type of the value. --- --- The value transimitted is any value encoded in the Postgres' Text data format. --- For reference, see the --- --- section of the Postgres' documentation. -{-# INLINABLE unknown #-} -unknown :: Value ByteString -unknown = - Value (Value.unsafePTIWithShow PTI.unknown (const A.bytea_strict)) - - --- * Array -------------------------- - --- | --- A generic array encoder. --- --- Here's an example of its usage: --- --- >x :: Value [[Int64]] --- >x = --- > array (dimension foldl' (dimension foldl' (element int8))) --- --- Please note that the PostgreSQL __IN__ keyword does not "accept" an array, but rather a syntactical list of --- values, thus this encoder is not suited for that. Use a **field** = ANY($1) query instead. --- -newtype Array a = - Array (Array.Array a) - --- | --- Lifts the 'Value' encoder into the 'Array' encoder of a non-nullable value. -{-# INLINABLE element #-} -element :: Value a -> Array a -element (Value (Value.Value elementOID arrayOID encoder renderer)) = - Array (Array.value elementOID arrayOID encoder renderer) - --- | --- Lifts the 'Value' encoder into the 'Array' encoder of a nullable value. -{-# INLINABLE nullableElement #-} -nullableElement :: Value a -> Array (Maybe a) -nullableElement (Value (Value.Value elementOID arrayOID encoder renderer)) = - Array (Array.nullableValue elementOID arrayOID encoder renderer) - --- | --- An encoder of an array dimension, --- which thus provides support for multidimensional arrays. --- --- Accepts: --- --- * An implementation of the left-fold operation, --- such as @Data.Foldable.'foldl''@, --- which determines the input value. --- --- * A component encoder, which can be either another 'dimension', --- 'element' or 'nullableElement'. --- -{-# INLINABLE dimension #-} -dimension :: (forall a. (a -> b -> a) -> a -> c -> a) -> Array b -> Array c -dimension foldl (Array imp) = - Array (Array.dimension foldl imp) - --- $insertMany --- It is not currently possible to pass in an array of encodable values --- to use in an 'insert many' statement using Hasql. Instead, PostgreSQL's --- (9.4 or later) `unnest` function can be used to in an analogous way --- to haskell's `zip` function by passing in multiple arrays of values --- to be zipped into the rows we want to insert: --- --- @ --- insertMultipleLocations :: Statement (Vector (UUID, Double, Double)) () --- insertMultipleLocations = --- statement sql encoder decoder True --- where --- sql = --- "insert into location (id, x, y) select * from unnest ($1, $2, $3)" --- encoder = --- contramap Vector.unzip3 $ --- contrazip3 (vector Encoders.uuid) (vector Encoders.float8) (vector Encoders.float8) --- where --- vector value = --- Encoders.param (Encoders.array (Encoders.dimension foldl' (Encoders.element value))) --- decoder = --- Decoders.unit --- @ +import Hasql.Private.Encoders diff --git a/library/Hasql/Private/Encoders.hs b/library/Hasql/Private/Encoders.hs new file mode 100644 index 0000000..7525065 --- /dev/null +++ b/library/Hasql/Private/Encoders.hs @@ -0,0 +1,371 @@ +{-| +A DSL for declaration of query parameter encoders. +-} +module Hasql.Private.Encoders +where + +import Hasql.Private.Prelude hiding (bool) +import qualified PostgreSQL.Binary.Encoding as A +import qualified PostgreSQL.Binary.Data as B +import qualified Text.Builder as C +import qualified Hasql.Private.Encoders.Params as Params +import qualified Hasql.Private.Encoders.Value as Value +import qualified Hasql.Private.Encoders.Array as Array +import qualified Hasql.Private.PTI as PTI +import qualified Hasql.Private.Prelude as Prelude + + +-- * Parameters Product Encoder +------------------------- + +{-| +Encoder of some representation of a parameters product. + +Has instances of 'Contravariant', 'Divisible' and 'Monoid', +which you can use to compose multiple parameters together. +E.g., + +@ +someParamsEncoder :: 'Params' (Int64, Maybe Text) +someParamsEncoder = + ('fst' '>$<' 'param' ('nonNullable' ('primitive' 'int8'))) '<>' + ('snd' '>$<' 'param' ('nullable' ('primitive' 'text'))) +@ + +As a general solution for tuples of any arity, instead of 'fst' and 'snd', +consider the functions of the @contrazip@ family +from the \"contravariant-extras\" package. +E.g., here's how you can achieve the same as the above: + +@ +someParamsEncoder :: 'Params' (Int64, Maybe Text) +someParamsEncoder = + 'contrazip2' ('param' ('nonNullable' ('primitive' 'int8'))) ('param' ('nullable' ('primitive' 'text'))) +@ + +Here's how you can implement encoders for custom composite types: + +@ +data Person = Person { name :: Text, gender :: Gender, age :: Int } + +data Gender = Male | Female + +personParams :: 'Params' Person +personParams = + (name '>$<' 'param' ('nonNullable' ('primitive' 'text'))) '<>' + (gender '>$<' 'param' ('nonNullable' ('primitive' genderPrimitive))) '<>' + ('fromIntegral' . age '>$<' 'param' ('nonNullable' ('primitive' 'int8'))) + +genderPrimitive :: 'Primitive' Gender +genderPrimitive = 'enum' genderText 'text' where + genderText gender = case gender of + Male -> "male" + Female -> "female" +@ +-} +newtype Params a = Params (Params.Params a) + deriving (Contravariant, Divisible, Decidable, Monoid, Semigroup) + +{-| +No parameters. Same as `mempty` and `conquered`. +-} +noParams :: Params () +noParams = mempty + +{-| +Lift a single parameter, with its nullability specified. +-} +param :: NullableOrNot Param a -> Params a +param = \ case + NonNullable (Param valueEnc) -> Params (Params.value valueEnc) + Nullable (Param valueEnc) -> Params (Params.nullableValue valueEnc) + + +-- * Nullability +------------------------- + +{-| +Extensional specification of nullability over a generic encoder. +-} +data NullableOrNot encoder a where + NonNullable :: encoder a -> NullableOrNot encoder a + Nullable :: encoder a -> NullableOrNot encoder (Maybe a) + +{-| +Specify that an encoder produces a non-nullable value. +-} +nonNullable :: encoder a -> NullableOrNot encoder a +nonNullable = NonNullable + +{-| +Specify that an encoder produces a nullable value. +-} +nullable :: encoder a -> NullableOrNot encoder (Maybe a) +nullable = Nullable + + +-- * Param +------------------------- + +{-| +An individual parameter encoder. +Will be mapped to a single placeholder in the statement. +-} +newtype Param a = Param (Value.Value a) + deriving (Contravariant) + +{-| +Lift a primitive value encoder into a parameter encoder. +-} +primitive :: Primitive a -> Param a +primitive (Primitive valueEnc) = Param valueEnc + +{-| +Lift an array encoder into a parameter encoder. +-} +array :: Array a -> Param a +array (Array (Array.Array valueOID arrayOID arrayEncoder renderer)) = let + encoder env input = A.array (PTI.oidWord32 valueOID) (arrayEncoder env input) + in Param (Value.Value arrayOID arrayOID encoder renderer) + + +-- * Primitive +------------------------- + +{-| +Primitive value encoder. +-} +newtype Primitive a = Primitive (Value.Value a) + deriving (Contravariant) + +{-| +Encoder of @BOOL@ values. +-} +{-# INLINABLE bool #-} +bool :: Primitive Bool +bool = Primitive (Value.unsafePTIWithShow PTI.bool (const A.bool)) + +{-| +Encoder of @INT2@ values. +-} +{-# INLINABLE int2 #-} +int2 :: Primitive Int16 +int2 = Primitive (Value.unsafePTIWithShow PTI.int2 (const A.int2_int16)) + +{-| +Encoder of @INT4@ values. +-} +{-# INLINABLE int4 #-} +int4 :: Primitive Int32 +int4 = Primitive (Value.unsafePTIWithShow PTI.int4 (const A.int4_int32)) + +{-| +Encoder of @INT8@ values. +-} +{-# INLINABLE int8 #-} +int8 :: Primitive Int64 +int8 = Primitive (Value.unsafePTIWithShow PTI.int8 (const A.int8_int64)) + +{-| +Encoder of @FLOAT4@ values. +-} +{-# INLINABLE float4 #-} +float4 :: Primitive Float +float4 = Primitive (Value.unsafePTIWithShow PTI.float4 (const A.float4)) + +{-| +Encoder of @FLOAT8@ values. +-} +{-# INLINABLE float8 #-} +float8 :: Primitive Double +float8 = Primitive (Value.unsafePTIWithShow PTI.float8 (const A.float8)) + +{-| +Encoder of @NUMERIC@ values. +-} +{-# INLINABLE numeric #-} +numeric :: Primitive B.Scientific +numeric = Primitive (Value.unsafePTIWithShow PTI.numeric (const A.numeric)) + +{-| +Encoder of @CHAR@ values. +-} +-- Note that it supports UTF-8 values and +-- identifies itself under the @TEXT@ OID because of that. +{-# INLINABLE char #-} +char :: Primitive Char +char = Primitive (Value.unsafePTIWithShow PTI.text (const A.char_utf8)) + +{-| +Encoder of @TEXT@ values. +-} +{-# INLINABLE text #-} +text :: Primitive Text +text = Primitive (Value.unsafePTIWithShow PTI.text (const A.text_strict)) + +{-| +Encoder of @BYTEA@ values. +-} +{-# INLINABLE bytea #-} +bytea :: Primitive ByteString +bytea = Primitive (Value.unsafePTIWithShow PTI.bytea (const A.bytea_strict)) + +{-| +Encoder of @DATE@ values. +-} +{-# INLINABLE date #-} +date :: Primitive B.Day +date = Primitive (Value.unsafePTIWithShow PTI.date (const A.date)) + +{-| +Encoder of @TIMESTAMP@ values. +-} +{-# INLINABLE timestamp #-} +timestamp :: Primitive B.LocalTime +timestamp = Primitive (Value.unsafePTIWithShow PTI.timestamp (Prelude.bool A.timestamp_float A.timestamp_int)) + +{-| +Encoder of @TIMESTAMPTZ@ values. +-} +{-# INLINABLE timestamptz #-} +timestamptz :: Primitive B.UTCTime +timestamptz = Primitive (Value.unsafePTIWithShow PTI.timestamptz (Prelude.bool A.timestamptz_float A.timestamptz_int)) + +{-| +Encoder of @TIME@ values. +-} +{-# INLINABLE time #-} +time :: Primitive B.TimeOfDay +time = Primitive (Value.unsafePTIWithShow PTI.time (Prelude.bool A.time_float A.time_int)) + +{-| +Encoder of @TIMETZ@ values. +-} +{-# INLINABLE timetz #-} +timetz :: Primitive (B.TimeOfDay, B.TimeZone) +timetz = Primitive (Value.unsafePTIWithShow PTI.timetz (Prelude.bool A.timetz_float A.timetz_int)) + +{-| +Encoder of @INTERVAL@ values. +-} +{-# INLINABLE interval #-} +interval :: Primitive B.DiffTime +interval = Primitive (Value.unsafePTIWithShow PTI.interval (Prelude.bool A.interval_float A.interval_int)) + +{-| +Encoder of @UUID@ values. +-} +{-# INLINABLE uuid #-} +uuid :: Primitive B.UUID +uuid = Primitive (Value.unsafePTIWithShow PTI.uuid (const A.uuid)) + +{-| +Encoder of @INET@ values. +-} +{-# INLINABLE inet #-} +inet :: Primitive (B.NetAddr B.IP) +inet = Primitive (Value.unsafePTIWithShow PTI.inet (const A.inet)) + +{-| +Encoder of @JSON@ values from JSON AST. +-} +{-# INLINABLE json #-} +json :: Primitive B.Value +json = Primitive (Value.unsafePTIWithShow PTI.json (const A.json_ast)) + +{-| +Encoder of @JSON@ values from raw JSON. +-} +{-# INLINABLE jsonBytes #-} +jsonBytes :: Primitive ByteString +jsonBytes = Primitive (Value.unsafePTIWithShow PTI.json (const A.json_bytes)) + +{-| +Encoder of @JSONB@ values from JSON AST. +-} +{-# INLINABLE jsonb #-} +jsonb :: Primitive B.Value +jsonb = Primitive (Value.unsafePTIWithShow PTI.jsonb (const A.jsonb_ast)) + +{-| +Encoder of @JSONB@ values from raw JSON. +-} +{-# INLINABLE jsonbBytes #-} +jsonbBytes :: Primitive ByteString +jsonbBytes = Primitive (Value.unsafePTIWithShow PTI.jsonb (const A.jsonb_bytes)) + +{-| +Given a function, +which maps a value into a textual enum label used on the DB side, +produces an encoder of that value. +-} +{-# INLINABLE enum #-} +enum :: (a -> Text) -> Primitive a +enum mapping = Primitive (Value.unsafePTI PTI.text (const (A.text_strict . mapping)) (C.text . mapping)) + +{-| +Identifies the value with the PostgreSQL's \"unknown\" type, +thus leaving it up to Postgres to infer the actual type of the value. + +The value transimitted is any value encoded in the Postgres' Text data format. +For reference, see the + +section of the Postgres' documentation. +-} +{-# INLINABLE unknown #-} +unknown :: Primitive ByteString +unknown = Primitive (Value.unsafePTIWithShow PTI.unknown (const A.bytea_strict)) + + +-- * Array +------------------------- + +{-| +Generic array encoder. + +Here's an example of its usage: + +@ +someParamsEncoder :: 'Params' [[Int64]] +someParamsEncoder = 'param' ('nonNullable' ('array' ('foldableDimension' ('foldableDimension' ('element' ('nonNullable' 'int8')))))) +@ + +Please note that the PostgreSQL __IN__ keyword does not accept an array, but rather a syntactical list of +values, thus this encoder is not suited for that. Use a @value = ANY($1)@ condition instead. +-} +newtype Array a = Array (Array.Array a) + +{-| +Lifts a 'Primitive' encoder into an 'Array' encoder. +-} +element :: NullableOrNot Primitive a -> Array a +element = \ case + NonNullable (Primitive (Value.Value elementOID arrayOID encoder renderer)) -> + Array (Array.value elementOID arrayOID encoder renderer) + Nullable (Primitive (Value.Value elementOID arrayOID encoder renderer)) -> + Array (Array.nullableValue elementOID arrayOID encoder renderer) + +{-| +Encoder of an array dimension, +which thus provides support for multidimensional arrays. + +Accepts: + +* An implementation of the left-fold operation, +such as @Data.Foldable.'foldl''@, +which determines the input value. + +* A component encoder, which can be either another 'dimension', +'element' or 'nullableElement'. +-} +{-# INLINABLE dimension #-} +dimension :: (forall a. (a -> b -> a) -> a -> c -> a) -> Array b -> Array c +dimension foldl (Array imp) = Array (Array.dimension foldl imp) + +{-| +Same as 'dimension', but specialized to 'Foldable' values, +which includes such structures as list and 'Vector'. +-} +{-# INLINE foldableDimension #-} +foldableDimension :: Foldable foldable => Array a -> Array (foldable a) +foldableDimension = dimension foldl' diff --git a/library/Hasql/Private/Prelude.hs b/library/Hasql/Private/Prelude.hs index 7d91ca6..e6964c3 100644 --- a/library/Hasql/Private/Prelude.hs +++ b/library/Hasql/Private/Prelude.hs @@ -81,6 +81,10 @@ import Development.Placeholders as Exports ------------------------- import Debug.Trace.LocationTH as Exports +-- postgresql-binary +------------------------- +import PostgreSQL.Binary.Data as Exports (UUID) + -- custom ------------------------- import qualified Debug.Trace.LocationTH diff --git a/library/Hasql/Statement.hs b/library/Hasql/Statement.hs index 8a0a70f..9375ed0 100644 --- a/library/Hasql/Statement.hs +++ b/library/Hasql/Statement.hs @@ -1,4 +1,36 @@ module Hasql.Statement +( + Statement(..), + -- * Recipies + -- ** Insert many + -- | + -- It is not currently possible to pass in an array of encodable values + -- to use in an insert many statement. Instead, PostgreSQL's + -- (9.4 or later) @unnest@ function can be used in an analogous way + -- to haskell's `zip` function by passing in multiple arrays of values + -- to be zipped into the rows we want to insert: + -- + -- @ + -- insertMultipleLocations :: 'Statement' (Vector (UUID, Double, Double)) () + -- insertMultipleLocations = 'Statement' sql encoder decoder True where + -- sql = "insert into location (id, x, y) select * from unnest ($1, $2, $3)" + -- encoder = + -- contramap Vector.'Data.Vector.unzip3' $ + -- contrazip3 (vector Encoders.'Encoders.uuid') (vector Encoders.'Encoders.float8') (vector Encoders.'Encoders.float8') + -- where + -- vector = + -- Encoders.'Encoders.param' . + -- Encoders.'Encoders.nonNullable' . + -- Encoders.'Encoders.array' . + -- Encoders.'Encoders.foldableDimension' . + -- Encoders.'Encoders.element' . + -- Encoders.'Encoders.nonNullable' + -- decoder = Decoders.'Decoders.unit' + -- @ + -- + -- This approach is much more efficient than executing a single-row Insert + -- statement multiple times. +) where import Hasql.Private.Prelude @@ -26,22 +58,17 @@ import qualified Hasql.Encoders as Encoders -- Following is an example of the declaration of a prepared statement with its associated codecs. -- -- @ --- selectSum :: Hasql.Statement.'Statement' (Int64, Int64) Int64 --- selectSum = --- Hasql.Statement.'Statement' sql encoder decoder True --- where --- sql = --- "select ($1 + $2)" --- encoder = --- 'contramap' 'fst' (Hasql.Encoders.'Hasql.Encoders.param' Hasql.Encoders.'Hasql.Encoders.int8') '<>' --- 'contramap' 'snd' (Hasql.Encoders.'Hasql.Encoders.param' Hasql.Encoders.'Hasql.Encoders.int8') --- decoder = --- Hasql.Decoders.'Hasql.Decoders.singleRow' (Hasql.Decoders.'Hasql.Decoders.column' Hasql.Decoders.'Hasql.Decoders.int8') +-- selectSum :: 'Statement' (Int64, Int64) Int64 +-- selectSum = 'Statement' sql encoder decoder True where +-- sql = "select ($1 + $2)" +-- encoder = +-- ('fst' '>$<' Encoders.'Hasql.Encoders.param' (Encoders.'Hasql.Encoders.nonNullable' (Encoders.'Hasql.Encoders.primitive' Encoders.'Hasql.Encoders.int8'))) '<>' +-- ('snd' '>$<' Encoders.'Hasql.Encoders.param' (Encoders.'Hasql.Encoders.nullable' (Encoders.'Hasql.Encoders.primitive' Encoders.'Hasql.Encoders.text'))) +-- decoder = Decoders.'Hasql.Decoders.singleRow' (Decoders.'Hasql.Decoders.column' Decoders.'Hasql.Decoders.int8') -- @ -- -- The statement above accepts a product of two parameters of type 'Int64' -- and produces a single result of type 'Int64'. --- data Statement a b = Statement ByteString (Encoders.Params a) (Decoders.Result b) Bool @@ -53,3 +80,5 @@ instance Profunctor Statement where {-# INLINE dimap #-} dimap f1 f2 (Statement template encoder decoder preparable) = Statement template (contramap f1 encoder) (fmap f2 decoder) preparable + + diff --git a/tasty/Main.hs b/tasty/Main.hs index b14a5f7..9847dd3 100644 --- a/tasty/Main.hs +++ b/tasty/Main.hs @@ -29,8 +29,8 @@ tree = where encoder = contrazip2 - (Encoders.param (Encoders.array (Encoders.dimension foldl' (Encoders.element Encoders.int8)))) - (Encoders.param Encoders.text) + (Encoders.param (Encoders.nonNullable (Encoders.array (Encoders.dimension foldl' (Encoders.element (Encoders.nonNullable Encoders.int8)))))) + (Encoders.param (Encoders.nonNullable (Encoders.primitive Encoders.text))) decoder = fmap (maybe False (const True)) (Decoders.rowMaybe (Decoders.column Decoders.bool)) session = @@ -47,7 +47,7 @@ tree = Statement.Statement "select true where 1 = any ($1)" encoder decoder True where encoder = - Encoders.param (Encoders.array (Encoders.dimension foldl' (Encoders.element Encoders.int8))) + Encoders.param (Encoders.nonNullable (Encoders.array (Encoders.dimension foldl' (Encoders.element (Encoders.nonNullable Encoders.int8))))) decoder = fmap (maybe False (const True)) (Decoders.rowMaybe (Decoders.column Decoders.bool)) session = @@ -65,7 +65,7 @@ tree = Statement.Statement "select true where 3 <> all ($1)" encoder decoder True where encoder = - Encoders.param (Encoders.array (Encoders.dimension foldl' (Encoders.element Encoders.int8))) + Encoders.param (Encoders.nonNullable (Encoders.array (Encoders.dimension foldl' (Encoders.element (Encoders.nonNullable Encoders.int8))))) decoder = fmap (maybe False (const True)) (Decoders.rowMaybe (Decoders.column Decoders.bool)) session = @@ -85,7 +85,7 @@ tree = sql = "select (1, true)" encoder = - Encoders.unit + mempty decoder = Decoders.singleRow (Decoders.column (Decoders.composite ((,) <$> Decoders.field Decoders.int8 <*> Decoders.field Decoders.bool))) session = @@ -102,7 +102,7 @@ tree = sql = "select (1, true) as entity1, ('hello', 3) as entity2" encoder = - Encoders.unit + mempty decoder = Decoders.singleRow $ (,) <$> Decoders.column entity1 <*> Decoders.column entity2 @@ -135,7 +135,7 @@ tree = sql = "select array[]::int8[]" encoder = - Encoders.unit + mempty decoder = Decoders.singleRow (Decoders.column (Decoders.array (Decoders.dimension replicateM (Decoders.element Decoders.int8)))) in io @@ -162,7 +162,7 @@ tree = sql = "absurd" encoder = - Encoders.unit + mempty decoder = Decoders.unit in io @@ -185,7 +185,7 @@ tree = sql = "select $1 :: int8" encoder = - Encoders.param Encoders.int8 + Encoders.param (Encoders.nonNullable (Encoders.primitive Encoders.int8)) decoder = Decoders.singleRow $ Decoders.column Decoders.int8 fail = @@ -201,8 +201,8 @@ tree = sql = "select ($1 + $2)" encoder = - contramap fst (Encoders.param Encoders.int8) <> - contramap snd (Encoders.param Encoders.int8) + contramap fst (Encoders.param (Encoders.nonNullable (Encoders.primitive Encoders.int8))) <> + contramap snd (Encoders.param (Encoders.nonNullable (Encoders.primitive Encoders.int8))) decoder = Decoders.singleRow (Decoders.column Decoders.int8) sumSession :: Session.Session Int64 @@ -226,8 +226,8 @@ tree = sql = "select ($1 + $2)" encoder = - contramap fst (Encoders.param Encoders.int8) <> - contramap snd (Encoders.param Encoders.int8) + contramap fst (Encoders.param (Encoders.nonNullable (Encoders.primitive Encoders.int8))) <> + contramap snd (Encoders.param (Encoders.nonNullable (Encoders.primitive Encoders.int8))) decoder = Decoders.singleRow (Decoders.column Decoders.int8) session :: Session.Session Int64 @@ -255,7 +255,7 @@ tree = decoder = (Decoders.singleRow (Decoders.column (Decoders.bool))) encoder = - Encoders.param (Encoders.interval) + Encoders.param (Encoders.nonNullable (Encoders.primitive Encoders.interval)) in DSL.statement (10 :: DiffTime) statement in actualIO >>= \x -> assertEqual (show x) (Right True) x , @@ -272,7 +272,7 @@ tree = decoder = (Decoders.singleRow (Decoders.column (Decoders.interval))) encoder = - Encoders.unit + Encoders.noParams in DSL.statement () statement in actualIO >>= \x -> assertEqual (show x) (Right (10 :: DiffTime)) x , @@ -289,7 +289,7 @@ tree = decoder = (Decoders.singleRow (Decoders.column (Decoders.interval))) encoder = - Encoders.param (Encoders.interval) + Encoders.param (Encoders.nonNullable (Encoders.primitive Encoders.interval)) in DSL.statement (10 :: DiffTime) statement in actualIO >>= \x -> assertEqual (show x) (Right (10 :: DiffTime)) x , @@ -320,7 +320,7 @@ tree = decoder = (Decoders.singleRow (Decoders.column (Decoders.bool))) encoder = - Encoders.param (Encoders.unknown) + Encoders.param (Encoders.nonNullable (Encoders.primitive Encoders.unknown)) in DSL.statement "ok" statement in actualIO >>= assertEqual "" (Right True) , @@ -351,7 +351,7 @@ tree = decoder = (Decoders.singleRow (Decoders.column (Decoders.text))) encoder = - contramany (Encoders.param Encoders.unknown) + contramany (Encoders.param (Encoders.nonNullable (Encoders.primitive Encoders.unknown))) in DSL.statement ["1", "2", "4", "5", "6"] statement in actualIO >>= assertEqual "" (Right "3456") , @@ -382,7 +382,7 @@ tree = decoder = (Decoders.singleRow (Decoders.column (Decoders.enum (Just . id)))) encoder = - Encoders.param (Encoders.enum id) + Encoders.param (Encoders.nonNullable (Encoders.primitive (Encoders.enum id))) in DSL.statement "ok" statement in actualIO >>= assertEqual "" (Right "ok") , @@ -400,7 +400,7 @@ tree = sql = "select $1" encoder = - Encoders.param Encoders.text + Encoders.param (Encoders.nonNullable (Encoders.primitive Encoders.text)) decoder = (Decoders.singleRow (Decoders.column (Decoders.text))) effect2 = @@ -412,7 +412,7 @@ tree = sql = "select $1" encoder = - Encoders.param Encoders.int8 + Encoders.param (Encoders.nonNullable (Encoders.primitive Encoders.int8)) decoder = (Decoders.singleRow (Decoders.column Decoders.int8)) in (,) <$> effect1 <*> effect2 diff --git a/threads-test/Main/Statements.hs b/threads-test/Main/Statements.hs index ecd591a..f652a7a 100644 --- a/threads-test/Main/Statements.hs +++ b/threads-test/Main/Statements.hs @@ -13,7 +13,7 @@ selectSleep = sql = "select pg_sleep($1)" encoder = - E.param E.float8 + E.param (E.nonNullable (E.primitive E.float8)) decoder = D.unit From 68339eeabefdf10be0ac47b840d296ae71f36bc2 Mon Sep 17 00:00:00 2001 From: Nikita Volkov Date: Mon, 20 May 2019 19:27:10 +0300 Subject: [PATCH 02/17] Ditch the coersion of encoders --- library/Hasql/Private/Session.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/library/Hasql/Private/Session.hs b/library/Hasql/Private/Session.hs index 87676ba..4145b3b 100644 --- a/library/Hasql/Private/Session.hs +++ b/library/Hasql/Private/Session.hs @@ -7,6 +7,7 @@ import qualified Database.PostgreSQL.LibPQ as LibPQ import qualified Hasql.Private.Decoders.Results as Decoders.Results import qualified Hasql.Private.Decoders.Result as Decoders.Result import qualified Hasql.Private.Encoders.Params as Encoders.Params +import qualified Hasql.Private.Encoders as Encoders import qualified Hasql.Private.Settings as Settings import qualified Hasql.Private.IO as IO import qualified Hasql.Statement as Statement @@ -44,16 +45,16 @@ sql sql = -- | -- Parameters and a specification of a parametric single-statement query to apply them to. statement :: params -> Statement.Statement params result -> Session result -statement input (Statement.Statement template encoder decoder preparable) = +statement input (Statement.Statement template (Encoders.Params paramsEncoder) decoder preparable) = Session $ ReaderT $ \(Connection.Connection pqConnectionRef integerDatetimes registry) -> ExceptT $ fmap (mapLeft (QueryError template inputReps)) $ withMVar pqConnectionRef $ \pqConnection -> do - r1 <- IO.sendParametricStatement pqConnection integerDatetimes registry template (unsafeCoerce encoder) preparable input + r1 <- IO.sendParametricStatement pqConnection integerDatetimes registry template paramsEncoder preparable input r2 <- IO.getResults pqConnection integerDatetimes (unsafeCoerce decoder) return $ r1 *> r2 where inputReps = let - Encoders.Params.Params (Op encoderOp) = (unsafeCoerce encoder) + Encoders.Params.Params (Op encoderOp) = paramsEncoder step (_, _, _, rendering) acc = rendering : acc in foldr step [] (encoderOp input) \ No newline at end of file From 590be494bc448bd47dded3d44390b8fbc8919dc4 Mon Sep 17 00:00:00 2001 From: Nikita Volkov Date: Tue, 21 May 2019 01:20:57 +0300 Subject: [PATCH 03/17] Redesign decoders --- benchmarks/Main.hs | 4 +- hasql.cabal | 1 + library/Hasql/Decoders.hs | 476 +----------------------------- library/Hasql/Private/Decoders.hs | 428 +++++++++++++++++++++++++++ profiling/Main.hs | 4 +- tasty/Main.hs | 42 +-- tasty/Main/Statements.hs | 2 +- 7 files changed, 463 insertions(+), 494 deletions(-) create mode 100644 library/Hasql/Private/Decoders.hs diff --git a/benchmarks/Main.hs b/benchmarks/Main.hs index c983951..7ec6572 100644 --- a/benchmarks/Main.hs +++ b/benchmarks/Main.hs @@ -79,7 +79,7 @@ statementWithSingleRow = D.singleRow row where row = - tuple <$> D.column D.int8 <*> D.column D.int8 + tuple <$> (D.column . D.nonNullable) D.int8 <*> (D.column . D.nonNullable) D.int8 where tuple !a !b = (a, b) @@ -93,7 +93,7 @@ statementWithManyRows decoder = encoder = conquer rowDecoder = - tuple <$> D.column D.int8 <*> D.column D.int8 + tuple <$> (D.column . D.nonNullable) D.int8 <*> (D.column . D.nonNullable) D.int8 where tuple !a !b = (a, b) diff --git a/hasql.cabal b/hasql.cabal index 5136b95..e5e7f9d 100644 --- a/hasql.cabal +++ b/hasql.cabal @@ -40,6 +40,7 @@ library Hasql.Private.PreparedStatementRegistry Hasql.Private.Settings Hasql.Private.Commands + Hasql.Private.Decoders Hasql.Private.Decoders.Array Hasql.Private.Decoders.Composite Hasql.Private.Decoders.Value diff --git a/library/Hasql/Decoders.hs b/library/Hasql/Decoders.hs index aa3d432..a031ef5 100644 --- a/library/Hasql/Decoders.hs +++ b/library/Hasql/Decoders.hs @@ -1,5 +1,6 @@ --- | --- A DSL for declaration of result decoders. +{-| +A DSL for declaration of result decoders. +-} module Hasql.Decoders ( -- * Result @@ -17,7 +18,10 @@ module Hasql.Decoders -- * Row Row, column, - nullableColumn, + -- * Nullability + NullableOrNot, + nonNullable, + nullable, -- * Value Value, bool, @@ -51,474 +55,10 @@ module Hasql.Decoders Array, dimension, element, - nullableElement, -- * Composite Composite, field, - nullableField, ) where -import Hasql.Private.Prelude hiding (maybe, bool) -import qualified Data.Vector as Vector -import qualified PostgreSQL.Binary.Decoding as A -import qualified PostgreSQL.Binary.Data as B -import qualified Hasql.Private.Decoders.Results as Results -import qualified Hasql.Private.Decoders.Result as Result -import qualified Hasql.Private.Decoders.Row as Row -import qualified Hasql.Private.Decoders.Value as Value -import qualified Hasql.Private.Decoders.Array as Array -import qualified Hasql.Private.Decoders.Composite as Composite -import qualified Hasql.Private.Prelude as Prelude - --- * Result -------------------------- - --- | --- Decoder of a query result. --- -newtype Result a = - Result (Results.Results a) - deriving (Functor) - --- | --- Decode no value from the result. --- --- Useful for statements like @INSERT@ or @CREATE@. --- -{-# INLINABLE unit #-} -unit :: Result () -unit = - Result (Results.single Result.unit) - --- | --- Get the amount of rows affected by such statements as --- @UPDATE@ or @DELETE@. --- -{-# INLINABLE rowsAffected #-} -rowsAffected :: Result Int64 -rowsAffected = - Result (Results.single Result.rowsAffected) - --- | --- Exactly one row. --- Will raise the 'Hasql.Errors.UnexpectedAmountOfRows' error if it's any other. --- -{-# INLINABLE singleRow #-} -singleRow :: Row a -> Result a -singleRow (Row row) = - Result (Results.single (Result.single row)) - --- ** Multi-row traversers -------------------------- - --- | --- Foldl multiple rows. --- -{-# INLINABLE foldlRows #-} -foldlRows :: (a -> b -> a) -> a -> Row b -> Result a -foldlRows step init (Row row) = - Result (Results.single (Result.foldl step init row)) - --- | --- Foldr multiple rows. --- -{-# INLINABLE foldrRows #-} -foldrRows :: (b -> a -> a) -> a -> Row b -> Result a -foldrRows step init (Row row) = - Result (Results.single (Result.foldr step init row)) - --- ** Specialized multi-row results -------------------------- - --- | --- Maybe one row or none. --- -{-# INLINABLE rowMaybe #-} -rowMaybe :: Row a -> Result (Maybe a) -rowMaybe (Row row) = - Result (Results.single (Result.maybe row)) - --- | --- Zero or more rows packed into the vector. --- --- It's recommended to prefer this function to 'rowList', --- since it performs notably better. --- -{-# INLINABLE rowVector #-} -rowVector :: Row a -> Result (Vector a) -rowVector (Row row) = - Result (Results.single (Result.vector row)) - --- | --- Zero or more rows packed into the list. --- -{-# INLINABLE rowList #-} -rowList :: Row a -> Result [a] -rowList = - foldrRows strictCons [] - - --- * Row -------------------------- - --- | --- Decoder of an individual row, --- which gets composed of column value decoders. --- --- E.g.: --- --- >x :: Row (Maybe Int64, Text, TimeOfDay) --- >x = --- > (,,) <$> nullableColumn int8 <*> column text <*> column time --- -newtype Row a = - Row (Row.Row a) - deriving (Functor, Applicative, Monad) - --- | --- Lift an individual non-nullable value decoder to a composable row decoder. --- -{-# INLINABLE column #-} -column :: Value a -> Row a -column (Value imp) = - Row (Row.nonNullValue imp) - --- | --- Lift an individual nullable value decoder to a composable row decoder. --- -{-# INLINABLE nullableColumn #-} -nullableColumn :: Value a -> Row (Maybe a) -nullableColumn (Value imp) = - Row (Row.value imp) - - --- * Value -------------------------- - --- | --- Decoder of an individual value. --- -newtype Value a = - Value (Value.Value a) - deriving (Functor) - - --- ** Plain value decoders -------------------------- - --- | --- Decoder of the @BOOL@ values. --- -{-# INLINABLE bool #-} -bool :: Value Bool -bool = - Value (Value.decoder (const A.bool)) - --- | --- Decoder of the @INT2@ values. --- -{-# INLINABLE int2 #-} -int2 :: Value Int16 -int2 = - Value (Value.decoder (const A.int)) - --- | --- Decoder of the @INT4@ values. --- -{-# INLINABLE int4 #-} -int4 :: Value Int32 -int4 = - Value (Value.decoder (const A.int)) - --- | --- Decoder of the @INT8@ values. --- -{-# INLINABLE int8 #-} -int8 :: Value Int64 -int8 = - {-# SCC "int8" #-} - Value (Value.decoder (const ({-# SCC "int8.int" #-} A.int))) - --- | --- Decoder of the @FLOAT4@ values. --- -{-# INLINABLE float4 #-} -float4 :: Value Float -float4 = - Value (Value.decoder (const A.float4)) - --- | --- Decoder of the @FLOAT8@ values. --- -{-# INLINABLE float8 #-} -float8 :: Value Double -float8 = - Value (Value.decoder (const A.float8)) - --- | --- Decoder of the @NUMERIC@ values. --- -{-# INLINABLE numeric #-} -numeric :: Value B.Scientific -numeric = - Value (Value.decoder (const A.numeric)) - --- | --- Decoder of the @CHAR@ values. --- Note that it supports UTF-8 values. -{-# INLINABLE char #-} -char :: Value Char -char = - Value (Value.decoder (const A.char)) - --- | --- Decoder of the @TEXT@ values. --- -{-# INLINABLE text #-} -text :: Value Text -text = - Value (Value.decoder (const A.text_strict)) - --- | --- Decoder of the @BYTEA@ values. --- -{-# INLINABLE bytea #-} -bytea :: Value ByteString -bytea = - Value (Value.decoder (const A.bytea_strict)) - --- | --- Decoder of the @DATE@ values. --- -{-# INLINABLE date #-} -date :: Value B.Day -date = - Value (Value.decoder (const A.date)) - --- | --- Decoder of the @TIMESTAMP@ values. --- -{-# INLINABLE timestamp #-} -timestamp :: Value B.LocalTime -timestamp = - Value (Value.decoder (Prelude.bool A.timestamp_float A.timestamp_int)) - --- | --- Decoder of the @TIMESTAMPTZ@ values. --- --- /NOTICE/ --- --- Postgres does not store the timezone information of @TIMESTAMPTZ@. --- Instead it stores a UTC value and performs silent conversions --- to the currently set timezone, when dealt with in the text format. --- However this library bypasses the silent conversions --- and communicates with Postgres using the UTC values directly. -{-# INLINABLE timestamptz #-} -timestamptz :: Value B.UTCTime -timestamptz = - Value (Value.decoder (Prelude.bool A.timestamptz_float A.timestamptz_int)) - --- | --- Decoder of the @TIME@ values. --- -{-# INLINABLE time #-} -time :: Value B.TimeOfDay -time = - Value (Value.decoder (Prelude.bool A.time_float A.time_int)) - --- | --- Decoder of the @TIMETZ@ values. --- --- Unlike in case of @TIMESTAMPTZ@, --- Postgres does store the timezone information for @TIMETZ@. --- However the Haskell's \"time\" library does not contain any composite type, --- that fits the task, so we use a pair of 'TimeOfDay' and 'TimeZone' --- to represent a value on the Haskell's side. -{-# INLINABLE timetz #-} -timetz :: Value (B.TimeOfDay, B.TimeZone) -timetz = - Value (Value.decoder (Prelude.bool A.timetz_float A.timetz_int)) - --- | --- Decoder of the @INTERVAL@ values. --- -{-# INLINABLE interval #-} -interval :: Value B.DiffTime -interval = - Value (Value.decoder (Prelude.bool A.interval_float A.interval_int)) - --- | --- Decoder of the @UUID@ values. --- -{-# INLINABLE uuid #-} -uuid :: Value B.UUID -uuid = - Value (Value.decoder (const A.uuid)) - --- | --- Decoder of the @INET@ values. --- -{-# INLINABLE inet #-} -inet :: Value (B.NetAddr B.IP) -inet = - Value (Value.decoder (const A.inet)) - --- | --- Decoder of the @JSON@ values into a JSON AST. --- -{-# INLINABLE json #-} -json :: Value B.Value -json = - Value (Value.decoder (const A.json_ast)) - --- | --- Decoder of the @JSON@ values into a raw JSON 'ByteString'. --- -{-# INLINABLE jsonBytes #-} -jsonBytes :: (ByteString -> Either Text a) -> Value a -jsonBytes fn = - Value (Value.decoder (const (A.json_bytes fn))) - --- | --- Decoder of the @JSONB@ values into a JSON AST. --- -{-# INLINABLE jsonb #-} -jsonb :: Value B.Value -jsonb = - Value (Value.decoder (const A.jsonb_ast)) - --- | --- Decoder of the @JSONB@ values into a raw JSON 'ByteString'. --- -{-# INLINABLE jsonbBytes #-} -jsonbBytes :: (ByteString -> Either Text a) -> Value a -jsonbBytes fn = - Value (Value.decoder (const (A.jsonb_bytes fn))) - --- | --- Lifts a custom value decoder function to a 'Value' decoder. --- -{-# INLINABLE custom #-} -custom :: (Bool -> ByteString -> Either Text a) -> Value a -custom fn = - Value (Value.decoderFn fn) - - --- ** Composite value decoders -------------------------- - --- | --- Lifts the 'Array' decoder to the 'Value' decoder. --- -{-# INLINABLE array #-} -array :: Array a -> Value a -array (Array imp) = - Value (Value.decoder (Array.run imp)) - --- | --- Lifts the 'Composite' decoder to the 'Value' decoder. --- -{-# INLINABLE composite #-} -composite :: Composite a -> Value a -composite (Composite imp) = - Value (Value.decoder (Composite.run imp)) - --- | --- A generic decoder of @HSTORE@ values. --- --- Here's how you can use it to construct a specific value: --- --- @ --- x :: Value [(Text, Maybe Text)] --- x = --- hstore 'replicateM' --- @ --- -{-# INLINABLE hstore #-} -hstore :: (forall m. Monad m => Int -> m (Text, Maybe Text) -> m a) -> Value a -hstore replicateM = - Value (Value.decoder (const (A.hstore replicateM A.text_strict A.text_strict))) - --- | --- Given a partial mapping from text to value, --- produces a decoder of that value. -enum :: (Text -> Maybe a) -> Value a -enum mapping = - Value (Value.decoder (const (A.enum mapping))) - - --- * Array decoders -------------------------- - --- | --- A generic array decoder. --- --- Here's how you can use it to produce a specific array value decoder: --- --- @ --- x :: Value [[Text]] --- x = --- array (dimension 'replicateM' (dimension 'replicateM' (element text))) --- @ --- -newtype Array a = - Array (Array.Array a) - deriving (Functor) - --- | --- 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 'dimension', --- 'element' or 'nullableElement'. --- -{-# INLINABLE dimension #-} -dimension :: (forall m. Monad m => Int -> m a -> m b) -> Array a -> Array b -dimension replicateM (Array imp) = - Array (Array.dimension replicateM imp) - --- | --- Lift a 'Value' decoder into an 'Array' decoder for parsing of non-nullable leaf values. -{-# INLINABLE element #-} -element :: Value a -> Array a -element (Value imp) = - Array (Array.nonNullValue (Value.run imp)) - --- | --- Lift a 'Value' decoder into an 'Array' decoder for parsing of nullable leaf values. -{-# INLINABLE nullableElement #-} -nullableElement :: Value a -> Array (Maybe a) -nullableElement (Value imp) = - Array (Array.value (Value.run imp)) - - --- * Composite decoders -------------------------- - --- | --- Composable decoder of composite values (rows, records). -newtype Composite a = - Composite (Composite.Composite a) - deriving (Functor, Applicative, Monad) - --- | --- Lift a 'Value' decoder into a 'Composite' decoder for parsing of non-nullable leaf values. -{-# INLINABLE field #-} -field :: Value a -> Composite a -field (Value imp) = - Composite (Composite.nonNullValue (Value.run imp)) - --- | --- Lift a 'Value' decoder into a 'Composite' decoder for parsing of nullable leaf values. -{-# INLINABLE nullableField #-} -nullableField :: Value a -> Composite (Maybe a) -nullableField (Value imp) = - Composite (Composite.value (Value.run imp)) - +import Hasql.Private.Decoders diff --git a/library/Hasql/Private/Decoders.hs b/library/Hasql/Private/Decoders.hs new file mode 100644 index 0000000..69fe26a --- /dev/null +++ b/library/Hasql/Private/Decoders.hs @@ -0,0 +1,428 @@ +{-| +A DSL for declaration of result decoders. +-} +module Hasql.Private.Decoders +where + +import Hasql.Private.Prelude hiding (maybe, bool) +import qualified Data.Vector as Vector +import qualified PostgreSQL.Binary.Decoding as A +import qualified PostgreSQL.Binary.Data as B +import qualified Hasql.Private.Decoders.Results as Results +import qualified Hasql.Private.Decoders.Result as Result +import qualified Hasql.Private.Decoders.Row as Row +import qualified Hasql.Private.Decoders.Value as Value +import qualified Hasql.Private.Decoders.Array as Array +import qualified Hasql.Private.Decoders.Composite as Composite +import qualified Hasql.Private.Prelude as Prelude + +-- * Result +------------------------- + +{-| +Decoder of a query result. +-} +newtype Result a = Result (Results.Results a) deriving (Functor) + +{-| +Decode no value from the result. + +Useful for statements like @INSERT@ or @CREATE@. +-} +{-# INLINABLE unit #-} +unit :: Result () +unit = Result (Results.single Result.unit) + +{-| +Get the amount of rows affected by such statements as +@UPDATE@ or @DELETE@. +-} +{-# INLINABLE rowsAffected #-} +rowsAffected :: Result Int64 +rowsAffected = Result (Results.single Result.rowsAffected) + +{-| +Exactly one row. +Will raise the 'Hasql.Errors.UnexpectedAmountOfRows' error if it's any other. +-} +{-# INLINABLE singleRow #-} +singleRow :: Row a -> Result a +singleRow (Row row) = Result (Results.single (Result.single row)) + +-- ** Multi-row traversers +------------------------- + +{-| +Foldl multiple rows. +-} +{-# INLINABLE foldlRows #-} +foldlRows :: (a -> b -> a) -> a -> Row b -> Result a +foldlRows step init (Row row) = Result (Results.single (Result.foldl step init row)) + +{-| +Foldr multiple rows. +-} +{-# INLINABLE foldrRows #-} +foldrRows :: (b -> a -> a) -> a -> Row b -> Result a +foldrRows step init (Row row) = Result (Results.single (Result.foldr step init row)) + +-- ** Specialized multi-row results +------------------------- + +{-| +Maybe one row or none. +-} +{-# INLINABLE rowMaybe #-} +rowMaybe :: Row a -> Result (Maybe a) +rowMaybe (Row row) = Result (Results.single (Result.maybe row)) + +{-| +Zero or more rows packed into the vector. + +It's recommended to prefer this function to 'rowList', +since it performs notably better. +-} +{-# INLINABLE rowVector #-} +rowVector :: Row a -> Result (Vector a) +rowVector (Row row) = Result (Results.single (Result.vector row)) + +{-| +Zero or more rows packed into the list. +-} +{-# INLINABLE rowList #-} +rowList :: Row a -> Result [a] +rowList = foldrRows strictCons [] + + +-- * Row +------------------------- + +{-| +Decoder of an individual row, +which gets composed of column value decoders. + +E.g.: + +>x :: Row (Maybe Int64, Text, TimeOfDay) +>x = +> (,,) <$> nullableColumn int8 <*> column text <*> column time +-} +newtype Row a = + Row (Row.Row a) + deriving (Functor, Applicative, Monad) + +{-| +Lift an individual non-nullable value decoder to a composable row decoder. +-} +{-# INLINABLE column #-} +column :: NullableOrNot Value a -> Row a +column = \ case + NonNullable (Value imp) -> Row (Row.nonNullValue imp) + Nullable (Value imp) -> Row (Row.value imp) + + +-- * Nullability +------------------------- + +{-| +Extensional specification of nullability over a generic decoder. +-} +data NullableOrNot decoder a where + NonNullable :: decoder a -> NullableOrNot decoder a + Nullable :: decoder a -> NullableOrNot decoder (Maybe a) + +{-| +Specify that a decoder produces a non-nullable value. +-} +nonNullable :: decoder a -> NullableOrNot decoder a +nonNullable = NonNullable + +{-| +Specify that a decoder produces a nullable value. +-} +nullable :: decoder a -> NullableOrNot decoder (Maybe a) +nullable = Nullable + + +-- * Value +------------------------- + +{-| +Decoder of a value. +-} +newtype Value a = Value (Value.Value a) + deriving (Functor) + +{-| +Decoder of the @BOOL@ values. +-} +{-# INLINABLE bool #-} +bool :: Value Bool +bool = Value (Value.decoder (const A.bool)) + +{-| +Decoder of the @INT2@ values. +-} +{-# INLINABLE int2 #-} +int2 :: Value Int16 +int2 = Value (Value.decoder (const A.int)) + +{-| +Decoder of the @INT4@ values. +-} +{-# INLINABLE int4 #-} +int4 :: Value Int32 +int4 = Value (Value.decoder (const A.int)) + +{-| +Decoder of the @INT8@ values. +-} +{-# INLINABLE int8 #-} +int8 :: Value Int64 +int8 = {-# SCC "int8" #-} + Value (Value.decoder (const ({-# SCC "int8.int" #-} A.int))) + +{-| +Decoder of the @FLOAT4@ values. +-} +{-# INLINABLE float4 #-} +float4 :: Value Float +float4 = Value (Value.decoder (const A.float4)) + +{-| +Decoder of the @FLOAT8@ values. +-} +{-# INLINABLE float8 #-} +float8 :: Value Double +float8 = Value (Value.decoder (const A.float8)) + +{-| +Decoder of the @NUMERIC@ values. +-} +{-# INLINABLE numeric #-} +numeric :: Value B.Scientific +numeric = Value (Value.decoder (const A.numeric)) + +{-| +Decoder of the @CHAR@ values. +Note that it supports UTF-8 values. +-} +{-# INLINABLE char #-} +char :: Value Char +char = Value (Value.decoder (const A.char)) + +{-| +Decoder of the @TEXT@ values. +-} +{-# INLINABLE text #-} +text :: Value Text +text = Value (Value.decoder (const A.text_strict)) + +{-| +Decoder of the @BYTEA@ values. +-} +{-# INLINABLE bytea #-} +bytea :: Value ByteString +bytea = Value (Value.decoder (const A.bytea_strict)) + +{-| +Decoder of the @DATE@ values. +-} +{-# INLINABLE date #-} +date :: Value B.Day +date = Value (Value.decoder (const A.date)) + +{-| +Decoder of the @TIMESTAMP@ values. +-} +{-# INLINABLE timestamp #-} +timestamp :: Value B.LocalTime +timestamp = Value (Value.decoder (Prelude.bool A.timestamp_float A.timestamp_int)) + +{-| +Decoder of the @TIMESTAMPTZ@ values. + +/NOTICE/ + +Postgres does not store the timezone information of @TIMESTAMPTZ@. +Instead it stores a UTC value and performs silent conversions +to the currently set timezone, when dealt with in the text format. +However this library bypasses the silent conversions +and communicates with Postgres using the UTC values directly. +-} +{-# INLINABLE timestamptz #-} +timestamptz :: Value B.UTCTime +timestamptz = Value (Value.decoder (Prelude.bool A.timestamptz_float A.timestamptz_int)) + +{-| +Decoder of the @TIME@ values. +-} +{-# INLINABLE time #-} +time :: Value B.TimeOfDay +time = Value (Value.decoder (Prelude.bool A.time_float A.time_int)) + +{-| +Decoder of the @TIMETZ@ values. + +Unlike in case of @TIMESTAMPTZ@, +Postgres does store the timezone information for @TIMETZ@. +However the Haskell's \"time\" library does not contain any composite type, +that fits the task, so we use a pair of 'TimeOfDay' and 'TimeZone' +to represent a value on the Haskell's side. +-} +{-# INLINABLE timetz #-} +timetz :: Value (B.TimeOfDay, B.TimeZone) +timetz = Value (Value.decoder (Prelude.bool A.timetz_float A.timetz_int)) + +{-| +Decoder of the @INTERVAL@ values. +-} +{-# INLINABLE interval #-} +interval :: Value B.DiffTime +interval = Value (Value.decoder (Prelude.bool A.interval_float A.interval_int)) + +{-| +Decoder of the @UUID@ values. +-} +{-# INLINABLE uuid #-} +uuid :: Value B.UUID +uuid = Value (Value.decoder (const A.uuid)) + +{-| +Decoder of the @INET@ values. +-} +{-# INLINABLE inet #-} +inet :: Value (B.NetAddr B.IP) +inet = Value (Value.decoder (const A.inet)) + +{-| +Decoder of the @JSON@ values into a JSON AST. +-} +{-# INLINABLE json #-} +json :: Value B.Value +json = Value (Value.decoder (const A.json_ast)) + +{-| +Decoder of the @JSON@ values into a raw JSON 'ByteString'. +-} +{-# INLINABLE jsonBytes #-} +jsonBytes :: (ByteString -> Either Text a) -> Value a +jsonBytes fn = Value (Value.decoder (const (A.json_bytes fn))) + +{-| +Decoder of the @JSONB@ values into a JSON AST. +-} +{-# INLINABLE jsonb #-} +jsonb :: Value B.Value +jsonb = Value (Value.decoder (const A.jsonb_ast)) + +{-| +Decoder of the @JSONB@ values into a raw JSON 'ByteString'. +-} +{-# INLINABLE jsonbBytes #-} +jsonbBytes :: (ByteString -> Either Text a) -> Value a +jsonbBytes fn = Value (Value.decoder (const (A.jsonb_bytes fn))) + +{-| +Lifts a custom value decoder function to a 'Value' decoder. +-} +{-# INLINABLE custom #-} +custom :: (Bool -> ByteString -> Either Text a) -> Value a +custom fn = Value (Value.decoderFn fn) + +{-| +A generic decoder of @HSTORE@ values. + +Here's how you can use it to construct a specific value: + +@ +x :: Value [(Text, Maybe Text)] +x = hstore 'replicateM' +@ +-} +{-# INLINABLE hstore #-} +hstore :: (forall m. Monad m => Int -> m (Text, Maybe Text) -> m a) -> Value a +hstore replicateM = Value (Value.decoder (const (A.hstore replicateM A.text_strict A.text_strict))) + +{-| +Given a partial mapping from text to value, +produces a decoder of that value. +-} +enum :: (Text -> Maybe a) -> Value a +enum mapping = Value (Value.decoder (const (A.enum mapping))) + +{-| +Lifts the 'Array' decoder to a 'Value' decoder. +-} +{-# INLINABLE array #-} +array :: Array a -> Value a +array (Array imp) = Value (Value.decoder (Array.run imp)) + +{-| +Lifts the 'Composite' decoder to a 'Value' decoder. +-} +{-# INLINABLE composite #-} +composite :: Composite a -> Value a +composite (Composite imp) = Value (Value.decoder (Composite.run imp)) + + +-- * Array decoders +------------------------- + +{-| +A generic array decoder. + +Here's how you can use it to produce a specific array value decoder: + +@ +x :: Value [[Text]] +x = + array (dimension 'replicateM' (dimension 'replicateM' (element text))) +@ +-} +newtype Array a = Array (Array.Array a) + deriving (Functor) + +{-| +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 'dimension', +'element' or 'nullableElement'. +-} +{-# INLINABLE dimension #-} +dimension :: (forall m. Monad m => Int -> m a -> m b) -> Array a -> Array b +dimension replicateM (Array imp) = Array (Array.dimension replicateM imp) + +{-| +Lift a 'Value' decoder into an 'Array' decoder for parsing of leaf values. +-} +{-# INLINABLE element #-} +element :: NullableOrNot Value a -> Array a +element = \ case + NonNullable (Value imp) -> Array (Array.nonNullValue (Value.run imp)) + Nullable (Value imp) -> Array (Array.value (Value.run imp)) + + +-- * Composite decoders +------------------------- + +{-| +Composable decoder of composite values (rows, records). +-} +newtype Composite a = Composite (Composite.Composite a) + deriving (Functor, Applicative, Monad) + +{-| +Lift a 'Value' decoder into a 'Composite' decoder for parsing of non-nullable leaf values. +-} +field :: NullableOrNot Value a -> Composite a +field = \ case + NonNullable (Value imp) -> Composite (Composite.nonNullValue (Value.run imp)) + Nullable (Value imp) -> Composite (Composite.value (Value.run imp)) diff --git a/profiling/Main.hs b/profiling/Main.hs index acb8c70..55bbf34 100644 --- a/profiling/Main.hs +++ b/profiling/Main.hs @@ -70,7 +70,7 @@ statementWithSingleRow = D.singleRow row where row = - tuple <$> D.column D.int8 <*> D.column D.int8 + tuple <$> (D.column . D.nonNullable) D.int8 <*> (D.column . D.nonNullable) D.int8 where tuple !a !b = (a, b) @@ -84,7 +84,7 @@ statementWithManyRows decoder = encoder = conquer rowDecoder = - tuple <$> D.column D.int8 <*> D.column D.int8 + tuple <$> (D.column . D.nonNullable) D.int8 <*> (D.column . D.nonNullable) D.int8 where tuple !a !b = (a, b) diff --git a/tasty/Main.hs b/tasty/Main.hs index 9847dd3..9cdb7ed 100644 --- a/tasty/Main.hs +++ b/tasty/Main.hs @@ -32,7 +32,7 @@ tree = (Encoders.param (Encoders.nonNullable (Encoders.array (Encoders.dimension foldl' (Encoders.element (Encoders.nonNullable Encoders.int8)))))) (Encoders.param (Encoders.nonNullable (Encoders.primitive Encoders.text))) decoder = - fmap (maybe False (const True)) (Decoders.rowMaybe (Decoders.column Decoders.bool)) + fmap (maybe False (const True)) (Decoders.rowMaybe ((Decoders.column . Decoders.nonNullable) Decoders.bool)) session = Session.statement ([3, 7], "a") statement in do @@ -49,7 +49,7 @@ tree = encoder = Encoders.param (Encoders.nonNullable (Encoders.array (Encoders.dimension foldl' (Encoders.element (Encoders.nonNullable Encoders.int8))))) decoder = - fmap (maybe False (const True)) (Decoders.rowMaybe (Decoders.column Decoders.bool)) + fmap (maybe False (const True)) (Decoders.rowMaybe ((Decoders.column . Decoders.nonNullable) Decoders.bool)) session = do result1 <- Session.statement [1, 2] statement @@ -67,7 +67,7 @@ tree = encoder = Encoders.param (Encoders.nonNullable (Encoders.array (Encoders.dimension foldl' (Encoders.element (Encoders.nonNullable Encoders.int8))))) decoder = - fmap (maybe False (const True)) (Decoders.rowMaybe (Decoders.column Decoders.bool)) + fmap (maybe False (const True)) (Decoders.rowMaybe ((Decoders.column . Decoders.nonNullable) Decoders.bool)) session = do result1 <- Session.statement [1, 2] statement @@ -87,7 +87,7 @@ tree = encoder = mempty decoder = - Decoders.singleRow (Decoders.column (Decoders.composite ((,) <$> Decoders.field Decoders.int8 <*> Decoders.field Decoders.bool))) + Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.composite ((,) <$> (Decoders.field . Decoders.nonNullable) Decoders.int8 <*> (Decoders.field . Decoders.nonNullable) Decoders.bool))) session = Session.statement () statement in do @@ -105,14 +105,14 @@ tree = mempty decoder = Decoders.singleRow $ - (,) <$> Decoders.column entity1 <*> Decoders.column entity2 + (,) <$> (Decoders.column . Decoders.nonNullable) entity1 <*> (Decoders.column . Decoders.nonNullable) entity2 where entity1 = Decoders.composite $ - (,) <$> Decoders.field Decoders.int8 <*> Decoders.field Decoders.bool + (,) <$> (Decoders.field . Decoders.nonNullable) Decoders.int8 <*> (Decoders.field . Decoders.nonNullable) Decoders.bool entity2 = Decoders.composite $ - (,) <$> Decoders.field Decoders.text <*> Decoders.field Decoders.int8 + (,) <$> (Decoders.field . Decoders.nonNullable) Decoders.text <*> (Decoders.field . Decoders.nonNullable) Decoders.int8 session = Session.statement () statement in do @@ -137,7 +137,7 @@ tree = encoder = mempty decoder = - Decoders.singleRow (Decoders.column (Decoders.array (Decoders.dimension replicateM (Decoders.element Decoders.int8)))) + Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.array (Decoders.dimension replicateM (Decoders.element (Decoders.nonNullable Decoders.int8))))) in io , testCase "Failing prepared statements" $ @@ -187,7 +187,7 @@ tree = encoder = Encoders.param (Encoders.nonNullable (Encoders.primitive Encoders.int8)) decoder = - Decoders.singleRow $ Decoders.column Decoders.int8 + Decoders.singleRow $ (Decoders.column . Decoders.nonNullable) Decoders.int8 fail = catchError (Session.sql "absurd") (const (pure ())) in io @@ -204,7 +204,7 @@ tree = contramap fst (Encoders.param (Encoders.nonNullable (Encoders.primitive Encoders.int8))) <> contramap snd (Encoders.param (Encoders.nonNullable (Encoders.primitive Encoders.int8))) decoder = - Decoders.singleRow (Decoders.column Decoders.int8) + Decoders.singleRow ((Decoders.column . Decoders.nonNullable) Decoders.int8) sumSession :: Session.Session Int64 sumSession = Session.sql "begin" *> Session.statement (1, 1) sumStatement <* Session.sql "end" @@ -229,7 +229,7 @@ tree = contramap fst (Encoders.param (Encoders.nonNullable (Encoders.primitive Encoders.int8))) <> contramap snd (Encoders.param (Encoders.nonNullable (Encoders.primitive Encoders.int8))) decoder = - Decoders.singleRow (Decoders.column Decoders.int8) + Decoders.singleRow ((Decoders.column . Decoders.nonNullable) Decoders.int8) session :: Session.Session Int64 session = do @@ -253,7 +253,7 @@ tree = sql = "select $1 = interval '10 seconds'" decoder = - (Decoders.singleRow (Decoders.column (Decoders.bool))) + (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.bool))) encoder = Encoders.param (Encoders.nonNullable (Encoders.primitive Encoders.interval)) in DSL.statement (10 :: DiffTime) statement @@ -270,7 +270,7 @@ tree = sql = "select interval '10 seconds'" decoder = - (Decoders.singleRow (Decoders.column (Decoders.interval))) + (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.interval))) encoder = Encoders.noParams in DSL.statement () statement @@ -287,7 +287,7 @@ tree = sql = "select $1" decoder = - (Decoders.singleRow (Decoders.column (Decoders.interval))) + (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.interval))) encoder = Encoders.param (Encoders.nonNullable (Encoders.primitive Encoders.interval)) in DSL.statement (10 :: DiffTime) statement @@ -318,7 +318,7 @@ tree = sql = "select $1 = ('ok' :: mood)" decoder = - (Decoders.singleRow (Decoders.column (Decoders.bool))) + (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.bool))) encoder = Encoders.param (Encoders.nonNullable (Encoders.primitive Encoders.unknown)) in DSL.statement "ok" statement @@ -349,7 +349,7 @@ tree = sql = "select overloaded($1, $2) || overloaded($3, $4, $5)" decoder = - (Decoders.singleRow (Decoders.column (Decoders.text))) + (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.text))) encoder = contramany (Encoders.param (Encoders.nonNullable (Encoders.primitive Encoders.unknown))) in DSL.statement ["1", "2", "4", "5", "6"] statement @@ -380,7 +380,7 @@ tree = sql = "select ($1 :: mood)" decoder = - (Decoders.singleRow (Decoders.column (Decoders.enum (Just . id)))) + (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.enum (Just . id)))) encoder = Encoders.param (Encoders.nonNullable (Encoders.primitive (Encoders.enum id))) in DSL.statement "ok" statement @@ -402,7 +402,7 @@ tree = encoder = Encoders.param (Encoders.nonNullable (Encoders.primitive Encoders.text)) decoder = - (Decoders.singleRow (Decoders.column (Decoders.text))) + (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.text))) effect2 = DSL.statement 1 statement where @@ -414,7 +414,7 @@ tree = encoder = Encoders.param (Encoders.nonNullable (Encoders.primitive Encoders.int8)) decoder = - (Decoders.singleRow (Decoders.column Decoders.int8)) + (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) Decoders.int8)) in (,) <$> effect1 <*> effect2 in actualIO >>= assertEqual "" (Right ("ok", 1)) , @@ -452,8 +452,8 @@ tree = DSL.session $ do DSL.statement () $ Statements.plain $ "drop table if exists a" DSL.statement () $ Statements.plain $ "create table a (id serial not null, v char not null, primary key (id))" - id1 <- DSL.statement () $ Statement.Statement "insert into a (v) values ('a') returning id" mempty (Decoders.singleRow (Decoders.column Decoders.int4)) False - id2 <- DSL.statement () $ Statement.Statement "insert into a (v) values ('b') returning id" mempty (Decoders.singleRow (Decoders.column Decoders.int4)) False + id1 <- DSL.statement () $ Statement.Statement "insert into a (v) values ('a') returning id" mempty (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) Decoders.int4)) False + id2 <- DSL.statement () $ Statement.Statement "insert into a (v) values ('b') returning id" mempty (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) Decoders.int4)) False DSL.statement () $ Statements.plain $ "drop table if exists a" pure (id1, id2) in assertEqual "" (Right (1, 2)) =<< actualIO diff --git a/tasty/Main/Statements.hs b/tasty/Main/Statements.hs index f31f6ac..f67a4e3 100644 --- a/tasty/Main/Statements.hs +++ b/tasty/Main/Statements.hs @@ -29,4 +29,4 @@ selectList = sql = "values (1,2), (3,4), (5,6)" decoder = - HD.rowList ((,) <$> HD.column HD.int8 <*> HD.column HD.int8) + HD.rowList ((,) <$> (HD.column . HD.nonNullable) HD.int8 <*> (HD.column . HD.nonNullable) HD.int8) From 51e0568b753785c708c3a5e40ec98df7e97cef3a Mon Sep 17 00:00:00 2001 From: Nikita Volkov Date: Tue, 21 May 2019 01:34:04 +0300 Subject: [PATCH 04/17] Add array roundtrip tests --- tasty/Main.hs | 20 ++++++++++++++++++++ 1 file changed, 20 insertions(+) diff --git a/tasty/Main.hs b/tasty/Main.hs index 9cdb7ed..2445284 100644 --- a/tasty/Main.hs +++ b/tasty/Main.hs @@ -22,6 +22,26 @@ tree = localOption (NumThreads 1) $ testGroup "All tests" [ + testGroup "Roundtrips" $ let + roundtrip encoder decoder input = let + session = let + statement = Statement.Statement "select $1" encoder decoder True + in Session.statement input statement + in unsafePerformIO $ do + x <- Connection.with (Session.run session) + return (Right (Right input) === x) + in [ + testProperty "Array" $ let + encoder = Encoders.param (Encoders.nonNullable (Encoders.array (Encoders.dimension foldl' (Encoders.element (Encoders.nonNullable Encoders.int8))))) + decoder = Decoders.singleRow (Decoders.column (Decoders.nonNullable (Decoders.array (Decoders.dimension replicateM (Decoders.element (Decoders.nonNullable Decoders.int8)))))) + in roundtrip encoder decoder + , + testProperty "2D Array" $ let + encoder = Encoders.param (Encoders.nonNullable (Encoders.array (Encoders.dimension foldl' (Encoders.dimension foldl' (Encoders.element (Encoders.nonNullable Encoders.int8)))))) + decoder = Decoders.singleRow (Decoders.column (Decoders.nonNullable (Decoders.array (Decoders.dimension replicateM (Decoders.dimension replicateM (Decoders.element (Decoders.nonNullable Decoders.int8))))))) + in \ list -> list /= [] ==> roundtrip encoder decoder (replicate 3 list) + ] + , testCase "Failed query" $ let statement = From 5b258ae53a4224533a89eea47f50931dd91e8bf3 Mon Sep 17 00:00:00 2001 From: Nikita Volkov Date: Tue, 21 May 2019 12:59:50 +0300 Subject: [PATCH 05/17] Ditch Primitive from encoders That's for consistency with decoders, and decoders can't have this separation without introducing too much complexity. That's so because of there existing a support for composite types, which may consist of arrays and arrays may consist of composites. --- library/Hasql/Encoders.hs | 7 +- library/Hasql/Private/Encoders.hs | 146 +++++++++++++----------------- tasty/Main.hs | 26 +++--- threads-test/Main/Statements.hs | 2 +- 4 files changed, 81 insertions(+), 100 deletions(-) diff --git a/library/Hasql/Encoders.hs b/library/Hasql/Encoders.hs index d2a9303..02e9f1c 100644 --- a/library/Hasql/Encoders.hs +++ b/library/Hasql/Encoders.hs @@ -14,12 +14,9 @@ module Hasql.Encoders NullableOrNot, nonNullable, nullable, - -- * Param - Param, - primitive, + -- * Value + Value, array, - -- * Primitive - Primitive, bool, int2, int4, diff --git a/library/Hasql/Private/Encoders.hs b/library/Hasql/Private/Encoders.hs index 7525065..93cc55e 100644 --- a/library/Hasql/Private/Encoders.hs +++ b/library/Hasql/Private/Encoders.hs @@ -53,11 +53,11 @@ data Gender = Male | Female personParams :: 'Params' Person personParams = (name '>$<' 'param' ('nonNullable' ('primitive' 'text'))) '<>' - (gender '>$<' 'param' ('nonNullable' ('primitive' genderPrimitive))) '<>' + (gender '>$<' 'param' ('nonNullable' ('primitive' genderValue))) '<>' ('fromIntegral' . age '>$<' 'param' ('nonNullable' ('primitive' 'int8'))) -genderPrimitive :: 'Primitive' Gender -genderPrimitive = 'enum' genderText 'text' where +genderValue :: 'Value' Gender +genderValue = 'enum' genderText 'text' where genderText gender = case gender of Male -> "male" Female -> "female" @@ -73,12 +73,13 @@ noParams :: Params () noParams = mempty {-| -Lift a single parameter, with its nullability specified. +Lift a single parameter encoder, with its nullability specified, +associating it with a single placeholder. -} -param :: NullableOrNot Param a -> Params a +param :: NullableOrNot Value a -> Params a param = \ case - NonNullable (Param valueEnc) -> Params (Params.value valueEnc) - Nullable (Param valueEnc) -> Params (Params.nullableValue valueEnc) + NonNullable (Value valueEnc) -> Params (Params.value valueEnc) + Nullable (Value valueEnc) -> Params (Params.nullableValue valueEnc) -- * Nullability @@ -104,88 +105,71 @@ nullable :: encoder a -> NullableOrNot encoder (Maybe a) nullable = Nullable --- * Param +-- * Value ------------------------- {-| -An individual parameter encoder. -Will be mapped to a single placeholder in the statement. +Value encoder. -} -newtype Param a = Param (Value.Value a) +newtype Value a = Value (Value.Value a) deriving (Contravariant) -{-| -Lift a primitive value encoder into a parameter encoder. --} -primitive :: Primitive a -> Param a -primitive (Primitive valueEnc) = Param valueEnc - {-| Lift an array encoder into a parameter encoder. -} -array :: Array a -> Param a +array :: Array a -> Value a array (Array (Array.Array valueOID arrayOID arrayEncoder renderer)) = let encoder env input = A.array (PTI.oidWord32 valueOID) (arrayEncoder env input) - in Param (Value.Value arrayOID arrayOID encoder renderer) - - --- * Primitive -------------------------- - -{-| -Primitive value encoder. --} -newtype Primitive a = Primitive (Value.Value a) - deriving (Contravariant) + in Value (Value.Value arrayOID arrayOID encoder renderer) {-| Encoder of @BOOL@ values. -} {-# INLINABLE bool #-} -bool :: Primitive Bool -bool = Primitive (Value.unsafePTIWithShow PTI.bool (const A.bool)) +bool :: Value Bool +bool = Value (Value.unsafePTIWithShow PTI.bool (const A.bool)) {-| Encoder of @INT2@ values. -} {-# INLINABLE int2 #-} -int2 :: Primitive Int16 -int2 = Primitive (Value.unsafePTIWithShow PTI.int2 (const A.int2_int16)) +int2 :: Value Int16 +int2 = Value (Value.unsafePTIWithShow PTI.int2 (const A.int2_int16)) {-| Encoder of @INT4@ values. -} {-# INLINABLE int4 #-} -int4 :: Primitive Int32 -int4 = Primitive (Value.unsafePTIWithShow PTI.int4 (const A.int4_int32)) +int4 :: Value Int32 +int4 = Value (Value.unsafePTIWithShow PTI.int4 (const A.int4_int32)) {-| Encoder of @INT8@ values. -} {-# INLINABLE int8 #-} -int8 :: Primitive Int64 -int8 = Primitive (Value.unsafePTIWithShow PTI.int8 (const A.int8_int64)) +int8 :: Value Int64 +int8 = Value (Value.unsafePTIWithShow PTI.int8 (const A.int8_int64)) {-| Encoder of @FLOAT4@ values. -} {-# INLINABLE float4 #-} -float4 :: Primitive Float -float4 = Primitive (Value.unsafePTIWithShow PTI.float4 (const A.float4)) +float4 :: Value Float +float4 = Value (Value.unsafePTIWithShow PTI.float4 (const A.float4)) {-| Encoder of @FLOAT8@ values. -} {-# INLINABLE float8 #-} -float8 :: Primitive Double -float8 = Primitive (Value.unsafePTIWithShow PTI.float8 (const A.float8)) +float8 :: Value Double +float8 = Value (Value.unsafePTIWithShow PTI.float8 (const A.float8)) {-| Encoder of @NUMERIC@ values. -} {-# INLINABLE numeric #-} -numeric :: Primitive B.Scientific -numeric = Primitive (Value.unsafePTIWithShow PTI.numeric (const A.numeric)) +numeric :: Value B.Scientific +numeric = Value (Value.unsafePTIWithShow PTI.numeric (const A.numeric)) {-| Encoder of @CHAR@ values. @@ -193,106 +177,106 @@ Encoder of @CHAR@ values. -- Note that it supports UTF-8 values and -- identifies itself under the @TEXT@ OID because of that. {-# INLINABLE char #-} -char :: Primitive Char -char = Primitive (Value.unsafePTIWithShow PTI.text (const A.char_utf8)) +char :: Value Char +char = Value (Value.unsafePTIWithShow PTI.text (const A.char_utf8)) {-| Encoder of @TEXT@ values. -} {-# INLINABLE text #-} -text :: Primitive Text -text = Primitive (Value.unsafePTIWithShow PTI.text (const A.text_strict)) +text :: Value Text +text = Value (Value.unsafePTIWithShow PTI.text (const A.text_strict)) {-| Encoder of @BYTEA@ values. -} {-# INLINABLE bytea #-} -bytea :: Primitive ByteString -bytea = Primitive (Value.unsafePTIWithShow PTI.bytea (const A.bytea_strict)) +bytea :: Value ByteString +bytea = Value (Value.unsafePTIWithShow PTI.bytea (const A.bytea_strict)) {-| Encoder of @DATE@ values. -} {-# INLINABLE date #-} -date :: Primitive B.Day -date = Primitive (Value.unsafePTIWithShow PTI.date (const A.date)) +date :: Value B.Day +date = Value (Value.unsafePTIWithShow PTI.date (const A.date)) {-| Encoder of @TIMESTAMP@ values. -} {-# INLINABLE timestamp #-} -timestamp :: Primitive B.LocalTime -timestamp = Primitive (Value.unsafePTIWithShow PTI.timestamp (Prelude.bool A.timestamp_float A.timestamp_int)) +timestamp :: Value B.LocalTime +timestamp = Value (Value.unsafePTIWithShow PTI.timestamp (Prelude.bool A.timestamp_float A.timestamp_int)) {-| Encoder of @TIMESTAMPTZ@ values. -} {-# INLINABLE timestamptz #-} -timestamptz :: Primitive B.UTCTime -timestamptz = Primitive (Value.unsafePTIWithShow PTI.timestamptz (Prelude.bool A.timestamptz_float A.timestamptz_int)) +timestamptz :: Value B.UTCTime +timestamptz = Value (Value.unsafePTIWithShow PTI.timestamptz (Prelude.bool A.timestamptz_float A.timestamptz_int)) {-| Encoder of @TIME@ values. -} {-# INLINABLE time #-} -time :: Primitive B.TimeOfDay -time = Primitive (Value.unsafePTIWithShow PTI.time (Prelude.bool A.time_float A.time_int)) +time :: Value B.TimeOfDay +time = Value (Value.unsafePTIWithShow PTI.time (Prelude.bool A.time_float A.time_int)) {-| Encoder of @TIMETZ@ values. -} {-# INLINABLE timetz #-} -timetz :: Primitive (B.TimeOfDay, B.TimeZone) -timetz = Primitive (Value.unsafePTIWithShow PTI.timetz (Prelude.bool A.timetz_float A.timetz_int)) +timetz :: Value (B.TimeOfDay, B.TimeZone) +timetz = Value (Value.unsafePTIWithShow PTI.timetz (Prelude.bool A.timetz_float A.timetz_int)) {-| Encoder of @INTERVAL@ values. -} {-# INLINABLE interval #-} -interval :: Primitive B.DiffTime -interval = Primitive (Value.unsafePTIWithShow PTI.interval (Prelude.bool A.interval_float A.interval_int)) +interval :: Value B.DiffTime +interval = Value (Value.unsafePTIWithShow PTI.interval (Prelude.bool A.interval_float A.interval_int)) {-| Encoder of @UUID@ values. -} {-# INLINABLE uuid #-} -uuid :: Primitive B.UUID -uuid = Primitive (Value.unsafePTIWithShow PTI.uuid (const A.uuid)) +uuid :: Value B.UUID +uuid = Value (Value.unsafePTIWithShow PTI.uuid (const A.uuid)) {-| Encoder of @INET@ values. -} {-# INLINABLE inet #-} -inet :: Primitive (B.NetAddr B.IP) -inet = Primitive (Value.unsafePTIWithShow PTI.inet (const A.inet)) +inet :: Value (B.NetAddr B.IP) +inet = Value (Value.unsafePTIWithShow PTI.inet (const A.inet)) {-| Encoder of @JSON@ values from JSON AST. -} {-# INLINABLE json #-} -json :: Primitive B.Value -json = Primitive (Value.unsafePTIWithShow PTI.json (const A.json_ast)) +json :: Value B.Value +json = Value (Value.unsafePTIWithShow PTI.json (const A.json_ast)) {-| Encoder of @JSON@ values from raw JSON. -} {-# INLINABLE jsonBytes #-} -jsonBytes :: Primitive ByteString -jsonBytes = Primitive (Value.unsafePTIWithShow PTI.json (const A.json_bytes)) +jsonBytes :: Value ByteString +jsonBytes = Value (Value.unsafePTIWithShow PTI.json (const A.json_bytes)) {-| Encoder of @JSONB@ values from JSON AST. -} {-# INLINABLE jsonb #-} -jsonb :: Primitive B.Value -jsonb = Primitive (Value.unsafePTIWithShow PTI.jsonb (const A.jsonb_ast)) +jsonb :: Value B.Value +jsonb = Value (Value.unsafePTIWithShow PTI.jsonb (const A.jsonb_ast)) {-| Encoder of @JSONB@ values from raw JSON. -} {-# INLINABLE jsonbBytes #-} -jsonbBytes :: Primitive ByteString -jsonbBytes = Primitive (Value.unsafePTIWithShow PTI.jsonb (const A.jsonb_bytes)) +jsonbBytes :: Value ByteString +jsonbBytes = Value (Value.unsafePTIWithShow PTI.jsonb (const A.jsonb_bytes)) {-| Given a function, @@ -300,8 +284,8 @@ which maps a value into a textual enum label used on the DB side, produces an encoder of that value. -} {-# INLINABLE enum #-} -enum :: (a -> Text) -> Primitive a -enum mapping = Primitive (Value.unsafePTI PTI.text (const (A.text_strict . mapping)) (C.text . mapping)) +enum :: (a -> Text) -> Value a +enum mapping = Value (Value.unsafePTI PTI.text (const (A.text_strict . mapping)) (C.text . mapping)) {-| Identifies the value with the PostgreSQL's \"unknown\" type, @@ -313,8 +297,8 @@ For reference, see the section of the Postgres' documentation. -} {-# INLINABLE unknown #-} -unknown :: Primitive ByteString -unknown = Primitive (Value.unsafePTIWithShow PTI.unknown (const A.bytea_strict)) +unknown :: Value ByteString +unknown = Value (Value.unsafePTIWithShow PTI.unknown (const A.bytea_strict)) -- * Array @@ -336,13 +320,13 @@ values, thus this encoder is not suited for that. Use a @value = ANY($1)@ condit newtype Array a = Array (Array.Array a) {-| -Lifts a 'Primitive' encoder into an 'Array' encoder. +Lifts a 'Value' encoder into an 'Array' encoder. -} -element :: NullableOrNot Primitive a -> Array a +element :: NullableOrNot Value a -> Array a element = \ case - NonNullable (Primitive (Value.Value elementOID arrayOID encoder renderer)) -> + NonNullable (Value (Value.Value elementOID arrayOID encoder renderer)) -> Array (Array.value elementOID arrayOID encoder renderer) - Nullable (Primitive (Value.Value elementOID arrayOID encoder renderer)) -> + Nullable (Value (Value.Value elementOID arrayOID encoder renderer)) -> Array (Array.nullableValue elementOID arrayOID encoder renderer) {-| diff --git a/tasty/Main.hs b/tasty/Main.hs index 2445284..25dfaa0 100644 --- a/tasty/Main.hs +++ b/tasty/Main.hs @@ -50,7 +50,7 @@ tree = encoder = contrazip2 (Encoders.param (Encoders.nonNullable (Encoders.array (Encoders.dimension foldl' (Encoders.element (Encoders.nonNullable Encoders.int8)))))) - (Encoders.param (Encoders.nonNullable (Encoders.primitive Encoders.text))) + (Encoders.param (Encoders.nonNullable (Encoders.text))) decoder = fmap (maybe False (const True)) (Decoders.rowMaybe ((Decoders.column . Decoders.nonNullable) Decoders.bool)) session = @@ -205,7 +205,7 @@ tree = sql = "select $1 :: int8" encoder = - Encoders.param (Encoders.nonNullable (Encoders.primitive Encoders.int8)) + Encoders.param (Encoders.nonNullable (Encoders.int8)) decoder = Decoders.singleRow $ (Decoders.column . Decoders.nonNullable) Decoders.int8 fail = @@ -221,8 +221,8 @@ tree = sql = "select ($1 + $2)" encoder = - contramap fst (Encoders.param (Encoders.nonNullable (Encoders.primitive Encoders.int8))) <> - contramap snd (Encoders.param (Encoders.nonNullable (Encoders.primitive Encoders.int8))) + contramap fst (Encoders.param (Encoders.nonNullable (Encoders.int8))) <> + contramap snd (Encoders.param (Encoders.nonNullable (Encoders.int8))) decoder = Decoders.singleRow ((Decoders.column . Decoders.nonNullable) Decoders.int8) sumSession :: Session.Session Int64 @@ -246,8 +246,8 @@ tree = sql = "select ($1 + $2)" encoder = - contramap fst (Encoders.param (Encoders.nonNullable (Encoders.primitive Encoders.int8))) <> - contramap snd (Encoders.param (Encoders.nonNullable (Encoders.primitive Encoders.int8))) + contramap fst (Encoders.param (Encoders.nonNullable (Encoders.int8))) <> + contramap snd (Encoders.param (Encoders.nonNullable (Encoders.int8))) decoder = Decoders.singleRow ((Decoders.column . Decoders.nonNullable) Decoders.int8) session :: Session.Session Int64 @@ -275,7 +275,7 @@ tree = decoder = (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.bool))) encoder = - Encoders.param (Encoders.nonNullable (Encoders.primitive Encoders.interval)) + Encoders.param (Encoders.nonNullable (Encoders.interval)) in DSL.statement (10 :: DiffTime) statement in actualIO >>= \x -> assertEqual (show x) (Right True) x , @@ -309,7 +309,7 @@ tree = decoder = (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.interval))) encoder = - Encoders.param (Encoders.nonNullable (Encoders.primitive Encoders.interval)) + Encoders.param (Encoders.nonNullable (Encoders.interval)) in DSL.statement (10 :: DiffTime) statement in actualIO >>= \x -> assertEqual (show x) (Right (10 :: DiffTime)) x , @@ -340,7 +340,7 @@ tree = decoder = (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.bool))) encoder = - Encoders.param (Encoders.nonNullable (Encoders.primitive Encoders.unknown)) + Encoders.param (Encoders.nonNullable (Encoders.unknown)) in DSL.statement "ok" statement in actualIO >>= assertEqual "" (Right True) , @@ -371,7 +371,7 @@ tree = decoder = (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.text))) encoder = - contramany (Encoders.param (Encoders.nonNullable (Encoders.primitive Encoders.unknown))) + contramany (Encoders.param (Encoders.nonNullable (Encoders.unknown))) in DSL.statement ["1", "2", "4", "5", "6"] statement in actualIO >>= assertEqual "" (Right "3456") , @@ -402,7 +402,7 @@ tree = decoder = (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.enum (Just . id)))) encoder = - Encoders.param (Encoders.nonNullable (Encoders.primitive (Encoders.enum id))) + Encoders.param (Encoders.nonNullable ((Encoders.enum id))) in DSL.statement "ok" statement in actualIO >>= assertEqual "" (Right "ok") , @@ -420,7 +420,7 @@ tree = sql = "select $1" encoder = - Encoders.param (Encoders.nonNullable (Encoders.primitive Encoders.text)) + Encoders.param (Encoders.nonNullable (Encoders.text)) decoder = (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.text))) effect2 = @@ -432,7 +432,7 @@ tree = sql = "select $1" encoder = - Encoders.param (Encoders.nonNullable (Encoders.primitive Encoders.int8)) + Encoders.param (Encoders.nonNullable (Encoders.int8)) decoder = (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) Decoders.int8)) in (,) <$> effect1 <*> effect2 diff --git a/threads-test/Main/Statements.hs b/threads-test/Main/Statements.hs index f652a7a..c6ebd19 100644 --- a/threads-test/Main/Statements.hs +++ b/threads-test/Main/Statements.hs @@ -13,7 +13,7 @@ selectSleep = sql = "select pg_sleep($1)" encoder = - E.param (E.nonNullable (E.primitive E.float8)) + E.param (E.nonNullable E.float8) decoder = D.unit From 8f78014876563963cffb47385b19b50c966061de Mon Sep 17 00:00:00 2001 From: Nikita Volkov Date: Tue, 21 May 2019 13:18:20 +0300 Subject: [PATCH 06/17] Correct the docs --- library/Hasql/Private/Decoders.hs | 15 +++++++-------- library/Hasql/Private/Encoders.hs | 12 ++++++------ library/Hasql/Statement.hs | 6 +++--- 3 files changed, 16 insertions(+), 17 deletions(-) diff --git a/library/Hasql/Private/Decoders.hs b/library/Hasql/Private/Decoders.hs index 69fe26a..4457bec 100644 --- a/library/Hasql/Private/Decoders.hs +++ b/library/Hasql/Private/Decoders.hs @@ -103,12 +103,12 @@ which gets composed of column value decoders. E.g.: ->x :: Row (Maybe Int64, Text, TimeOfDay) ->x = -> (,,) <$> nullableColumn int8 <*> column text <*> column time +@ +x :: 'Row' (Maybe Int64, Text, TimeOfDay) +x = (,,) '<$>' ('column' . 'nullable') 'int8' '<*>' ('column' . 'nonNullable') 'text' '<*>' ('column' . 'nonNullable') 'time' +@ -} -newtype Row a = - Row (Row.Row a) +newtype Row a = Row (Row.Row a) deriving (Functor, Applicative, Monad) {-| @@ -375,9 +375,8 @@ A generic array decoder. Here's how you can use it to produce a specific array value decoder: @ -x :: Value [[Text]] -x = - array (dimension 'replicateM' (dimension 'replicateM' (element text))) +x :: 'Value' [[Text]] +x = 'array' ('dimension' 'replicateM' ('dimension' 'replicateM' ('element' ('nonNullable' 'text')))) @ -} newtype Array a = Array (Array.Array a) diff --git a/library/Hasql/Private/Encoders.hs b/library/Hasql/Private/Encoders.hs index 93cc55e..8677716 100644 --- a/library/Hasql/Private/Encoders.hs +++ b/library/Hasql/Private/Encoders.hs @@ -28,8 +28,8 @@ E.g., @ someParamsEncoder :: 'Params' (Int64, Maybe Text) someParamsEncoder = - ('fst' '>$<' 'param' ('nonNullable' ('primitive' 'int8'))) '<>' - ('snd' '>$<' 'param' ('nullable' ('primitive' 'text'))) + ('fst' '>$<' 'param' ('nonNullable' 'int8')) '<>' + ('snd' '>$<' 'param' ('nullable' 'text')) @ As a general solution for tuples of any arity, instead of 'fst' and 'snd', @@ -40,7 +40,7 @@ E.g., here's how you can achieve the same as the above: @ someParamsEncoder :: 'Params' (Int64, Maybe Text) someParamsEncoder = - 'contrazip2' ('param' ('nonNullable' ('primitive' 'int8'))) ('param' ('nullable' ('primitive' 'text'))) + 'contrazip2' ('param' ('nonNullable' 'int8')) ('param' ('nullable' 'text')) @ Here's how you can implement encoders for custom composite types: @@ -52,9 +52,9 @@ data Gender = Male | Female personParams :: 'Params' Person personParams = - (name '>$<' 'param' ('nonNullable' ('primitive' 'text'))) '<>' - (gender '>$<' 'param' ('nonNullable' ('primitive' genderValue))) '<>' - ('fromIntegral' . age '>$<' 'param' ('nonNullable' ('primitive' 'int8'))) + (name '>$<' 'param' ('nonNullable' 'text')) '<>' + (gender '>$<' 'param' ('nonNullable' genderValue)) '<>' + ('fromIntegral' . age '>$<' 'param' ('nonNullable' 'int8')) genderValue :: 'Value' Gender genderValue = 'enum' genderText 'text' where diff --git a/library/Hasql/Statement.hs b/library/Hasql/Statement.hs index 9375ed0..e5faf42 100644 --- a/library/Hasql/Statement.hs +++ b/library/Hasql/Statement.hs @@ -62,9 +62,9 @@ import qualified Hasql.Encoders as Encoders -- selectSum = 'Statement' sql encoder decoder True where -- sql = "select ($1 + $2)" -- encoder = --- ('fst' '>$<' Encoders.'Hasql.Encoders.param' (Encoders.'Hasql.Encoders.nonNullable' (Encoders.'Hasql.Encoders.primitive' Encoders.'Hasql.Encoders.int8'))) '<>' --- ('snd' '>$<' Encoders.'Hasql.Encoders.param' (Encoders.'Hasql.Encoders.nullable' (Encoders.'Hasql.Encoders.primitive' Encoders.'Hasql.Encoders.text'))) --- decoder = Decoders.'Hasql.Decoders.singleRow' (Decoders.'Hasql.Decoders.column' Decoders.'Hasql.Decoders.int8') +-- ('fst' '>$<' Encoders.'Hasql.Encoders.param' (Encoders.'Hasql.Encoders.nonNullable' Encoders.'Hasql.Encoders.int8')) '<>' +-- ('snd' '>$<' Encoders.'Hasql.Encoders.param' (Encoders.'Hasql.Encoders.nullable' Encoders.'Hasql.Encoders.text')) +-- decoder = Decoders.'Hasql.Decoders.singleRow' (Decoders.'Hasql.Decoders.column' (Decoders.'Hasql.Decoders.nonNullable' Decoders.'Hasql.Decoders.int8')) -- @ -- -- The statement above accepts a product of two parameters of type 'Int64' From db4261ddb5c334b70829064426269eadfaa56bfd Mon Sep 17 00:00:00 2001 From: Nikita Volkov Date: Tue, 21 May 2019 13:25:22 +0300 Subject: [PATCH 07/17] Rename unit to noResult --- library/Hasql/Decoders.hs | 2 +- library/Hasql/Private/Decoders.hs | 6 +++--- library/Hasql/Private/Decoders/Result.hs | 6 +++--- library/Hasql/Private/Decoders/Results.hs | 2 +- library/Hasql/Private/IO.hs | 2 +- library/Hasql/Private/Session.hs | 2 +- library/Hasql/Statement.hs | 2 +- tasty/Main.hs | 14 +++++++------- tasty/Main/Statements.hs | 2 +- threads-test/Main/Statements.hs | 2 +- 10 files changed, 20 insertions(+), 20 deletions(-) diff --git a/library/Hasql/Decoders.hs b/library/Hasql/Decoders.hs index a031ef5..fa5c98d 100644 --- a/library/Hasql/Decoders.hs +++ b/library/Hasql/Decoders.hs @@ -5,7 +5,7 @@ module Hasql.Decoders ( -- * Result Result, - unit, + noResult, rowsAffected, singleRow, -- ** Specialized multi-row results diff --git a/library/Hasql/Private/Decoders.hs b/library/Hasql/Private/Decoders.hs index 4457bec..9a53888 100644 --- a/library/Hasql/Private/Decoders.hs +++ b/library/Hasql/Private/Decoders.hs @@ -29,9 +29,9 @@ Decode no value from the result. Useful for statements like @INSERT@ or @CREATE@. -} -{-# INLINABLE unit #-} -unit :: Result () -unit = Result (Results.single Result.unit) +{-# INLINABLE noResult #-} +noResult :: Result () +noResult = Result (Results.single Result.noResult) {-| Get the amount of rows affected by such statements as diff --git a/library/Hasql/Private/Decoders/Result.hs b/library/Hasql/Private/Decoders/Result.hs index 519a1b9..11acf77 100644 --- a/library/Hasql/Private/Decoders/Result.hs +++ b/library/Hasql/Private/Decoders/Result.hs @@ -20,9 +20,9 @@ run :: Result a -> (Bool, LibPQ.Result) -> IO (Either ResultError a) run (Result reader) env = runExceptT (runReaderT reader env) -{-# INLINE unit #-} -unit :: Result () -unit = +{-# INLINE noResult #-} +noResult :: Result () +noResult = checkExecStatus $ \case LibPQ.CommandOk -> True LibPQ.TuplesOk -> True diff --git a/library/Hasql/Private/Decoders/Results.hs b/library/Hasql/Private/Decoders/Results.hs index 34e8257..cf0cb56 100644 --- a/library/Hasql/Private/Decoders/Results.hs +++ b/library/Hasql/Private/Decoders/Results.hs @@ -81,4 +81,4 @@ dropRemainders = loop integerDatetimes connection <* checkErrors where checkErrors = - ExceptT $ fmap (mapLeft ResultError) $ Result.run Result.unit (integerDatetimes, result) + ExceptT $ fmap (mapLeft ResultError) $ Result.run Result.noResult (integerDatetimes, result) diff --git a/library/Hasql/Private/IO.hs b/library/Hasql/Private/IO.hs index f227a16..d51c712 100644 --- a/library/Hasql/Private/IO.hs +++ b/library/Hasql/Private/IO.hs @@ -88,7 +88,7 @@ getPreparedStatementKey connection registry template oidList = sent <- LibPQ.sendPrepare connection key template (mfilter (not . null) (Just oidList)) let resultsDecoder = if sent - then ResultsDecoders.single ResultDecoders.unit + then ResultsDecoders.single ResultDecoders.noResult else ResultsDecoders.clientError fmap resultsMapping $ getResults connection undefined resultsDecoder where diff --git a/library/Hasql/Private/Session.hs b/library/Hasql/Private/Session.hs index 4145b3b..d9dafb2 100644 --- a/library/Hasql/Private/Session.hs +++ b/library/Hasql/Private/Session.hs @@ -40,7 +40,7 @@ sql sql = return $ r1 *> r2 where decoder = - Decoders.Results.single Decoders.Result.unit + Decoders.Results.single Decoders.Result.noResult -- | -- Parameters and a specification of a parametric single-statement query to apply them to. diff --git a/library/Hasql/Statement.hs b/library/Hasql/Statement.hs index e5faf42..e60488b 100644 --- a/library/Hasql/Statement.hs +++ b/library/Hasql/Statement.hs @@ -25,7 +25,7 @@ module Hasql.Statement -- Encoders.'Encoders.foldableDimension' . -- Encoders.'Encoders.element' . -- Encoders.'Encoders.nonNullable' - -- decoder = Decoders.'Decoders.unit' + -- decoder = Decoders.'Decoders.noResult' -- @ -- -- This approach is much more efficient than executing a single-row Insert diff --git a/tasty/Main.hs b/tasty/Main.hs index 25dfaa0..c7772ca 100644 --- a/tasty/Main.hs +++ b/tasty/Main.hs @@ -184,7 +184,7 @@ tree = encoder = mempty decoder = - Decoders.unit + Decoders.noResult in io , testCase "Prepared statements after error" $ @@ -319,14 +319,14 @@ tree = DSL.session $ do let statement = - Statement.Statement sql mempty Decoders.unit True + Statement.Statement sql mempty Decoders.noResult True where sql = "drop type if exists mood" in DSL.statement () statement let statement = - Statement.Statement sql mempty Decoders.unit True + Statement.Statement sql mempty Decoders.noResult True where sql = "create type mood as enum ('sad', 'ok', 'happy')" @@ -350,14 +350,14 @@ tree = DSL.session $ do let statement = - Statement.Statement sql mempty Decoders.unit True + Statement.Statement sql mempty Decoders.noResult True where sql = "create or replace function overloaded(a int, b int) returns int as $$ select a + b $$ language sql;" in DSL.statement () statement let statement = - Statement.Statement sql mempty Decoders.unit True + Statement.Statement sql mempty Decoders.noResult True where sql = "create or replace function overloaded(a text, b text, c text) returns text as $$ select a || b || c $$ language sql;" @@ -381,14 +381,14 @@ tree = DSL.session $ do let statement = - Statement.Statement sql mempty Decoders.unit True + Statement.Statement sql mempty Decoders.noResult True where sql = "drop type if exists mood" in DSL.statement () statement let statement = - Statement.Statement sql mempty Decoders.unit True + Statement.Statement sql mempty Decoders.noResult True where sql = "create type mood as enum ('sad', 'ok', 'happy')" diff --git a/tasty/Main/Statements.hs b/tasty/Main/Statements.hs index f67a4e3..ea3cbcc 100644 --- a/tasty/Main/Statements.hs +++ b/tasty/Main/Statements.hs @@ -9,7 +9,7 @@ import qualified Main.Prelude as Prelude plain :: ByteString -> HQ.Statement () () plain sql = - HQ.Statement sql mempty HD.unit False + HQ.Statement sql mempty HD.noResult False dropType :: ByteString -> HQ.Statement () () dropType name = diff --git a/threads-test/Main/Statements.hs b/threads-test/Main/Statements.hs index c6ebd19..a2f53d5 100644 --- a/threads-test/Main/Statements.hs +++ b/threads-test/Main/Statements.hs @@ -15,6 +15,6 @@ selectSleep = encoder = E.param (E.nonNullable E.float8) decoder = - D.unit + D.noResult From a1ead0ed62a686d9dfb82561b415641caa786660 Mon Sep 17 00:00:00 2001 From: Nikita Volkov Date: Tue, 21 May 2019 13:29:00 +0300 Subject: [PATCH 08/17] Ditch foldableDimension --- library/Hasql/Encoders.hs | 1 - library/Hasql/Private/Encoders.hs | 10 +--------- library/Hasql/Statement.hs | 2 +- 3 files changed, 2 insertions(+), 11 deletions(-) diff --git a/library/Hasql/Encoders.hs b/library/Hasql/Encoders.hs index 02e9f1c..8720df0 100644 --- a/library/Hasql/Encoders.hs +++ b/library/Hasql/Encoders.hs @@ -45,7 +45,6 @@ module Hasql.Encoders Array, element, dimension, - foldableDimension, ) where diff --git a/library/Hasql/Private/Encoders.hs b/library/Hasql/Private/Encoders.hs index 8677716..83f1935 100644 --- a/library/Hasql/Private/Encoders.hs +++ b/library/Hasql/Private/Encoders.hs @@ -311,7 +311,7 @@ Here's an example of its usage: @ someParamsEncoder :: 'Params' [[Int64]] -someParamsEncoder = 'param' ('nonNullable' ('array' ('foldableDimension' ('foldableDimension' ('element' ('nonNullable' 'int8')))))) +someParamsEncoder = 'param' ('nonNullable' ('array' ('dimension' 'foldl'' ('dimension' 'foldl'' ('element' ('nonNullable' 'int8')))))) @ Please note that the PostgreSQL __IN__ keyword does not accept an array, but rather a syntactical list of @@ -345,11 +345,3 @@ which determines the input value. {-# INLINABLE dimension #-} dimension :: (forall a. (a -> b -> a) -> a -> c -> a) -> Array b -> Array c dimension foldl (Array imp) = Array (Array.dimension foldl imp) - -{-| -Same as 'dimension', but specialized to 'Foldable' values, -which includes such structures as list and 'Vector'. --} -{-# INLINE foldableDimension #-} -foldableDimension :: Foldable foldable => Array a -> Array (foldable a) -foldableDimension = dimension foldl' diff --git a/library/Hasql/Statement.hs b/library/Hasql/Statement.hs index e60488b..0eadd6b 100644 --- a/library/Hasql/Statement.hs +++ b/library/Hasql/Statement.hs @@ -22,7 +22,7 @@ module Hasql.Statement -- Encoders.'Encoders.param' . -- Encoders.'Encoders.nonNullable' . -- Encoders.'Encoders.array' . - -- Encoders.'Encoders.foldableDimension' . + -- Encoders.'Encoders.dimension' 'foldl'' . -- Encoders.'Encoders.element' . -- Encoders.'Encoders.nonNullable' -- decoder = Decoders.'Decoders.noResult' From 872808e9635f6917fc8a16d948ece32623f9ada6 Mon Sep 17 00:00:00 2001 From: Nikita Volkov Date: Tue, 21 May 2019 14:50:40 +0300 Subject: [PATCH 09/17] Correct the docs --- library/Hasql/Statement.hs | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/library/Hasql/Statement.hs b/library/Hasql/Statement.hs index 0eadd6b..efd4e2f 100644 --- a/library/Hasql/Statement.hs +++ b/library/Hasql/Statement.hs @@ -39,7 +39,7 @@ import qualified Hasql.Encoders as Encoders -- | --- A specification of a strictly single-statement query, which can be parameterized and prepared. +-- Specification of a strictly single-statement query, which can be parameterized and prepared. -- -- Consists of the following: -- @@ -51,11 +51,12 @@ import qualified Hasql.Encoders as Encoders -- The SQL template must be formatted according to Postgres' standard, -- with any non-ASCII characters of the template encoded using UTF-8. -- According to the format, --- parameters must be referred to using the positional notation, as in the following: +-- parameters must be referred to using a positional notation, as in the following: -- @$1@, @$2@, @$3@ and etc. --- Those references must be used to refer to the values of the 'Encoders.Params' encoder. +-- Those references must be used in accordance to the order in which the according +-- value encoders are specified in 'Encoders.Params'. -- --- Following is an example of the declaration of a prepared statement with its associated codecs. +-- Following is an example of a declaration of a prepared statement with its associated codecs. -- -- @ -- selectSum :: 'Statement' (Int64, Int64) Int64 From 38e80351e6bb538604a1cdfde3623c3dae5538eb Mon Sep 17 00:00:00 2001 From: Nikita Volkov Date: Tue, 21 May 2019 18:51:53 +0300 Subject: [PATCH 10/17] Correct the docs --- library/Hasql/Private/Encoders.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/library/Hasql/Private/Encoders.hs b/library/Hasql/Private/Encoders.hs index 83f1935..aa62f89 100644 --- a/library/Hasql/Private/Encoders.hs +++ b/library/Hasql/Private/Encoders.hs @@ -314,7 +314,7 @@ someParamsEncoder :: 'Params' [[Int64]] someParamsEncoder = 'param' ('nonNullable' ('array' ('dimension' 'foldl'' ('dimension' 'foldl'' ('element' ('nonNullable' 'int8')))))) @ -Please note that the PostgreSQL __IN__ keyword does not accept an array, but rather a syntactical list of +Please note that the PostgreSQL @IN@ keyword does not accept an array, but rather a syntactical list of values, thus this encoder is not suited for that. Use a @value = ANY($1)@ condition instead. -} newtype Array a = Array (Array.Array a) From 799fbca0ed3ae972c618f7592ef1abf81d68bc4c Mon Sep 17 00:00:00 2001 From: Nikita Volkov Date: Tue, 21 May 2019 19:01:18 +0300 Subject: [PATCH 11/17] Add "foldableArray" encoder --- library/Hasql/Encoders.hs | 1 + library/Hasql/Private/Encoders.hs | 20 ++++++++++++++++++++ 2 files changed, 21 insertions(+) diff --git a/library/Hasql/Encoders.hs b/library/Hasql/Encoders.hs index 8720df0..0ae794d 100644 --- a/library/Hasql/Encoders.hs +++ b/library/Hasql/Encoders.hs @@ -17,6 +17,7 @@ module Hasql.Encoders -- * Value Value, array, + foldableArray, bool, int2, int4, diff --git a/library/Hasql/Private/Encoders.hs b/library/Hasql/Private/Encoders.hs index aa62f89..01c01f7 100644 --- a/library/Hasql/Private/Encoders.hs +++ b/library/Hasql/Private/Encoders.hs @@ -122,6 +122,26 @@ array (Array (Array.Array valueOID arrayOID arrayEncoder renderer)) = let encoder env input = A.array (PTI.oidWord32 valueOID) (arrayEncoder env input) in Value (Value.Value arrayOID arrayOID encoder renderer) +{-| +Lift a value encoder of element into a unidimensional array encoder of a foldable value. + +E.g., + +@ +vectorOfInts :: Value (Vector Int64) +vectorOfInts = 'foldableArray' ('nonNullable' 'int8') +@ + +This function is merely a shortcut for the following expression: + +@ +('array' . 'dimension' 'foldl'' . 'element') +@ +-} +{-# INLINE foldableArray #-} +foldableArray :: Foldable foldable => NullableOrNot Value a -> Value (foldable a) +foldableArray = array . dimension foldl' . element + {-| Encoder of @BOOL@ values. -} From 5fc68b7d92147304070e021eb9321b7e30402b6d Mon Sep 17 00:00:00 2001 From: Nikita Volkov Date: Tue, 21 May 2019 21:20:31 +0300 Subject: [PATCH 12/17] Rearrange the encoders --- library/Hasql/Encoders.hs | 4 +-- library/Hasql/Private/Encoders.hs | 56 +++++++++++++++---------------- 2 files changed, 30 insertions(+), 30 deletions(-) diff --git a/library/Hasql/Encoders.hs b/library/Hasql/Encoders.hs index 0ae794d..42fcfb6 100644 --- a/library/Hasql/Encoders.hs +++ b/library/Hasql/Encoders.hs @@ -16,8 +16,6 @@ module Hasql.Encoders nullable, -- * Value Value, - array, - foldableArray, bool, int2, int4, @@ -42,6 +40,8 @@ module Hasql.Encoders jsonbBytes, enum, unknown, + array, + foldableArray, -- * Array Array, element, diff --git a/library/Hasql/Private/Encoders.hs b/library/Hasql/Private/Encoders.hs index 01c01f7..b1e406c 100644 --- a/library/Hasql/Private/Encoders.hs +++ b/library/Hasql/Private/Encoders.hs @@ -114,34 +114,6 @@ Value encoder. newtype Value a = Value (Value.Value a) deriving (Contravariant) -{-| -Lift an array encoder into a parameter encoder. --} -array :: Array a -> Value a -array (Array (Array.Array valueOID arrayOID arrayEncoder renderer)) = let - encoder env input = A.array (PTI.oidWord32 valueOID) (arrayEncoder env input) - in Value (Value.Value arrayOID arrayOID encoder renderer) - -{-| -Lift a value encoder of element into a unidimensional array encoder of a foldable value. - -E.g., - -@ -vectorOfInts :: Value (Vector Int64) -vectorOfInts = 'foldableArray' ('nonNullable' 'int8') -@ - -This function is merely a shortcut for the following expression: - -@ -('array' . 'dimension' 'foldl'' . 'element') -@ --} -{-# INLINE foldableArray #-} -foldableArray :: Foldable foldable => NullableOrNot Value a -> Value (foldable a) -foldableArray = array . dimension foldl' . element - {-| Encoder of @BOOL@ values. -} @@ -320,6 +292,34 @@ section of the Postgres' documentation. unknown :: Value ByteString unknown = Value (Value.unsafePTIWithShow PTI.unknown (const A.bytea_strict)) +{-| +Lift an array encoder into a parameter encoder. +-} +array :: Array a -> Value a +array (Array (Array.Array valueOID arrayOID arrayEncoder renderer)) = let + encoder env input = A.array (PTI.oidWord32 valueOID) (arrayEncoder env input) + in Value (Value.Value arrayOID arrayOID encoder renderer) + +{-| +Lift a value encoder of element into a unidimensional array encoder of a foldable value. + +E.g., + +@ +vectorOfInts :: Value (Vector Int64) +vectorOfInts = 'foldableArray' ('nonNullable' 'int8') +@ + +This function is merely a shortcut for the following expression: + +@ +('array' . 'dimension' 'foldl'' . 'element') +@ +-} +{-# INLINE foldableArray #-} +foldableArray :: Foldable foldable => NullableOrNot Value a -> Value (foldable a) +foldableArray = array . dimension foldl' . element + -- * Array ------------------------- From 37002e6530f6d2001406dcee6876cdd408672e5c Mon Sep 17 00:00:00 2001 From: Nikita Volkov Date: Tue, 21 May 2019 21:22:42 +0300 Subject: [PATCH 13/17] Update the signature of "foldableArray" --- library/Hasql/Private/Encoders.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/library/Hasql/Private/Encoders.hs b/library/Hasql/Private/Encoders.hs index b1e406c..feaba3c 100644 --- a/library/Hasql/Private/Encoders.hs +++ b/library/Hasql/Private/Encoders.hs @@ -317,7 +317,7 @@ This function is merely a shortcut for the following expression: @ -} {-# INLINE foldableArray #-} -foldableArray :: Foldable foldable => NullableOrNot Value a -> Value (foldable a) +foldableArray :: Foldable foldable => NullableOrNot Value element -> Value (foldable element) foldableArray = array . dimension foldl' . element From 296de5498b57f23c68ad4ad7b0900071d17922aa Mon Sep 17 00:00:00 2001 From: Nikita Volkov Date: Tue, 21 May 2019 21:34:01 +0300 Subject: [PATCH 14/17] Correct the grammar in docs --- library/Hasql/Private/Decoders.hs | 6 +++--- library/Hasql/Private/Encoders.hs | 2 +- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/library/Hasql/Private/Decoders.hs b/library/Hasql/Private/Decoders.hs index 9a53888..41650f7 100644 --- a/library/Hasql/Private/Decoders.hs +++ b/library/Hasql/Private/Decoders.hs @@ -324,7 +324,7 @@ jsonbBytes :: (ByteString -> Either Text a) -> Value a jsonbBytes fn = Value (Value.decoder (const (A.jsonb_bytes fn))) {-| -Lifts a custom value decoder function to a 'Value' decoder. +Lift a custom value decoder function to a 'Value' decoder. -} {-# INLINABLE custom #-} custom :: (Bool -> ByteString -> Either Text a) -> Value a @@ -352,14 +352,14 @@ enum :: (Text -> Maybe a) -> Value a enum mapping = Value (Value.decoder (const (A.enum mapping))) {-| -Lifts the 'Array' decoder to a 'Value' decoder. +Lift an 'Array' decoder to a 'Value' decoder. -} {-# INLINABLE array #-} array :: Array a -> Value a array (Array imp) = Value (Value.decoder (Array.run imp)) {-| -Lifts the 'Composite' decoder to a 'Value' decoder. +Lift a 'Composite' decoder to a 'Value' decoder. -} {-# INLINABLE composite #-} composite :: Composite a -> Value a diff --git a/library/Hasql/Private/Encoders.hs b/library/Hasql/Private/Encoders.hs index feaba3c..b3201a3 100644 --- a/library/Hasql/Private/Encoders.hs +++ b/library/Hasql/Private/Encoders.hs @@ -310,7 +310,7 @@ vectorOfInts :: Value (Vector Int64) vectorOfInts = 'foldableArray' ('nonNullable' 'int8') @ -This function is merely a shortcut for the following expression: +This function is merely a shortcut to the following expression: @ ('array' . 'dimension' 'foldl'' . 'element') From 3b6af08a2863d458c2230d7e3cc319e7e973865f Mon Sep 17 00:00:00 2001 From: Nikita Volkov Date: Tue, 21 May 2019 21:34:20 +0300 Subject: [PATCH 15/17] Add shortcut array decoders --- library/Hasql/Decoders.hs | 2 ++ library/Hasql/Private/Decoders.hs | 27 +++++++++++++++++++++++++++ 2 files changed, 29 insertions(+) diff --git a/library/Hasql/Decoders.hs b/library/Hasql/Decoders.hs index fa5c98d..90d9c62 100644 --- a/library/Hasql/Decoders.hs +++ b/library/Hasql/Decoders.hs @@ -47,6 +47,8 @@ module Hasql.Decoders jsonb, jsonbBytes, array, + listArray, + vectorArray, composite, hstore, enum, diff --git a/library/Hasql/Private/Decoders.hs b/library/Hasql/Private/Decoders.hs index 41650f7..25f6f14 100644 --- a/library/Hasql/Private/Decoders.hs +++ b/library/Hasql/Private/Decoders.hs @@ -15,6 +15,7 @@ import qualified Hasql.Private.Decoders.Value as Value import qualified Hasql.Private.Decoders.Array as Array import qualified Hasql.Private.Decoders.Composite as Composite import qualified Hasql.Private.Prelude as Prelude +import qualified Data.Vector.Generic as GenericVector -- * Result ------------------------- @@ -358,6 +359,32 @@ Lift an 'Array' decoder to a 'Value' decoder. array :: Array a -> Value a array (Array imp) = Value (Value.decoder (Array.run imp)) +{-| +Lift a value decoder of element into a unidimensional array decoder producing a list. + +This function is merely a shortcut to the following expression: + +@ +('array' . 'dimension' Control.Monad.'replicateM' . 'element') +@ +-} +{-# INLINE listArray #-} +listArray :: NullableOrNot Value element -> Value [element] +listArray = array . dimension replicateM . element + +{-| +Lift a value decoder of element into a unidimensional array decoder producing a generic vector. + +This function is merely a shortcut to the following expression: + +@ +('array' . 'dimension' Data.Vector.Generic.'GenericVector.replicateM' . 'element') +@ +-} +{-# INLINE vectorArray #-} +vectorArray :: GenericVector.Vector vector element => NullableOrNot Value element -> Value (vector element) +vectorArray = array . dimension GenericVector.replicateM . element + {-| Lift a 'Composite' decoder to a 'Value' decoder. -} From 5c260f9b50e154ad712f339f8ef14c0e2f2b7981 Mon Sep 17 00:00:00 2001 From: Nikita Volkov Date: Tue, 21 May 2019 21:36:29 +0300 Subject: [PATCH 16/17] Correct the docs --- library/Hasql/Private/Decoders.hs | 3 +-- library/Hasql/Private/Encoders.hs | 3 +-- 2 files changed, 2 insertions(+), 4 deletions(-) diff --git a/library/Hasql/Private/Decoders.hs b/library/Hasql/Private/Decoders.hs index 25f6f14..3cfc6b1 100644 --- a/library/Hasql/Private/Decoders.hs +++ b/library/Hasql/Private/Decoders.hs @@ -419,8 +419,7 @@ Accepts: (@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 'dimension', -'element' or 'nullableElement'. +* A decoder of its components, which can be either another 'dimension' or 'element'. -} {-# INLINABLE dimension #-} dimension :: (forall m. Monad m => Int -> m a -> m b) -> Array a -> Array b diff --git a/library/Hasql/Private/Encoders.hs b/library/Hasql/Private/Encoders.hs index b3201a3..5f42f90 100644 --- a/library/Hasql/Private/Encoders.hs +++ b/library/Hasql/Private/Encoders.hs @@ -359,8 +359,7 @@ Accepts: such as @Data.Foldable.'foldl''@, which determines the input value. -* A component encoder, which can be either another 'dimension', -'element' or 'nullableElement'. +* A component encoder, which can be either another 'dimension' or 'element'. -} {-# INLINABLE dimension #-} dimension :: (forall a. (a -> b -> a) -> a -> c -> a) -> Array b -> Array c From 9ebf5593ce3c4490a72fc76244b4122d8ac75907 Mon Sep 17 00:00:00 2001 From: Nikita Volkov Date: Tue, 21 May 2019 21:37:28 +0300 Subject: [PATCH 17/17] Correct the docs --- library/Hasql/Private/Decoders.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/library/Hasql/Private/Decoders.hs b/library/Hasql/Private/Decoders.hs index 3cfc6b1..12f05b5 100644 --- a/library/Hasql/Private/Decoders.hs +++ b/library/Hasql/Private/Decoders.hs @@ -445,7 +445,7 @@ newtype Composite a = Composite (Composite.Composite a) deriving (Functor, Applicative, Monad) {-| -Lift a 'Value' decoder into a 'Composite' decoder for parsing of non-nullable leaf values. +Lift a 'Value' decoder into a 'Composite' decoder for parsing of component values. -} field :: NullableOrNot Value a -> Composite a field = \ case