diff --git a/benchmarks/Main.hs b/benchmarks/Main.hs --- a/benchmarks/Main.hs +++ b/benchmarks/Main.hs @@ -79,7 +79,7 @@ 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 @@ 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 --- a/hasql.cabal +++ b/hasql.cabal @@ -1,50 +1,29 @@ -name: - hasql -version: - 1.3.0.6 -category: - Hasql, Database, PostgreSQL -synopsis: - An efficient PostgreSQL driver and a flexible mapping API +name: hasql +version: 1.4 +category: Hasql, Database, PostgreSQL +synopsis: An efficient PostgreSQL driver with a flexible mapping API description: This package is the root of the \"hasql\" ecosystem. . The API comes free from all kinds of exceptions. All error-reporting is explicit and is presented using the 'Either' type. -homepage: - https://github.com/nikita-volkov/hasql -bug-reports: - https://github.com/nikita-volkov/hasql/issues -author: - Nikita Volkov -maintainer: - Nikita Volkov -copyright: - (c) 2014, Nikita Volkov -license: - MIT -license-file: - LICENSE -build-type: - Simple -cabal-version: - >=1.10 - +homepage: https://github.com/nikita-volkov/hasql +bug-reports: https://github.com/nikita-volkov/hasql/issues +author: Nikita Volkov +maintainer: Nikita Volkov +copyright: (c) 2014, Nikita Volkov +license: MIT +license-file: LICENSE +build-type: Simple +cabal-version: >=1.10 source-repository head - type: - git - location: - git://github.com/nikita-volkov/hasql.git - + type: git + location: git://github.com/nikita-volkov/hasql.git library - hs-source-dirs: - library - ghc-options: - default-extensions: - Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples - default-language: - Haskell2010 + hs-source-dirs: library + default-extensions: Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples + default-language: Haskell2010 exposed-modules: Hasql.Decoders Hasql.Encoders @@ -61,143 +40,106 @@ Hasql.Private.PreparedStatementRegistry Hasql.Private.Settings Hasql.Private.Commands + Hasql.Private.Decoders Hasql.Private.Decoders.Array Hasql.Private.Decoders.Composite Hasql.Private.Decoders.Value 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 build-depends: - -- parsing: - attoparsec >= 0.10 && < 0.14, - -- database: - postgresql-binary >= 0.12.1 && < 0.13, - postgresql-libpq == 0.9.*, - -- builders: - bytestring-strict-builder >= 0.4.5.1 && < 0.5, - -- data: - dlist >= 0.7 && < 0.9, - vector >= 0.10 && < 0.13, - hashtables >= 1.1 && < 2, - text >= 1 && < 2, - text-builder >= 0.6.1.2 && < 0.7, - bytestring >= 0.10 && < 0.11, - hashable >= 1.2 && < 2, - -- control: - data-default-class >= 0.0.1 && < 0.2, - profunctors >= 5.1 && < 6, - contravariant-extras == 0.3.*, - contravariant >= 1.3 && < 2, - mtl >= 2 && < 3, - transformers >= 0.3 && < 0.6, - -- errors: - loch-th == 0.2.*, - placeholders == 0.1.*, - -- general: - base-prelude >= 0.1.19 && < 2, - base >= 4.9 && < 5 - + attoparsec >=0.10 && <0.14, + base >=4.9 && <5, + base-prelude >=0.1.19 && <2, + bytestring >=0.10 && <0.11, + bytestring-strict-builder >=0.4.5.1 && <0.5, + contravariant >=1.3 && <2, + contravariant-extras ==0.3.*, + dlist >=0.7 && <0.9, + hashable >=1.2 && <2, + hashtables >=1.1 && <2, + loch-th ==0.2.*, + mtl >=2 && <3, + placeholders ==0.1.*, + postgresql-binary >=0.12.1 && <0.13, + postgresql-libpq ==0.9.*, + profunctors >=5.1 && <6, + text >=1 && <2, + text-builder >=0.6.1.2 && <0.7, + transformers >=0.3 && <0.6, + vector >=0.10 && <0.13 test-suite tasty - type: - exitcode-stdio-1.0 - hs-source-dirs: - tasty - main-is: - Main.hs + type: exitcode-stdio-1.0 + hs-source-dirs: tasty + main-is: Main.hs + default-extensions: Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples + default-language: Haskell2010 other-modules: Main.DSL Main.Connection Main.Statements Main.Prelude - default-extensions: - Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples - default-language: - Haskell2010 build-depends: - -- database: hasql, - -- testing: - tasty >= 0.12 && < 2, - tasty-quickcheck >= 0.9 && < 0.11, - tasty-hunit >= 0.9 && < 0.11, - quickcheck-instances >= 0.3.11 && < 0.4, - QuickCheck >= 2.8.1 && < 3, - -- general: - data-default-class, - -- - rerebase < 2 - + QuickCheck >=2.8.1 && <3, + quickcheck-instances >=0.3.11 && <0.4, + rerebase <2, + tasty >=0.12 && <2, + tasty-hunit >=0.9 && <0.11, + tasty-quickcheck >=0.9 && <0.11 test-suite threads-test - type: - exitcode-stdio-1.0 - hs-source-dirs: - threads-test - main-is: - Main.hs + type: exitcode-stdio-1.0 + hs-source-dirs: threads-test + main-is: Main.hs + default-extensions: + Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples + default-language: + Haskell2010 other-modules: Main.Statements ghc-options: -O2 -threaded "-with-rtsopts=-N" - default-extensions: - Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples - default-language: - Haskell2010 build-depends: - -- database: hasql, - -- rebase - benchmark benchmarks - type: - exitcode-stdio-1.0 - hs-source-dirs: - benchmarks - main-is: - Main.hs + type: exitcode-stdio-1.0 + hs-source-dirs: benchmarks + main-is: Main.hs + default-extensions: Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples + default-language: Haskell2010 ghc-options: -O2 -threaded "-with-rtsopts=-N" -rtsopts -funbox-strict-fields - default-extensions: - Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples - default-language: - Haskell2010 build-depends: + bug ==1.*, + criterion >=1.1 && <2, hasql, - -- benchmarking: - criterion >= 1.1 && < 2, - -- general: - bug == 1.*, - rerebase < 2 - + rerebase <2 test-suite profiling - type: - exitcode-stdio-1.0 - hs-source-dirs: - profiling - main-is: - Main.hs + type: exitcode-stdio-1.0 + hs-source-dirs: profiling + main-is: Main.hs + default-extensions: Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples + default-language: Haskell2010 ghc-options: -O2 -threaded -rtsopts - default-extensions: - Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples - default-language: - Haskell2010 build-depends: + bug ==1.*, hasql, - bug == 1.*, - rerebase == 1.* + rerebase ==1.* diff --git a/library/Hasql/Decoders.hs b/library/Hasql/Decoders.hs --- a/library/Hasql/Decoders.hs +++ b/library/Hasql/Decoders.hs @@ -1,10 +1,11 @@ --- | --- A DSL for declaration of result decoders. +{-| +A DSL for declaration of result decoders. +-} module Hasql.Decoders ( -- * Result Result, - unit, + noResult, rowsAffected, singleRow, -- ** Specialized multi-row results @@ -17,7 +18,10 @@ -- * Row Row, column, - nullableColumn, + -- * Nullability + NullableOrNot, + nonNullable, + nullable, -- * Value Value, bool, @@ -43,6 +47,8 @@ jsonb, jsonbBytes, array, + listArray, + vectorArray, composite, hstore, enum, @@ -51,663 +57,10 @@ 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 [] - - --- ** Instances -------------------------- - --- | Maps to 'unit'. -instance Default (Result ()) where - {-# INLINE def #-} - def = - unit - --- | Maps to 'rowsAffected'. -instance Default (Result Int64) where - {-# INLINE def #-} - def = - rowsAffected - --- | Maps to @('rowMaybe' def)@. -instance Default (Row a) => Default (Result (Maybe a)) where - {-# INLINE def #-} - def = - rowMaybe def - --- | Maps to @('rowVector' def)@. -instance Default (Row a) => Default (Result (Vector a)) where - {-# INLINE def #-} - def = - rowVector def - --- | Maps to @('rowList' def)@. -instance Default (Row a) => Default (Result ([] a)) where - {-# INLINE def #-} - def = - rowList def - --- | Maps to @(fmap Identity ('singleRow' def)@. -instance Default (Row a) => Default (Result (Identity a)) where - {-# INLINE def #-} - def = - fmap Identity (singleRow def) - - --- * 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) - - --- ** Instances -------------------------- - -instance Default (Value a) => Default (Row (Identity a)) where - {-# INLINE def #-} - def = - fmap Identity (column def) - -instance Default (Value a) => Default (Row (Maybe a)) where - {-# INLINE def #-} - def = - nullableColumn def - -instance (Default (Value a1), Default (Value a2)) => Default (Row (a1, a2)) where - {-# INLINE def #-} - def = - ap (fmap (,) (column def)) (column def) - - --- * 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))) - - --- ** Instances -------------------------- - --- | --- Maps to 'bool'. -instance Default (Value Bool) where - {-# INLINE def #-} - def = - bool - --- | --- Maps to 'int2'. -instance Default (Value Int16) where - {-# INLINE def #-} - def = - int2 - --- | --- Maps to 'int4'. -instance Default (Value Int32) where - {-# INLINE def #-} - def = - int4 - --- | --- Maps to 'int8'. -instance Default (Value Int64) where - {-# INLINE def #-} - def = - int8 - --- | --- Maps to 'float4'. -instance Default (Value Float) where - {-# INLINE def #-} - def = - float4 - --- | --- Maps to 'float8'. -instance Default (Value Double) where - {-# INLINE def #-} - def = - float8 - --- | --- Maps to 'numeric'. -instance Default (Value B.Scientific) where - {-# INLINE def #-} - def = - numeric - --- | --- Maps to 'char'. -instance Default (Value Char) where - {-# INLINE def #-} - def = - char - --- | --- Maps to 'text'. -instance Default (Value Text) where - {-# INLINE def #-} - def = - text - --- | --- Maps to 'bytea'. -instance Default (Value ByteString) where - {-# INLINE def #-} - def = - bytea - --- | --- Maps to 'date'. -instance Default (Value B.Day) where - {-# INLINE def #-} - def = - date - --- | --- Maps to 'timestamp'. -instance Default (Value B.LocalTime) where - {-# INLINE def #-} - def = - timestamp - --- | --- Maps to 'timestamptz'. -instance Default (Value B.UTCTime) where - {-# INLINE def #-} - def = - timestamptz - --- | --- Maps to 'time'. -instance Default (Value B.TimeOfDay) where - {-# INLINE def #-} - def = - time - --- | --- Maps to 'timetz'. -instance Default (Value (B.TimeOfDay, B.TimeZone)) where - {-# INLINE def #-} - def = - timetz - --- | --- Maps to 'interval'. -instance Default (Value B.DiffTime) where - {-# INLINE def #-} - def = - interval - --- | --- Maps to 'uuid'. -instance Default (Value B.UUID) where - {-# INLINE def #-} - def = - uuid - --- | --- Maps to 'json'. -instance Default (Value B.Value) where - {-# INLINE def #-} - def = - json - - --- * 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/Encoders.hs b/library/Hasql/Encoders.hs --- a/library/Hasql/Encoders.hs +++ b/library/Hasql/Encoders.hs @@ -1,12 +1,19 @@ --- | --- 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, + -- * Nullability + NullableOrNot, + nonNullable, + nullable, -- * Value Value, bool, @@ -31,529 +38,15 @@ jsonBytes, jsonb, jsonbBytes, - array, enum, unknown, + array, + foldableArray, -- * Array Array, element, - nullableElement, dimension, - -- ** Insert Many - -- $insertMany ) 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) - - --- ** Instances -------------------------- - --- | --- Maps to 'unit'. -instance Default (Params ()) where - {-# INLINE def #-} - def = - unit - -instance Default (Value a) => Default (Params (Identity a)) where - {-# INLINE def #-} - def = - contramap runIdentity (param def) - -instance (Default (Value a1), Default (Value a2)) => Default (Params (a1, a2)) where - {-# INLINE def #-} - def = - contrazip2 (param def) (param def) - -instance (Default (Value a1), Default (Value a2), Default (Value a3)) => Default (Params (a1, a2, a3)) where - {-# INLINE def #-} - def = - contrazip3 (param def) (param def) (param def) - -instance (Default (Value a1), Default (Value a2), Default (Value a3), Default (Value a4)) => Default (Params (a1, a2, a3, a4)) where - {-# INLINE def #-} - def = - contrazip4 (param def) (param def) (param def) (param def) - -instance (Default (Value a1), Default (Value a2), Default (Value a3), Default (Value a4), Default (Value a5)) => Default (Params (a1, a2, a3, a4, a5)) where - {-# INLINE def #-} - def = - contrazip5 (param def) (param def) (param def) (param def) (param def) - - --- * 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)) - - --- ** Instances -------------------------- - --- | Maps to 'bool'. -instance Default (Value Bool) where - {-# INLINE def #-} - def = - bool - --- | Maps to 'int2'. -instance Default (Value Int16) where - {-# INLINE def #-} - def = - int2 - --- | Maps to 'int4'. -instance Default (Value Int32) where - {-# INLINE def #-} - def = - int4 - --- | Maps to 'int8'. -instance Default (Value Int64) where - {-# INLINE def #-} - def = - int8 - --- | Maps to 'float4'. -instance Default (Value Float) where - {-# INLINE def #-} - def = - float4 - --- | Maps to 'float8'. -instance Default (Value Double) where - {-# INLINE def #-} - def = - float8 - --- | Maps to 'numeric'. -instance Default (Value B.Scientific) where - {-# INLINE def #-} - def = - numeric - --- | Maps to 'char'. -instance Default (Value Char) where - {-# INLINE def #-} - def = - char - --- | Maps to 'text'. -instance Default (Value Text) where - {-# INLINE def #-} - def = - text - --- | Maps to 'bytea'. -instance Default (Value ByteString) where - {-# INLINE def #-} - def = - bytea - --- | Maps to 'date'. -instance Default (Value B.Day) where - {-# INLINE def #-} - def = - date - --- | Maps to 'timestamp'. -instance Default (Value B.LocalTime) where - {-# INLINE def #-} - def = - timestamp - --- | Maps to 'timestamptz'. -instance Default (Value B.UTCTime) where - {-# INLINE def #-} - def = - timestamptz - --- | Maps to 'time'. -instance Default (Value B.TimeOfDay) where - {-# INLINE def #-} - def = - time - --- | Maps to 'timetz'. -instance Default (Value (B.TimeOfDay, B.TimeZone)) where - {-# INLINE def #-} - def = - timetz - --- | Maps to 'interval'. -instance Default (Value B.DiffTime) where - {-# INLINE def #-} - def = - interval - --- | Maps to 'uuid'. -instance Default (Value B.UUID) where - {-# INLINE def #-} - def = - uuid - --- | Maps to 'json'. -instance Default (Value B.Value) where - {-# INLINE def #-} - def = - json - - --- * 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/Decoders.hs b/library/Hasql/Private/Decoders.hs new file mode 100644 --- /dev/null +++ b/library/Hasql/Private/Decoders.hs @@ -0,0 +1,459 @@ +{-| +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 +import qualified Data.Vector.Generic as GenericVector + +-- * 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 noResult #-} +noResult :: Result () +noResult = Result (Results.single Result.noResult) + +{-| +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 = (,,) '<$>' ('column' . 'nullable') 'int8' '<*>' ('column' . 'nonNullable') 'text' '<*>' ('column' . 'nonNullable') '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 Unicode 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))) + +{-| +Lift 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))) + +{-| +Lift an 'Array' decoder to a 'Value' decoder. +-} +{-# INLINABLE array #-} +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') +@ + +Please notice that in case of multidimensional arrays nesting 'listArray' decoder +won't work. You have to explicitly construct the array decoder using 'array'. +-} +{-# 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') +@ + +Please notice that in case of multidimensional arrays nesting 'vectorArray' decoder +won't work. You have to explicitly construct the array decoder using 'array'. +-} +{-# 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. +-} +{-# 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' ('nonNullable' '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' or 'element'. +-} +{-# 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 component 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/library/Hasql/Private/Decoders/Result.hs b/library/Hasql/Private/Decoders/Result.hs --- a/library/Hasql/Private/Decoders/Result.hs +++ b/library/Hasql/Private/Decoders/Result.hs @@ -20,9 +20,9 @@ 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 --- a/library/Hasql/Private/Decoders/Results.hs +++ b/library/Hasql/Private/Decoders/Results.hs @@ -81,4 +81,4 @@ 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/Encoders.hs b/library/Hasql/Private/Encoders.hs new file mode 100644 --- /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' 'int8')) '<>' + ('snd' '>$<' 'param' ('nullable' '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' 'int8')) ('param' ('nullable' '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' 'text')) '<>' + (gender '>$<' 'param' ('nonNullable' genderValue)) '<>' + ('fromIntegral' . age '>$<' 'param' ('nonNullable' 'int8')) + +genderValue :: 'Value' Gender +genderValue = '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 encoder, with its nullability specified, +associating it with a single placeholder. +-} +param :: NullableOrNot Value a -> Params a +param = \ case + NonNullable (Value valueEnc) -> Params (Params.value valueEnc) + Nullable (Value 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 + + +-- * Value +------------------------- + +{-| +Value encoder. +-} +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 Unicode 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)) + +{-| +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) -> 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)) + +{-| +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 to the following expression: + +@ +('array' . 'dimension' 'foldl'' . 'element') +@ + +Please notice that in case of multidimensional arrays nesting 'foldableArray' encoder +won't work. You have to explicitly construct the array encoder using 'array'. +-} +{-# INLINE foldableArray #-} +foldableArray :: Foldable foldable => NullableOrNot Value element -> Value (foldable element) +foldableArray = array . dimension foldl' . element + + +-- * Array +------------------------- + +{-| +Generic array encoder. + +Here's an example of its usage: + +@ +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 +values, thus this encoder is not suited for that. Use a @value = ANY($1)@ condition instead. +-} +newtype Array a = Array (Array.Array a) + deriving (Contravariant) + +{-| +Lifts a 'Value' encoder into an 'Array' encoder. +-} +element :: NullableOrNot Value a -> Array a +element = \ case + NonNullable (Value (Value.Value elementOID arrayOID encoder renderer)) -> + Array (Array.value elementOID arrayOID encoder renderer) + Nullable (Value (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' or 'element'. +-} +{-# INLINABLE dimension #-} +dimension :: (forall a. (a -> b -> a) -> a -> c -> a) -> Array b -> Array c +dimension foldl (Array imp) = Array (Array.dimension foldl imp) diff --git a/library/Hasql/Private/Encoders/Array.hs b/library/Hasql/Private/Encoders/Array.hs --- a/library/Hasql/Private/Encoders/Array.hs +++ b/library/Hasql/Private/Encoders/Array.hs @@ -9,6 +9,10 @@ data Array a = Array B.OID B.OID (Bool -> a -> A.Array) (a -> C.Builder) +instance Contravariant Array where + contramap fn (Array valueOid arrayOid encoder renderer) = + Array valueOid arrayOid (\ intDateTimes -> encoder intDateTimes . fn) (renderer . fn) + {-# INLINE value #-} value :: B.OID -> B.OID -> (Bool -> a -> A.Encoding) -> (a -> C.Builder) -> Array a value valueOID arrayOID encoder = diff --git a/library/Hasql/Private/IO.hs b/library/Hasql/Private/IO.hs --- a/library/Hasql/Private/IO.hs +++ b/library/Hasql/Private/IO.hs @@ -88,7 +88,7 @@ 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/Prelude.hs b/library/Hasql/Private/Prelude.hs --- a/library/Hasql/Private/Prelude.hs +++ b/library/Hasql/Private/Prelude.hs @@ -36,10 +36,6 @@ ------------------------- import Control.Monad.Error.Class as Exports (MonadError (..)) --- data-default-class -------------------------- -import Data.Default.Class as Exports - -- profunctors ------------------------- import Data.Profunctor.Unsafe as Exports @@ -84,6 +80,10 @@ -- loch-th ------------------------- import Debug.Trace.LocationTH as Exports + +-- postgresql-binary +------------------------- +import PostgreSQL.Binary.Data as Exports (UUID) -- custom ------------------------- diff --git a/library/Hasql/Private/Session.hs b/library/Hasql/Private/Session.hs --- a/library/Hasql/Private/Session.hs +++ b/library/Hasql/Private/Session.hs @@ -7,6 +7,7 @@ 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 @@ -39,21 +40,21 @@ 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. 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) diff --git a/library/Hasql/Statement.hs b/library/Hasql/Statement.hs --- a/library/Hasql/Statement.hs +++ b/library/Hasql/Statement.hs @@ -1,47 +1,53 @@ module Hasql.Statement +( + Statement(..), + -- * Recipies + + -- ** Insert many + -- $insertMany + + -- ** IN and NOT IN + -- $inAndNotIn +) where import Hasql.Private.Prelude import qualified Hasql.Decoders as Decoders import qualified Hasql.Encoders as Encoders +{-| +Specification of a strictly single-statement query, which can be parameterized and prepared. --- | --- A specification of a strictly single-statement query, which can be parameterized and prepared. --- --- Consists of the following: --- --- * SQL template, --- * params encoder, --- * result decoder, --- * a flag, determining whether it should be prepared. --- --- 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: --- @$1@, @$2@, @$3@ and etc. --- Those references must be used to refer to the values of the 'Encoders.Params' encoder. --- --- 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') --- @ --- --- The statement above accepts a product of two parameters of type 'Int64' --- and produces a single result of type 'Int64'. --- +Consists of the following: + +* SQL template, +* params encoder, +* result decoder, +* a flag, determining whether it should be prepared. + +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 a positional notation, as in the following: +@$1@, @$2@, @$3@ and etc. +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 a declaration of a prepared statement with its associated codecs. + +@ +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.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' +and produces a single result of type 'Int64'. +-} data Statement a b = Statement ByteString (Encoders.Params a) (Decoders.Result b) Bool @@ -53,3 +59,53 @@ {-# INLINE dimap #-} dimap f1 f2 (Statement template encoder decoder preparable) = Statement template (contramap f1 encoder) (fmap f2 decoder) preparable + + +{- $insertMany + +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.dimension' 'foldl'' . + Encoders.'Encoders.element' . + Encoders.'Encoders.nonNullable' + decoder = Decoders.'Decoders.noResult' +@ + +This approach is much more efficient than executing a single-row Insert +statement multiple times. +-} + +{- $inAndNotIn + +There is a common misconception that Postgresql supports array +as a parameter for the @IN@ operator. +However Postgres only supports a syntactical list of values with it, +i.e., you have to specify each option as an individual parameter +(@something IN ($1, $2, $3)@). + +Clearly it would be much more convenient to provide an array as a single parameter, +but the @IN@ operator does not support that. +Fortunately, Postgres does provide such functionality with other operators: + +* Use @something = ANY($1)@ instead of @something IN ($1)@ +* Use @something <> ALL($1)@ instead of @something NOT IN ($1)@ + +For details see +. +-} diff --git a/profiling/Main.hs b/profiling/Main.hs --- a/profiling/Main.hs +++ b/profiling/Main.hs @@ -70,7 +70,7 @@ 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 @@ 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 --- a/tasty/Main.hs +++ b/tasty/Main.hs @@ -22,6 +22,26 @@ 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 = @@ -29,10 +49,10 @@ 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.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 @@ -47,9 +67,9 @@ 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)) + fmap (maybe False (const True)) (Decoders.rowMaybe ((Decoders.column . Decoders.nonNullable) Decoders.bool)) session = do result1 <- Session.statement [1, 2] statement @@ -65,9 +85,9 @@ 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)) + fmap (maybe False (const True)) (Decoders.rowMaybe ((Decoders.column . Decoders.nonNullable) Decoders.bool)) session = do result1 <- Session.statement [1, 2] statement @@ -85,9 +105,9 @@ sql = "select (1, true)" encoder = - Encoders.unit + 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 @@ -102,17 +122,17 @@ sql = "select (1, true) as entity1, ('hello', 3) as entity2" encoder = - Encoders.unit + 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 @@ -135,9 +155,9 @@ sql = "select array[]::int8[]" encoder = - Encoders.unit + 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" $ @@ -162,9 +182,9 @@ sql = "absurd" encoder = - Encoders.unit + mempty decoder = - Decoders.unit + Decoders.noResult in io , testCase "Prepared statements after error" $ @@ -185,9 +205,9 @@ sql = "select $1 :: int8" encoder = - Encoders.param Encoders.int8 + Encoders.param (Encoders.nonNullable (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 @@ -201,10 +221,10 @@ sql = "select ($1 + $2)" encoder = - contramap fst (Encoders.param Encoders.int8) <> - contramap snd (Encoders.param Encoders.int8) + contramap fst (Encoders.param (Encoders.nonNullable (Encoders.int8))) <> + contramap snd (Encoders.param (Encoders.nonNullable (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" @@ -226,10 +246,10 @@ sql = "select ($1 + $2)" encoder = - contramap fst (Encoders.param Encoders.int8) <> - contramap snd (Encoders.param Encoders.int8) + contramap fst (Encoders.param (Encoders.nonNullable (Encoders.int8))) <> + contramap snd (Encoders.param (Encoders.nonNullable (Encoders.int8))) decoder = - Decoders.singleRow (Decoders.column Decoders.int8) + Decoders.singleRow ((Decoders.column . Decoders.nonNullable) Decoders.int8) session :: Session.Session Int64 session = do @@ -253,9 +273,9 @@ 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.interval) + Encoders.param (Encoders.nonNullable (Encoders.interval)) in DSL.statement (10 :: DiffTime) statement in actualIO >>= \x -> assertEqual (show x) (Right True) x , @@ -270,9 +290,9 @@ sql = "select interval '10 seconds'" decoder = - (Decoders.singleRow (Decoders.column (Decoders.interval))) + (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.interval))) encoder = - Encoders.unit + Encoders.noParams in DSL.statement () statement in actualIO >>= \x -> assertEqual (show x) (Right (10 :: DiffTime)) x , @@ -287,9 +307,9 @@ sql = "select $1" decoder = - (Decoders.singleRow (Decoders.column (Decoders.interval))) + (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.interval))) encoder = - Encoders.param (Encoders.interval) + Encoders.param (Encoders.nonNullable (Encoders.interval)) in DSL.statement (10 :: DiffTime) statement in actualIO >>= \x -> assertEqual (show x) (Right (10 :: DiffTime)) x , @@ -299,14 +319,14 @@ 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')" @@ -318,9 +338,9 @@ sql = "select $1 = ('ok' :: mood)" decoder = - (Decoders.singleRow (Decoders.column (Decoders.bool))) + (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.bool))) encoder = - Encoders.param (Encoders.unknown) + Encoders.param (Encoders.nonNullable (Encoders.unknown)) in DSL.statement "ok" statement in actualIO >>= assertEqual "" (Right True) , @@ -330,14 +350,14 @@ 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;" @@ -349,9 +369,9 @@ 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.unknown) + contramany (Encoders.param (Encoders.nonNullable (Encoders.unknown))) in DSL.statement ["1", "2", "4", "5", "6"] statement in actualIO >>= assertEqual "" (Right "3456") , @@ -361,14 +381,14 @@ 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')" @@ -380,9 +400,9 @@ 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.enum id) + Encoders.param (Encoders.nonNullable ((Encoders.enum id))) in DSL.statement "ok" statement in actualIO >>= assertEqual "" (Right "ok") , @@ -400,9 +420,9 @@ sql = "select $1" encoder = - Encoders.param Encoders.text + Encoders.param (Encoders.nonNullable (Encoders.text)) decoder = - (Decoders.singleRow (Decoders.column (Decoders.text))) + (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.text))) effect2 = DSL.statement 1 statement where @@ -412,9 +432,9 @@ sql = "select $1" encoder = - Encoders.param Encoders.int8 + Encoders.param (Encoders.nonNullable (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)) , @@ -438,7 +458,7 @@ DSL.statement () $ Statements.plain $ "insert into a (name) values ('a')" deleteRows = - DSL.statement () $ Statement.Statement sql def decoder False + DSL.statement () $ Statement.Statement sql mempty decoder False where sql = "delete from a" @@ -452,8 +472,8 @@ 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" def (Decoders.singleRow (Decoders.column Decoders.int4)) False - id2 <- DSL.statement () $ Statement.Statement "insert into a (v) values ('b') returning id" def (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/Prelude.hs b/tasty/Main/Prelude.hs --- a/tasty/Main/Prelude.hs +++ b/tasty/Main/Prelude.hs @@ -8,7 +8,3 @@ -- rerebase ------------------------- import Prelude as Exports - --- data-default-class -------------------------- -import Data.Default.Class as Exports diff --git a/tasty/Main/Statements.hs b/tasty/Main/Statements.hs --- a/tasty/Main/Statements.hs +++ b/tasty/Main/Statements.hs @@ -1,19 +1,15 @@ module Main.Statements where -import Main.Prelude hiding (def) +import Main.Prelude import qualified Hasql.Statement as HQ import qualified Hasql.Encoders as HE import qualified Hasql.Decoders as HD import qualified Main.Prelude as Prelude -def :: ByteString -> HQ.Statement () () -def sql = - HQ.Statement sql Prelude.def Prelude.def False - 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 = @@ -33,4 +29,4 @@ 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) diff --git a/threads-test/Main/Statements.hs b/threads-test/Main/Statements.hs --- a/threads-test/Main/Statements.hs +++ b/threads-test/Main/Statements.hs @@ -13,8 +13,8 @@ sql = "select pg_sleep($1)" encoder = - E.param E.float8 + E.param (E.nonNullable E.float8) decoder = - D.unit + D.noResult