packages feed

hasql 1.5.0.4 → 1.5.0.5

raw patch · 35 files changed

+1670/−1815 lines, 35 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

benchmarks/Main.hs view
@@ -1,15 +1,14 @@ module Main where -import Prelude+import qualified Data.Vector as F import Gauge import Gauge.Main import qualified Hasql.Connection as A-import qualified Hasql.Session as B-import qualified Hasql.Statement as C import qualified Hasql.Decoders as D import qualified Hasql.Encoders as E-import qualified Data.Vector as F-+import qualified Hasql.Session as B+import qualified Hasql.Statement as C+import Prelude  main =   do@@ -20,22 +19,18 @@       A.acquire ""     useConnection connection =       defaultMain-      [-        sessionBench "largeResultInVector" sessionWithSingleLargeResultInVector-        ,-        sessionBench "largeResultInList" sessionWithSingleLargeResultInList-        ,-        sessionBench "manyLargeResults" sessionWithManyLargeResults-        ,-        sessionBench "manySmallResults" sessionWithManySmallResults-      ]+        [ sessionBench "largeResultInVector" sessionWithSingleLargeResultInVector,+          sessionBench "largeResultInList" sessionWithSingleLargeResultInList,+          sessionBench "manyLargeResults" sessionWithManyLargeResults,+          sessionBench "manySmallResults" sessionWithManySmallResults+        ]       where         sessionBench :: NFData a => String -> B.Session a -> Benchmark         sessionBench name session =           bench name (nfIO (fmap (either (error "") id) (B.run session connection))) - -- * Sessions+ -------------------------  sessionWithManySmallParameters :: Vector (Int64, Int64) -> B.Session ()@@ -58,8 +53,8 @@ sessionWithManySmallResults =   replicateM 1000 (B.statement () statementWithSingleRow) - -- * Statements+ -------------------------  statementWithManyParameters :: C.Statement (Vector (Int64, Int64)) ()
hasql.cabal view
@@ -1,5 +1,5 @@ name: hasql-version: 1.5.0.4+version: 1.5.0.5 category: Hasql, Database, PostgreSQL synopsis: An efficient PostgreSQL driver with a flexible mapping API description:
library/Hasql/Connection.hs view
@@ -1,15 +1,14 @@ -- | -- This module provides a low-level effectful API dealing with the connections to the database. module Hasql.Connection-(-  Connection,-  ConnectionError(..),-  acquire,-  release,-  Settings,-  settings,-  withLibPQConnection-)+  ( Connection,+    ConnectionError (..),+    acquire,+    release,+    Settings,+    settings,+    withLibPQConnection,+  ) where  import Hasql.Private.Connection
library/Hasql/Decoders.hs view
@@ -1,67 +1,72 @@-{-|-A DSL for declaration of result decoders.--}+-- |+-- A DSL for declaration of result decoders. module Hasql.Decoders-(-  -- * Result-  Result,-  noResult,-  rowsAffected,-  singleRow,-  -- ** Specialized multi-row results-  rowMaybe,-  rowVector,-  rowList,-  -- ** Multi-row traversers-  foldlRows,-  foldrRows,-  -- * Row-  Row,-  column,-  -- * Nullability-  NullableOrNot,-  nonNullable,-  nullable,-  -- * Value-  Value,-  bool,-  int2,-  int4,-  int8,-  float4,-  float8,-  numeric,-  char,-  text,-  bytea,-  date,-  timestamp,-  timestamptz,-  time,-  timetz,-  interval,-  uuid,-  inet,-  json,-  jsonBytes,-  jsonb,-  jsonbBytes,-  array,-  listArray,-  vectorArray,-  composite,-  hstore,-  enum,-  custom,-  refine,-  -- * Array-  Array,-  dimension,-  element,-  -- * Composite-  Composite,-  field,-)+  ( -- * Result+    Result,+    noResult,+    rowsAffected,+    singleRow,++    -- ** Specialized multi-row results+    rowMaybe,+    rowVector,+    rowList,++    -- ** Multi-row traversers+    foldlRows,+    foldrRows,++    -- * Row+    Row,+    column,++    -- * Nullability+    NullableOrNot,+    nonNullable,+    nullable,++    -- * Value+    Value,+    bool,+    int2,+    int4,+    int8,+    float4,+    float8,+    numeric,+    char,+    text,+    bytea,+    date,+    timestamp,+    timestamptz,+    time,+    timetz,+    interval,+    uuid,+    inet,+    json,+    jsonBytes,+    jsonb,+    jsonbBytes,+    array,+    listArray,+    vectorArray,+    composite,+    hstore,+    enum,+    custom,+    refine,++    -- * Array+    Array,+    dimension,+    element,++    -- * Composite+    Composite,+    field,+  ) where  import Hasql.Private.Decoders
library/Hasql/Encoders.hs view
@@ -1,52 +1,53 @@-{-|-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.--}+-- |+-- 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-(-  -- * Parameters product-  Params,-  noParams,-  param,-  -- * Nullability-  NullableOrNot,-  nonNullable,-  nullable,-  -- * Value-  Value,-  bool,-  int2,-  int4,-  int8,-  float4,-  float8,-  numeric,-  char,-  text,-  bytea,-  date,-  timestamp,-  timestamptz,-  time,-  timetz,-  interval,-  uuid,-  inet,-  json,-  jsonBytes,-  jsonb,-  jsonbBytes,-  enum,-  unknown,-  array,-  foldableArray,-  -- * Array-  Array,-  element,-  dimension,-)+  ( -- * Parameters product+    Params,+    noParams,+    param,++    -- * Nullability+    NullableOrNot,+    nonNullable,+    nullable,++    -- * Value+    Value,+    bool,+    int2,+    int4,+    int8,+    float4,+    float8,+    numeric,+    char,+    text,+    bytea,+    date,+    timestamp,+    timestamptz,+    time,+    timetz,+    interval,+    uuid,+    inet,+    json,+    jsonBytes,+    jsonb,+    jsonbBytes,+    enum,+    unknown,+    array,+    foldableArray,++    -- * Array+    Array,+    element,+    dimension,+  ) where  import Hasql.Private.Encoders
library/Hasql/Private/Commands.hs view
@@ -1,20 +1,18 @@ module Hasql.Private.Commands-(-  Commands,-  asBytes,-  setEncodersToUTF8,-  setMinClientMessagesToWarning,-)+  ( Commands,+    asBytes,+    setEncodersToUTF8,+    setMinClientMessagesToWarning,+  ) where -import Hasql.Private.Prelude import qualified Data.ByteString as B import qualified Data.ByteString.Builder as BB import qualified Data.ByteString.Lazy as BL-+import Hasql.Private.Prelude -newtype Commands =-  Commands (DList BB.Builder)+newtype Commands+  = Commands (DList BB.Builder)   deriving (Semigroup, Monoid)  asBytes :: Commands -> ByteString
library/Hasql/Private/Connection.hs view
@@ -1,19 +1,17 @@ -- | -- This module provides a low-level effectful API dealing with the connections to the database.-module Hasql.Private.Connection-where+module Hasql.Private.Connection where -import Hasql.Private.Prelude import qualified Database.PostgreSQL.LibPQ as LibPQ-import qualified Hasql.Private.PreparedStatementRegistry as PreparedStatementRegistry import qualified Hasql.Private.IO as IO+import Hasql.Private.Prelude+import qualified Hasql.Private.PreparedStatementRegistry as PreparedStatementRegistry import qualified Hasql.Private.Settings as Settings - -- | -- A single connection to the database.-data Connection =-  Connection !(MVar LibPQ.Connection) !Bool !PreparedStatementRegistry.PreparedStatementRegistry+data Connection+  = Connection !(MVar LibPQ.Connection) !Bool !PreparedStatementRegistry.PreparedStatementRegistry  -- | -- Possible details of the connection acquistion error.
library/Hasql/Private/Decoders.hs view
@@ -1,53 +1,48 @@-{-|-A DSL for declaration of result decoders.--}-module Hasql.Private.Decoders-where+-- |+-- 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 Data.Vector.Generic as GenericVector+import qualified Hasql.Private.Decoders.Array as Array+import qualified Hasql.Private.Decoders.Composite as Composite import qualified Hasql.Private.Decoders.Result as Result+import qualified Hasql.Private.Decoders.Results as Results 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.Errors as Errors+import Hasql.Private.Prelude hiding (bool, maybe) import qualified Hasql.Private.Prelude as Prelude-import qualified Data.Vector.Generic as GenericVector+import qualified PostgreSQL.Binary.Data as B+import qualified PostgreSQL.Binary.Decoding as A  -- * Result+ ------------------------- -{-|-Decoder of a query 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 #-}+-- |+-- Decode no value from the result.+--+-- Useful for statements like @INSERT@ or @CREATE@.+{-# INLINEABLE noResult #-} noResult :: Result () noResult = Result (Results.single Result.noResult) -{-|-Get the amount of rows affected by such statements as-@UPDATE@ or @DELETE@.--}-{-# INLINABLE rowsAffected #-}+-- |+-- Get the amount of rows affected by such statements as+-- @UPDATE@ or @DELETE@.+{-# INLINEABLE rowsAffected #-} rowsAffected :: Result Int64 rowsAffected = Result (Results.single Result.rowsAffected) -{-|-Exactly one row.-Will raise the 'Errors.UnexpectedAmountOfRows' error if it's any other.--}-{-# INLINABLE singleRow #-}+-- |+-- Exactly one row.+-- Will raise the 'Errors.UnexpectedAmountOfRows' error if it's any other.+{-# INLINEABLE singleRow #-} singleRow :: Row a -> Result a singleRow (Row row) = Result (Results.single (Result.single row)) @@ -55,418 +50,375 @@ refineResult refiner (Result results) = Result (Results.refine refiner results)  -- ** Multi-row traversers+ ------------------------- -{-|-Foldl multiple rows.--}-{-# INLINABLE foldlRows #-}+-- |+-- Foldl multiple rows.+{-# INLINEABLE 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 #-}+-- |+-- Foldr multiple rows.+{-# INLINEABLE 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 #-}+-- |+-- Maybe one row or none.+{-# INLINEABLE 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 #-}+-- |+-- Zero or more rows packed into the vector.+--+-- It's recommended to prefer this function to 'rowList',+-- since it performs notably better.+{-# INLINEABLE 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 #-}+-- |+-- Zero or more rows packed into the list.+{-# INLINEABLE 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'-@--}+-- |+-- 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, MonadFail) -{-|-Lift an individual value decoder to a composable row decoder.--}-{-# INLINABLE column #-}+-- |+-- Lift an individual value decoder to a composable row decoder.+{-# INLINEABLE column #-} column :: NullableOrNot Value a -> Row a-column = \ case+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.--}+-- |+-- 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.--}+-- |+-- 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.--}+-- |+-- Specify that a decoder produces a nullable value. nullable :: decoder a -> NullableOrNot decoder (Maybe a) nullable = Nullable - -- * Value+ ------------------------- -{-|-Decoder of a value.--}+-- |+-- Decoder of a value. newtype Value a = Value (Value.Value a)   deriving (Functor)  type role Value representational -{-|-Decoder of the @BOOL@ values.--}-{-# INLINABLE bool #-}+-- |+-- Decoder of the @BOOL@ values.+{-# INLINEABLE bool #-} bool :: Value Bool bool = Value (Value.decoder (const A.bool)) -{-|-Decoder of the @INT2@ values.--}-{-# INLINABLE int2 #-}+-- |+-- Decoder of the @INT2@ values.+{-# INLINEABLE int2 #-} int2 :: Value Int16 int2 = Value (Value.decoder (const A.int)) -{-|-Decoder of the @INT4@ values.--}-{-# INLINABLE int4 #-}+-- |+-- Decoder of the @INT4@ values.+{-# INLINEABLE int4 #-} int4 :: Value Int32 int4 = Value (Value.decoder (const A.int)) -{-|-Decoder of the @INT8@ values.--}-{-# INLINABLE int8 #-}+-- |+-- Decoder of the @INT8@ values.+{-# INLINEABLE int8 #-} int8 :: Value Int64-int8 = {-# SCC "int8" #-}+int8 =+  {-# SCC "int8" #-}   Value (Value.decoder (const ({-# SCC "int8.int" #-} A.int))) -{-|-Decoder of the @FLOAT4@ values.--}-{-# INLINABLE float4 #-}+-- |+-- Decoder of the @FLOAT4@ values.+{-# INLINEABLE float4 #-} float4 :: Value Float float4 = Value (Value.decoder (const A.float4)) -{-|-Decoder of the @FLOAT8@ values.--}-{-# INLINABLE float8 #-}+-- |+-- Decoder of the @FLOAT8@ values.+{-# INLINEABLE float8 #-} float8 :: Value Double float8 = Value (Value.decoder (const A.float8)) -{-|-Decoder of the @NUMERIC@ values.--}-{-# INLINABLE numeric #-}+-- |+-- Decoder of the @NUMERIC@ values.+{-# INLINEABLE 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 #-}+-- |+-- Decoder of the @CHAR@ values.+-- Note that it supports Unicode values.+{-# INLINEABLE char #-} char :: Value Char char = Value (Value.decoder (const A.char)) -{-|-Decoder of the @TEXT@ values.--}-{-# INLINABLE text #-}+-- |+-- Decoder of the @TEXT@ values.+{-# INLINEABLE text #-} text :: Value Text text = Value (Value.decoder (const A.text_strict)) -{-|-Decoder of the @BYTEA@ values.--}-{-# INLINABLE bytea #-}+-- |+-- Decoder of the @BYTEA@ values.+{-# INLINEABLE bytea #-} bytea :: Value ByteString bytea = Value (Value.decoder (const A.bytea_strict)) -{-|-Decoder of the @DATE@ values.--}-{-# INLINABLE date #-}+-- |+-- Decoder of the @DATE@ values.+{-# INLINEABLE date #-} date :: Value B.Day date = Value (Value.decoder (const A.date)) -{-|-Decoder of the @TIMESTAMP@ values.--}-{-# INLINABLE timestamp #-}+-- |+-- Decoder of the @TIMESTAMP@ values.+{-# INLINEABLE 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 #-}+-- |+-- 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.+{-# INLINEABLE timestamptz #-} timestamptz :: Value B.UTCTime timestamptz = Value (Value.decoder (Prelude.bool A.timestamptz_float A.timestamptz_int)) -{-|-Decoder of the @TIME@ values.--}-{-# INLINABLE time #-}+-- |+-- Decoder of the @TIME@ values.+{-# INLINEABLE 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 #-}+-- |+-- 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.+{-# INLINEABLE 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 #-}+-- |+-- Decoder of the @INTERVAL@ values.+{-# INLINEABLE interval #-} interval :: Value B.DiffTime interval = Value (Value.decoder (Prelude.bool A.interval_float A.interval_int)) -{-|-Decoder of the @UUID@ values.--}-{-# INLINABLE uuid #-}+-- |+-- Decoder of the @UUID@ values.+{-# INLINEABLE uuid #-} uuid :: Value B.UUID uuid = Value (Value.decoder (const A.uuid)) -{-|-Decoder of the @INET@ values.--}-{-# INLINABLE inet #-}+-- |+-- Decoder of the @INET@ values.+{-# INLINEABLE 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 #-}+-- |+-- Decoder of the @JSON@ values into a JSON AST.+{-# INLINEABLE 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 #-}+-- |+-- Decoder of the @JSON@ values into a raw JSON 'ByteString'.+{-# INLINEABLE 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 #-}+-- |+-- Decoder of the @JSONB@ values into a JSON AST.+{-# INLINEABLE 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 #-}+-- |+-- Decoder of the @JSONB@ values into a raw JSON 'ByteString'.+{-# INLINEABLE 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 #-}+-- |+-- Lift a custom value decoder function to a 'Value' decoder.+{-# INLINEABLE custom #-} custom :: (Bool -> ByteString -> Either Text a) -> Value a custom fn = Value (Value.decoderFn fn) -{-|-Refine a value decoder, lifting the possible error to the session level.--}-{-# INLINABLE refine #-}+-- |+-- Refine a value decoder, lifting the possible error to the session level.+{-# INLINEABLE refine #-} refine :: (a -> Either Text b) -> Value a -> Value b refine fn (Value v) = Value (Value.Value (\b -> A.refine fn (Value.run v b))) -{-|-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 #-}+-- |+-- 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'+-- @+{-# INLINEABLE 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.--}+-- |+-- 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 #-}+-- |+-- Lift an 'Array' decoder to a 'Value' decoder.+{-# INLINEABLE 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'.--}+-- |+-- 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'.--}+-- |+-- 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 #-}+-- |+-- Lift a 'Composite' decoder to a 'Value' decoder.+{-# INLINEABLE 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'))))-@--}+-- |+-- 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 #-}+-- |+-- 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'.+{-# INLINEABLE 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 #-}+-- |+-- Lift a 'Value' decoder into an 'Array' decoder for parsing of leaf values.+{-# INLINEABLE element #-} element :: NullableOrNot Value a -> Array a-element = \ case+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).--}+-- |+-- Composable decoder of composite values (rows, records). newtype Composite a = Composite (Composite.Composite a)   deriving (Functor, Applicative, Monad, MonadFail) -{-|-Lift a 'Value' decoder into a 'Composite' decoder for parsing of component values.--}+-- |+-- Lift a 'Value' decoder into a 'Composite' decoder for parsing of component values. field :: NullableOrNot Value a -> Composite a-field = \ case+field = \case   NonNullable (Value imp) -> Composite (Composite.nonNullValue (Value.run imp))   Nullable (Value imp) -> Composite (Composite.value (Value.run imp))
library/Hasql/Private/Decoders/Array.hs view
@@ -3,9 +3,8 @@ import Hasql.Private.Prelude import qualified PostgreSQL.Binary.Decoding as A --newtype Array a =-  Array (ReaderT Bool A.Array a)+newtype Array a+  = Array (ReaderT Bool A.Array a)   deriving (Functor)  {-# INLINE run #-}@@ -27,4 +26,3 @@ nonNullValue :: (Bool -> A.Value a) -> Array a nonNullValue decoder' =   Array $ ReaderT $ A.valueArray . decoder'-
library/Hasql/Private/Decoders/Composite.hs view
@@ -3,9 +3,8 @@ import Hasql.Private.Prelude import qualified PostgreSQL.Binary.Decoding as A --newtype Composite a =-  Composite (ReaderT Bool A.Composite a)+newtype Composite a+  = Composite (ReaderT Bool A.Composite a)   deriving (Functor, Applicative, Monad, MonadFail)  {-# INLINE run #-}@@ -22,4 +21,3 @@ nonNullValue :: (Bool -> A.Value a) -> Composite a nonNullValue decoder' =   Composite $ ReaderT $ A.valueComposite . decoder'-
library/Hasql/Private/Decoders/Result.hs view
@@ -1,18 +1,17 @@ module Hasql.Private.Decoders.Result where -import Hasql.Private.Prelude hiding (maybe, many)-import Hasql.Private.Errors-import qualified Database.PostgreSQL.LibPQ as LibPQ-import qualified Hasql.Private.Decoders.Row as Row import qualified Data.Attoparsec.ByteString.Char8 as Attoparsec import qualified Data.ByteString as ByteString-import qualified Hasql.Private.Prelude as Prelude import qualified Data.Vector as Vector import qualified Data.Vector.Mutable as MutableVector-+import qualified Database.PostgreSQL.LibPQ as LibPQ+import qualified Hasql.Private.Decoders.Row as Row+import Hasql.Private.Errors+import Hasql.Private.Prelude hiding (many, maybe)+import qualified Hasql.Private.Prelude as Prelude -newtype Result a =-  Result (ReaderT (Bool, LibPQ.Result) (ExceptT ResultError IO) a)+newtype Result a+  = Result (ReaderT (Bool, LibPQ.Result) (ExceptT ResultError IO) a)   deriving (Functor, Applicative, Monad)  {-# INLINE run #-}@@ -35,8 +34,10 @@     checkExecStatus $ \case       LibPQ.CommandOk -> True       _ -> False-    Result $ ReaderT $ \(_, result) -> ExceptT $-      LibPQ.cmdTuples result & fmap cmdTuplesReader+    Result $+      ReaderT $ \(_, result) ->+        ExceptT $+          LibPQ.cmdTuples result & fmap cmdTuplesReader   where     cmdTuplesReader =       notNothing >=> notEmpty >=> decimal@@ -49,36 +50,37 @@             else Right bytes         decimal bytes =           mapLeft (\m -> UnexpectedResult ("Decimal parsing failure: " <> fromString m)) $-          Attoparsec.parseOnly (Attoparsec.decimal <* Attoparsec.endOfInput) bytes+            Attoparsec.parseOnly (Attoparsec.decimal <* Attoparsec.endOfInput) bytes  {-# INLINE checkExecStatus #-} checkExecStatus :: (LibPQ.ExecStatus -> Bool) -> Result () checkExecStatus predicate =-  {-# SCC "checkExecStatus" #-} +  {-# SCC "checkExecStatus" #-}   do     status <- Result $ ReaderT $ \(_, result) -> lift $ LibPQ.resultStatus result     unless (predicate status) $ do       case status of-        LibPQ.BadResponse   -> serverError+        LibPQ.BadResponse -> serverError         LibPQ.NonfatalError -> serverError-        LibPQ.FatalError    -> serverError+        LibPQ.FatalError -> serverError         _ -> Result $ lift $ ExceptT $ pure $ Left $ UnexpectedResult $ "Unexpected result status: " <> (fromString $ show status)  {-# INLINE serverError #-} serverError :: Result () serverError =-  Result $ ReaderT $ \(_, result) -> ExceptT $ do-    code <- -      fmap fold $-      LibPQ.resultErrorField result LibPQ.DiagSqlstate-    message <- -      fmap fold $-      LibPQ.resultErrorField result LibPQ.DiagMessagePrimary-    detail <- -      LibPQ.resultErrorField result LibPQ.DiagMessageDetail-    hint <- -      LibPQ.resultErrorField result LibPQ.DiagMessageHint-    pure $ Left $ ServerError code message detail hint+  Result $+    ReaderT $ \(_, result) -> ExceptT $ do+      code <-+        fmap fold $+          LibPQ.resultErrorField result LibPQ.DiagSqlstate+      message <-+        fmap fold $+          LibPQ.resultErrorField result LibPQ.DiagMessagePrimary+      detail <-+        LibPQ.resultErrorField result LibPQ.DiagMessageDetail+      hint <-+        LibPQ.resultErrorField result LibPQ.DiagMessageHint+      pure $ Left $ ServerError code message detail hint  {-# INLINE maybe #-} maybe :: Row.Row a -> Result (Maybe a)@@ -87,15 +89,16 @@     checkExecStatus $ \case       LibPQ.TuplesOk -> True       _ -> False-    Result $ ReaderT $ \(integerDatetimes, result) -> ExceptT $ do-      maxRows <- LibPQ.ntuples result-      case maxRows of-        0 -> return (Right Nothing)-        1 -> do-          maxCols <- LibPQ.nfields result-          let fromRowError (col, err) = RowError 0 col err-          fmap (fmap Just . mapLeft fromRowError) $ Row.run rowDec (result, 0, maxCols, integerDatetimes)-        _ -> return (Left (UnexpectedAmountOfRows (rowToInt maxRows)))+    Result $+      ReaderT $ \(integerDatetimes, result) -> ExceptT $ do+        maxRows <- LibPQ.ntuples result+        case maxRows of+          0 -> return (Right Nothing)+          1 -> do+            maxCols <- LibPQ.nfields result+            let fromRowError (col, err) = RowError 0 col err+            fmap (fmap Just . mapLeft fromRowError) $ Row.run rowDec (result, 0, maxCols, integerDatetimes)+          _ -> return (Left (UnexpectedAmountOfRows (rowToInt maxRows)))   where     rowToInt (LibPQ.Row n) =       fromIntegral n@@ -109,14 +112,15 @@     checkExecStatus $ \case       LibPQ.TuplesOk -> True       _ -> False-    Result $ ReaderT $ \(integerDatetimes, result) -> ExceptT $ do-      maxRows <- LibPQ.ntuples result-      case maxRows of-        1 -> do-          maxCols <- LibPQ.nfields result-          let fromRowError (col, err) = RowError 0 col err-          fmap (mapLeft fromRowError) $ Row.run rowDec (result, 0, maxCols, integerDatetimes)-        _ -> return (Left (UnexpectedAmountOfRows (rowToInt maxRows)))+    Result $+      ReaderT $ \(integerDatetimes, result) -> ExceptT $ do+        maxRows <- LibPQ.ntuples result+        case maxRows of+          1 -> do+            maxCols <- LibPQ.nfields result+            let fromRowError (col, err) = RowError 0 col err+            fmap (mapLeft fromRowError) $ Row.run rowDec (result, 0, maxCols, integerDatetimes)+          _ -> return (Left (UnexpectedAmountOfRows (rowToInt maxRows)))   where     rowToInt (LibPQ.Row n) =       fromIntegral n@@ -130,19 +134,20 @@     checkExecStatus $ \case       LibPQ.TuplesOk -> True       _ -> False-    Result $ ReaderT $ \(integerDatetimes, result) -> ExceptT $ do-      maxRows <- LibPQ.ntuples result-      maxCols <- LibPQ.nfields result-      mvector <- MutableVector.unsafeNew (rowToInt maxRows)-      failureRef <- newIORef Nothing-      forMFromZero_ (rowToInt maxRows) $ \rowIndex -> do-        rowResult <- Row.run rowDec (result, intToRow rowIndex, maxCols, integerDatetimes)-        case rowResult of-          Left !(!colIndex,!x) -> writeIORef failureRef (Just (RowError rowIndex colIndex x))-          Right !x -> MutableVector.unsafeWrite mvector rowIndex x-      readIORef failureRef >>= \case-        Nothing -> Right <$> Vector.unsafeFreeze mvector-        Just x -> pure (Left x)+    Result $+      ReaderT $ \(integerDatetimes, result) -> ExceptT $ do+        maxRows <- LibPQ.ntuples result+        maxCols <- LibPQ.nfields result+        mvector <- MutableVector.unsafeNew (rowToInt maxRows)+        failureRef <- newIORef Nothing+        forMFromZero_ (rowToInt maxRows) $ \rowIndex -> do+          rowResult <- Row.run rowDec (result, intToRow rowIndex, maxCols, integerDatetimes)+          case rowResult of+            Left !(!colIndex, !x) -> writeIORef failureRef (Just (RowError rowIndex colIndex x))+            Right !x -> MutableVector.unsafeWrite mvector rowIndex x+        readIORef failureRef >>= \case+          Nothing -> Right <$> Vector.unsafeFreeze mvector+          Just x -> pure (Left x)   where     rowToInt (LibPQ.Row n) =       fromIntegral n@@ -152,24 +157,28 @@ {-# INLINE foldl #-} foldl :: (a -> b -> a) -> a -> Row.Row b -> Result a foldl step init rowDec =-  {-# SCC "foldl" #-} +  {-# SCC "foldl" #-}   do     checkExecStatus $ \case       LibPQ.TuplesOk -> True       _ -> False-    Result $ ReaderT $ \(integerDatetimes, result) -> ExceptT $ {-# SCC "traversal" #-} do-      maxRows <- LibPQ.ntuples result-      maxCols <- LibPQ.nfields result-      accRef <- newIORef init-      failureRef <- newIORef Nothing-      forMFromZero_ (rowToInt maxRows) $ \rowIndex -> do-        rowResult <- Row.run rowDec (result, intToRow rowIndex, maxCols, integerDatetimes)-        case rowResult of-          Left !(!colIndex,!x) -> writeIORef failureRef (Just (RowError rowIndex colIndex x))-          Right !x -> modifyIORef' accRef (\acc -> step acc x)-      readIORef failureRef >>= \case-        Nothing -> Right <$> readIORef accRef-        Just x -> pure (Left x)+    Result $+      ReaderT $ \(integerDatetimes, result) ->+        ExceptT $+          {-# SCC "traversal" #-}+          do+            maxRows <- LibPQ.ntuples result+            maxCols <- LibPQ.nfields result+            accRef <- newIORef init+            failureRef <- newIORef Nothing+            forMFromZero_ (rowToInt maxRows) $ \rowIndex -> do+              rowResult <- Row.run rowDec (result, intToRow rowIndex, maxCols, integerDatetimes)+              case rowResult of+                Left !(!colIndex, !x) -> writeIORef failureRef (Just (RowError rowIndex colIndex x))+                Right !x -> modifyIORef' accRef (\acc -> step acc x)+            readIORef failureRef >>= \case+              Nothing -> Right <$> readIORef accRef+              Just x -> pure (Left x)   where     rowToInt (LibPQ.Row n) =       fromIntegral n@@ -179,24 +188,25 @@ {-# INLINE foldr #-} foldr :: (b -> a -> a) -> a -> Row.Row b -> Result a foldr step init rowDec =-  {-# SCC "foldr" #-} +  {-# SCC "foldr" #-}   do     checkExecStatus $ \case       LibPQ.TuplesOk -> True       _ -> False-    Result $ ReaderT $ \(integerDatetimes, result) -> ExceptT $ do-      maxRows <- LibPQ.ntuples result-      maxCols <- LibPQ.nfields result-      accRef <- newIORef init-      failureRef <- newIORef Nothing-      forMToZero_ (rowToInt maxRows) $ \rowIndex -> do-        rowResult <- Row.run rowDec (result, intToRow rowIndex, maxCols, integerDatetimes)-        case rowResult of-          Left !(!colIndex,!x) -> writeIORef failureRef (Just (RowError rowIndex colIndex x))-          Right !x -> modifyIORef accRef (\acc -> step x acc)-      readIORef failureRef >>= \case-        Nothing -> Right <$> readIORef accRef-        Just x -> pure (Left x)+    Result $+      ReaderT $ \(integerDatetimes, result) -> ExceptT $ do+        maxRows <- LibPQ.ntuples result+        maxCols <- LibPQ.nfields result+        accRef <- newIORef init+        failureRef <- newIORef Nothing+        forMToZero_ (rowToInt maxRows) $ \rowIndex -> do+          rowResult <- Row.run rowDec (result, intToRow rowIndex, maxCols, integerDatetimes)+          case rowResult of+            Left !(!colIndex, !x) -> writeIORef failureRef (Just (RowError rowIndex colIndex x))+            Right !x -> modifyIORef accRef (\acc -> step x acc)+        readIORef failureRef >>= \case+          Nothing -> Right <$> readIORef accRef+          Just x -> pure (Left x)   where     rowToInt (LibPQ.Row n) =       fromIntegral n
library/Hasql/Private/Decoders/Results.hs view
@@ -1,29 +1,26 @@ -- | -- An API for retrieval of multiple results. -- Can be used to handle:--- +-- -- * A single result,--- +-- -- * Individual results of a multi-statement query -- with the help of "Applicative" and "Monad",--- +-- -- * Row-by-row fetching.---  module Hasql.Private.Decoders.Results where -import Hasql.Private.Prelude hiding (maybe, many)-import Hasql.Private.Errors import qualified Database.PostgreSQL.LibPQ as LibPQ-import qualified Hasql.Private.Prelude as Prelude import qualified Hasql.Private.Decoders.Result as Result import qualified Hasql.Private.Decoders.Row as Row-+import Hasql.Private.Errors+import Hasql.Private.Prelude hiding (many, maybe)+import qualified Hasql.Private.Prelude as Prelude -newtype Results a =-  Results (ReaderT (Bool, LibPQ.Connection) (ExceptT CommandError IO) a)+newtype Results a+  = Results (ReaderT (Bool, LibPQ.Connection) (ExceptT CommandError IO) a)   deriving (Functor, Applicative, Monad) - {-# INLINE run #-} run :: Results a -> (Bool, LibPQ.Connection) -> IO (Either CommandError a) run (Results stack) env =@@ -32,32 +29,36 @@ {-# INLINE clientError #-} clientError :: Results a clientError =-  Results $ ReaderT $ \(_, connection) -> ExceptT $-  fmap (Left . ClientError) (LibPQ.errorMessage connection)+  Results $+    ReaderT $ \(_, connection) ->+      ExceptT $+        fmap (Left . ClientError) (LibPQ.errorMessage connection)  -- | -- Parse a single result. {-# INLINE single #-} single :: Result.Result a -> Results a single resultDec =-  Results $ ReaderT $ \(integerDatetimes, connection) -> ExceptT $ do-    resultMaybe <- LibPQ.getResult connection-    case resultMaybe of-      Just result ->-        mapLeft ResultError <$> Result.run resultDec (integerDatetimes, result) -      Nothing ->-        fmap (Left . ClientError) (LibPQ.errorMessage connection)+  Results $+    ReaderT $ \(integerDatetimes, connection) -> ExceptT $ do+      resultMaybe <- LibPQ.getResult connection+      case resultMaybe of+        Just result ->+          mapLeft ResultError <$> Result.run resultDec (integerDatetimes, result)+        Nothing ->+          fmap (Left . ClientError) (LibPQ.errorMessage connection)  -- | -- Fetch a single result. {-# INLINE getResult #-} getResult :: Results LibPQ.Result getResult =-  Results $ ReaderT $ \(_, connection) -> ExceptT $ do-    resultMaybe <- LibPQ.getResult connection-    case resultMaybe of-      Just result -> pure (Right result)-      Nothing -> fmap (Left . ClientError) (LibPQ.errorMessage connection)+  Results $+    ReaderT $ \(_, connection) -> ExceptT $ do+      resultMaybe <- LibPQ.getResult connection+      case resultMaybe of+        Just result -> pure (Right result)+        Nothing -> fmap (Left . ClientError) (LibPQ.errorMessage connection)  -- | -- Fetch a single result.@@ -69,7 +70,7 @@ {-# INLINE dropRemainders #-} dropRemainders :: Results () dropRemainders =-  {-# SCC "dropRemainders" #-} +  {-# SCC "dropRemainders" #-}   Results $ ReaderT $ \(integerDatetimes, connection) -> loop integerDatetimes connection   where     loop integerDatetimes connection =@@ -84,6 +85,7 @@               ExceptT $ fmap (mapLeft ResultError) $ Result.run Result.noResult (integerDatetimes, result)  refine :: (a -> Either Text b) -> Results a -> Results b-refine refiner results = Results $ ReaderT $ \ env -> ExceptT $ do-  resultEither <- run results env-  return $ resultEither >>= mapLeft (ResultError . UnexpectedResult) . refiner+refine refiner results = Results $+  ReaderT $ \env -> ExceptT $ do+    resultEither <- run results env+    return $ resultEither >>= mapLeft (ResultError . UnexpectedResult) . refiner
library/Hasql/Private/Decoders/Row.hs view
@@ -1,24 +1,23 @@ module Hasql.Private.Decoders.Row where -import Hasql.Private.Prelude hiding (error)-import Hasql.Private.Errors import qualified Database.PostgreSQL.LibPQ as LibPQ-import qualified PostgreSQL.Binary.Decoding as A import qualified Hasql.Private.Decoders.Value as Value-+import Hasql.Private.Errors+import Hasql.Private.Prelude hiding (error)+import qualified PostgreSQL.Binary.Decoding as A -newtype Row a =-  Row (ReaderT Env (ExceptT RowError IO) a)+newtype Row a+  = Row (ReaderT Env (ExceptT RowError IO) a)   deriving (Functor, Applicative, Monad)  instance MonadFail Row where   fail = error . ValueError . fromString -data Env =-  Env !LibPQ.Result !LibPQ.Row !LibPQ.Column !Bool !(IORef LibPQ.Column)-+data Env+  = Env !LibPQ.Result !LibPQ.Row !LibPQ.Column !Bool !(IORef LibPQ.Column)  -- * Functions+ -------------------------  {-# INLINE run #-}@@ -44,20 +43,22 @@ value :: Value.Value a -> Row (Maybe a) value valueDec =   {-# SCC "value" #-}-  Row $ ReaderT $ \(Env result row columnsAmount integerDatetimes columnRef) -> ExceptT $ do-    col <- readIORef columnRef-    writeIORef columnRef (succ col)-    if col < columnsAmount-      then do-        valueMaybe <- {-# SCC "getvalue'" #-} LibPQ.getvalue' result row col-        pure $-          case valueMaybe of-            Nothing ->-              Right Nothing-            Just value ->-              fmap Just $ mapLeft ValueError $-              {-# SCC "decode" #-} A.valueParser (Value.run valueDec integerDatetimes) value-      else pure (Left EndOfInput)+  Row $+    ReaderT $ \(Env result row columnsAmount integerDatetimes columnRef) -> ExceptT $ do+      col <- readIORef columnRef+      writeIORef columnRef (succ col)+      if col < columnsAmount+        then do+          valueMaybe <- {-# SCC "getvalue'" #-} LibPQ.getvalue' result row col+          pure $+            case valueMaybe of+              Nothing ->+                Right Nothing+              Just value ->+                fmap Just $+                  mapLeft ValueError $+                    {-# SCC "decode" #-} A.valueParser (Value.run valueDec integerDatetimes) value+        else pure (Left EndOfInput)  -- | -- Next value, decoded using the provided value decoder.
library/Hasql/Private/Decoders/Value.hs view
@@ -3,9 +3,8 @@ import Hasql.Private.Prelude import qualified PostgreSQL.Binary.Decoding as A --newtype Value a =-  Value (Bool -> A.Value a)+newtype Value a+  = Value (Bool -> A.Value a)   deriving (Functor)  {-# INLINE run #-}@@ -16,7 +15,7 @@ {-# INLINE decoder #-} decoder :: (Bool -> A.Value a) -> Value a decoder =-  {-# SCC "decoder" #-} +  {-# SCC "decoder" #-}   Value  {-# INLINE decoderFn #-}
library/Hasql/Private/Encoders.hs view
@@ -1,371 +1,336 @@-{-|-A DSL for declaration of query parameter encoders.--}-module Hasql.Private.Encoders-where+-- |+-- 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.Array as Array 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 Hasql.Private.Prelude hiding (bool) import qualified Hasql.Private.Prelude as Prelude-+import qualified PostgreSQL.Binary.Data as B+import qualified PostgreSQL.Binary.Encoding as A+import qualified Text.Builder as C  -- * 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"-@--}+-- |+-- 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`.--}+-- |+-- 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.--}+-- |+-- Lift a single parameter encoder, with its nullability specified,+-- associating it with a single placeholder. param :: NullableOrNot Value a -> Params a-param = \ case+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.--}+-- |+-- 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.--}+-- |+-- 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.--}+-- |+-- Specify that an encoder produces a nullable value. nullable :: encoder a -> NullableOrNot encoder (Maybe a) nullable = Nullable - -- * Value+ ------------------------- -{-|-Value encoder.--}+-- |+-- Value encoder. newtype Value a = Value (Value.Value a)   deriving (Contravariant) -{-|-Encoder of @BOOL@ values.--}-{-# INLINABLE bool #-}+-- |+-- Encoder of @BOOL@ values.+{-# INLINEABLE bool #-} bool :: Value Bool bool = Value (Value.unsafePTIWithShow PTI.bool (const A.bool)) -{-|-Encoder of @INT2@ values.--}-{-# INLINABLE int2 #-}+-- |+-- Encoder of @INT2@ values.+{-# INLINEABLE int2 #-} int2 :: Value Int16 int2 = Value (Value.unsafePTIWithShow PTI.int2 (const A.int2_int16)) -{-|-Encoder of @INT4@ values.--}-{-# INLINABLE int4 #-}+-- |+-- Encoder of @INT4@ values.+{-# INLINEABLE int4 #-} int4 :: Value Int32 int4 = Value (Value.unsafePTIWithShow PTI.int4 (const A.int4_int32)) -{-|-Encoder of @INT8@ values.--}-{-# INLINABLE int8 #-}+-- |+-- Encoder of @INT8@ values.+{-# INLINEABLE int8 #-} int8 :: Value Int64 int8 = Value (Value.unsafePTIWithShow PTI.int8 (const A.int8_int64)) -{-|-Encoder of @FLOAT4@ values.--}-{-# INLINABLE float4 #-}+-- |+-- Encoder of @FLOAT4@ values.+{-# INLINEABLE float4 #-} float4 :: Value Float float4 = Value (Value.unsafePTIWithShow PTI.float4 (const A.float4)) -{-|-Encoder of @FLOAT8@ values.--}-{-# INLINABLE float8 #-}+-- |+-- Encoder of @FLOAT8@ values.+{-# INLINEABLE float8 #-} float8 :: Value Double float8 = Value (Value.unsafePTIWithShow PTI.float8 (const A.float8)) -{-|-Encoder of @NUMERIC@ values.--}-{-# INLINABLE numeric #-}+-- |+-- Encoder of @NUMERIC@ values.+{-# INLINEABLE 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 #-}+-- |+-- Encoder of @CHAR@ values.+--+-- Note that it supports Unicode values and+-- identifies itself under the @TEXT@ OID because of that.+{-# INLINEABLE char #-} char :: Value Char char = Value (Value.unsafePTIWithShow PTI.text (const A.char_utf8)) -{-|-Encoder of @TEXT@ values.--}-{-# INLINABLE text #-}+-- |+-- Encoder of @TEXT@ values.+{-# INLINEABLE text #-} text :: Value Text text = Value (Value.unsafePTIWithShow PTI.text (const A.text_strict)) -{-|-Encoder of @BYTEA@ values.--}-{-# INLINABLE bytea #-}+-- |+-- Encoder of @BYTEA@ values.+{-# INLINEABLE bytea #-} bytea :: Value ByteString bytea = Value (Value.unsafePTIWithShow PTI.bytea (const A.bytea_strict)) -{-|-Encoder of @DATE@ values.--}-{-# INLINABLE date #-}+-- |+-- Encoder of @DATE@ values.+{-# INLINEABLE date #-} date :: Value B.Day date = Value (Value.unsafePTIWithShow PTI.date (const A.date)) -{-|-Encoder of @TIMESTAMP@ values.--}-{-# INLINABLE timestamp #-}+-- |+-- Encoder of @TIMESTAMP@ values.+{-# INLINEABLE 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 #-}+-- |+-- Encoder of @TIMESTAMPTZ@ values.+{-# INLINEABLE 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 #-}+-- |+-- Encoder of @TIME@ values.+{-# INLINEABLE 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 #-}+-- |+-- Encoder of @TIMETZ@ values.+{-# INLINEABLE 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 #-}+-- |+-- Encoder of @INTERVAL@ values.+{-# INLINEABLE 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 #-}+-- |+-- Encoder of @UUID@ values.+{-# INLINEABLE uuid #-} uuid :: Value B.UUID uuid = Value (Value.unsafePTIWithShow PTI.uuid (const A.uuid)) -{-|-Encoder of @INET@ values.--}-{-# INLINABLE inet #-}+-- |+-- Encoder of @INET@ values.+{-# INLINEABLE 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 #-}+-- |+-- Encoder of @JSON@ values from JSON AST.+{-# INLINEABLE json #-} json :: Value B.Value json = Value (Value.unsafePTIWithShow PTI.json (const A.json_ast)) -{-|-Encoder of @JSON@ values from raw JSON.--}-{-# INLINABLE jsonBytes #-}+-- |+-- Encoder of @JSON@ values from raw JSON.+{-# INLINEABLE jsonBytes #-} jsonBytes :: Value ByteString jsonBytes = Value (Value.unsafePTIWithShow PTI.json (const A.json_bytes)) -{-|-Encoder of @JSONB@ values from JSON AST.--}-{-# INLINABLE jsonb #-}+-- |+-- Encoder of @JSONB@ values from JSON AST.+{-# INLINEABLE jsonb #-} jsonb :: Value B.Value jsonb = Value (Value.unsafePTIWithShow PTI.jsonb (const A.jsonb_ast)) -{-|-Encoder of @JSONB@ values from raw JSON.--}-{-# INLINABLE jsonbBytes #-}+-- |+-- Encoder of @JSONB@ values from raw JSON.+{-# INLINEABLE 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 #-}+-- |+-- Given a function,+-- which maps a value into a textual enum label used on the DB side,+-- produces an encoder of that value.+{-# INLINEABLE 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-<https://www.postgresql.org/docs/10/static/protocol-overview.html#protocol-format-codes Formats and Format Codes>-section of the Postgres' documentation.--}-{-# INLINABLE unknown #-}+-- |+-- 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+-- <https://www.postgresql.org/docs/10/static/protocol-overview.html#protocol-format-codes Formats and Format Codes>+-- section of the Postgres' documentation.+--+-- __Warning:__ Do not use this as part of composite encoders like 'array' since+-- it is the only encoder that doesn't use the binary format.+{-# INLINEABLE unknown #-} unknown :: Value ByteString unknown = Value (Value.unsafePTIWithShow PTI.unknown (const A.bytea_strict)) -{-|-Lift an array encoder into a parameter encoder.--}+-- |+-- 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.--This function is merely a shortcut to the following expression:--@-('array' . 'dimension' 'foldl'' . 'element')-@--You can use it like this:--@-vectorOfInts :: Value (Vector Int64)-vectorOfInts = 'foldableArray' ('nonNullable' 'int8')-@+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) -Please notice that in case of multidimensional arrays nesting 'foldableArray' encoder-won't work. You have to explicitly construct the array encoder using 'array'.--}+-- |+-- Lift a value encoder of element into a unidimensional array encoder of a foldable value.+--+-- This function is merely a shortcut to the following expression:+--+-- @+-- ('array' . 'dimension' 'foldl'' . 'element')+-- @+--+-- You can use it like this:+--+-- @+-- vectorOfInts :: Value (Vector Int64)+-- vectorOfInts = 'foldableArray' ('nonNullable' 'int8')+-- @+--+-- 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.--}+-- |+-- 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.--}+-- |+-- Lifts a 'Value' encoder into an 'Array' encoder. element :: NullableOrNot Value a -> Array a-element = \ case+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 #-}+-- |+-- 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'.+{-# INLINEABLE dimension #-} dimension :: (forall a. (a -> b -> a) -> a -> c -> a) -> Array b -> Array c dimension foldl (Array imp) = Array (Array.dimension foldl imp)
library/Hasql/Private/Encoders/Array.hs view
@@ -1,17 +1,16 @@ module Hasql.Private.Encoders.Array where +import qualified Hasql.Private.PTI as B import Hasql.Private.Prelude import qualified PostgreSQL.Binary.Encoding as A-import qualified Hasql.Private.PTI as B import qualified Text.Builder as C --data Array a =-  Array B.OID B.OID (Bool -> a -> A.Array) (a -> C.Builder)+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)+    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@@ -21,29 +20,25 @@ {-# INLINE nullableValue #-} nullableValue :: B.OID -> B.OID -> (Bool -> a -> A.Encoding) -> (a -> C.Builder) -> Array (Maybe a) nullableValue valueOID arrayOID encoder renderer =-  let-    maybeEncoder params =-      maybe A.nullArray (A.encodingArray . encoder params)-    maybeRenderer =-      maybe (C.string "null") renderer-    in Array valueOID arrayOID maybeEncoder maybeRenderer+  let maybeEncoder params =+        maybe A.nullArray (A.encodingArray . encoder params)+      maybeRenderer =+        maybe (C.string "null") renderer+   in Array valueOID arrayOID maybeEncoder maybeRenderer  {-# INLINE dimension #-} dimension :: (forall a. (a -> b -> a) -> a -> c -> a) -> Array b -> Array c dimension fold (Array valueOID arrayOID elEncoder elRenderer) =-  let-    encoder el =-      A.dimensionArray fold (elEncoder el)-    renderer els =-      let-        folded =-          let-            step builder el =-              if C.null builder-                then C.char '[' <> elRenderer el-                else builder <> C.string ", " <> elRenderer el-            in fold step mempty els-        in if C.null folded-          then C.string "[]"-          else folded <> C.char ']'-    in Array valueOID arrayOID encoder renderer+  let encoder el =+        A.dimensionArray fold (elEncoder el)+      renderer els =+        let folded =+              let step builder el =+                    if C.null builder+                      then C.char '[' <> elRenderer el+                      else builder <> C.string ", " <> elRenderer el+               in fold step mempty els+         in if C.null folded+              then C.string "[]"+              else folded <> C.char ']'+   in Array valueOID arrayOID encoder renderer
library/Hasql/Private/Encoders/Params.hs view
@@ -1,17 +1,16 @@ module Hasql.Private.Encoders.Params where -import Hasql.Private.Prelude import qualified Database.PostgreSQL.LibPQ as A-import qualified PostgreSQL.Binary.Encoding as B import qualified Hasql.Private.Encoders.Value as C import qualified Hasql.Private.PTI as D+import Hasql.Private.Prelude+import qualified PostgreSQL.Binary.Encoding as B import qualified Text.Builder as E - -- | -- Encoder of some representation of a parameters product.-newtype Params a =-  Params (Op (DList (A.Oid, A.Format, Bool -> Maybe ByteString, Text)) a)+newtype Params a+  = Params (Op (DList (A.Oid, A.Format, Bool -> Maybe ByteString, Text)) a)   deriving (Contravariant, Divisible, Decidable, Semigroup, Monoid)  value :: C.Value a -> Params a@@ -20,12 +19,12 @@  nullableValue :: C.Value a -> Params (Maybe a) nullableValue (C.Value valueOID arrayOID encode render) =-  Params $ Op $ \ input ->-  let-    D.OID _ pqOid format =-      valueOID-    encoder env =-      fmap (B.encodingBytes . encode env) input-    rendering =-      maybe "null" (E.run . render) input-    in pure (pqOid, format, encoder, rendering)+  Params $+    Op $ \input ->+      let D.OID _ pqOid format =+            valueOID+          encoder env =+            fmap (B.encodingBytes . encode env) input+          rendering =+            maybe "null" (E.run . render) input+       in pure (pqOid, format, encoder, rendering)
library/Hasql/Private/Encoders/Value.hs view
@@ -1,13 +1,12 @@ module Hasql.Private.Encoders.Value where +import qualified Hasql.Private.PTI as PTI import Hasql.Private.Prelude import qualified PostgreSQL.Binary.Encoding as B-import qualified Hasql.Private.PTI as PTI import qualified Text.Builder as C --data Value a =-  Value PTI.OID PTI.OID (Bool -> a -> B.Encoding) (a -> C.Builder)+data Value a+  = Value PTI.OID PTI.OID (Bool -> a -> B.Encoding) (a -> C.Builder)  instance Contravariant Value where   {-# INLINE contramap #-}
library/Hasql/Private/Errors.hs view
@@ -1,90 +1,88 @@ -- | -- An API for retrieval of multiple results. -- Can be used to handle:--- +-- -- * A single result,--- +-- -- * Individual results of a multi-statement query -- with the help of "Applicative" and "Monad",--- +-- -- * Row-by-row fetching.---  module Hasql.Private.Errors where  import Hasql.Private.Prelude - -- | -- An error during the execution of a query. -- Comes packed with the query template and a textual representation of the provided params.-data QueryError =-  QueryError ByteString [Text] CommandError+data QueryError+  = QueryError ByteString [Text] CommandError   deriving (Show, Eq, Typeable)  instance Exception QueryError  -- | -- An error of some command in the session.-data CommandError =-  -- |-  -- An error on the client-side,-  -- with a message generated by the \"libpq\" library.-  -- Usually indicates problems with connection.-  ClientError (Maybe ByteString) |-  -- |-  -- Some error with a command result.-  ResultError ResultError+data CommandError+  = -- |+    -- An error on the client-side,+    -- with a message generated by the \"libpq\" library.+    -- Usually indicates problems with connection.+    ClientError (Maybe ByteString)+  | -- |+    -- Some error with a command result.+    ResultError ResultError   deriving (Show, Eq)  -- | -- An error with a command result.-data ResultError =-  -- | -  -- An error reported by the DB.-  -- Consists of the following: Code, message, details, hint.-  -- -  -- * __Code__.-  -- The SQLSTATE code for the error.-  -- It's recommended to use-  -- <http://hackage.haskell.org/package/postgresql-error-codes the "postgresql-error-codes" package>-  -- to work with those.-  -- -  -- * __Message__.-  -- The primary human-readable error message (typically one line). Always present.-  -- -  -- * __Details__.-  -- An optional secondary error message carrying more detail about the problem. -  -- Might run to multiple lines.-  -- -  -- * __Hint__.-  -- An optional suggestion on what to do about the problem. -  -- This is intended to differ from detail in that it offers advice (potentially inappropriate) -  -- rather than hard facts.-  -- Might run to multiple lines.-  ServerError ByteString ByteString (Maybe ByteString) (Maybe ByteString) |-  -- |-  -- The database returned an unexpected result.-  -- Indicates an improper statement or a schema mismatch.-  UnexpectedResult Text |-  -- |-  -- An error of the row reader, preceded by the indexes of the row and column.-  RowError Int Int RowError |-  -- |-  -- An unexpected amount of rows.-  UnexpectedAmountOfRows Int+data ResultError+  = -- |+    -- An error reported by the DB.+    -- Consists of the following: Code, message, details, hint.+    --+    -- * __Code__.+    -- The SQLSTATE code for the error.+    -- It's recommended to use+    -- <http://hackage.haskell.org/package/postgresql-error-codes the "postgresql-error-codes" package>+    -- to work with those.+    --+    -- * __Message__.+    -- The primary human-readable error message (typically one line). Always present.+    --+    -- * __Details__.+    -- An optional secondary error message carrying more detail about the problem.+    -- Might run to multiple lines.+    --+    -- * __Hint__.+    -- An optional suggestion on what to do about the problem.+    -- This is intended to differ from detail in that it offers advice (potentially inappropriate)+    -- rather than hard facts.+    -- Might run to multiple lines.+    ServerError ByteString ByteString (Maybe ByteString) (Maybe ByteString)+  | -- |+    -- The database returned an unexpected result.+    -- Indicates an improper statement or a schema mismatch.+    UnexpectedResult Text+  | -- |+    -- An error of the row reader, preceded by the indexes of the row and column.+    RowError Int Int RowError+  | -- |+    -- An unexpected amount of rows.+    UnexpectedAmountOfRows Int   deriving (Show, Eq)  -- | -- An error during the decoding of a specific row.-data RowError =-  -- |-  -- Appears on the attempt to parse more columns than there are in the result.-  EndOfInput |-  -- |-  -- Appears on the attempt to parse a @NULL@ as some value.-  UnexpectedNull |-  -- |-  -- Appears when a wrong value parser is used.-  -- Comes with the error details.-  ValueError Text+data RowError+  = -- |+    -- Appears on the attempt to parse more columns than there are in the result.+    EndOfInput+  | -- |+    -- Appears on the attempt to parse a @NULL@ as some value.+    UnexpectedNull+  | -- |+    -- Appears when a wrong value parser is used.+    -- Comes with the error details.+    ValueError Text   deriving (Show, Eq)
library/Hasql/Private/IO.hs view
@@ -1,18 +1,16 @@ -- | -- An API of low-level IO operations.-module Hasql.Private.IO-where+module Hasql.Private.IO where -import Hasql.Private.Prelude-import Hasql.Private.Errors+import qualified Data.DList as DList import qualified Database.PostgreSQL.LibPQ as LibPQ import qualified Hasql.Private.Commands as Commands-import qualified Hasql.Private.PreparedStatementRegistry as PreparedStatementRegistry import qualified Hasql.Private.Decoders.Result as ResultDecoders import qualified Hasql.Private.Decoders.Results as ResultsDecoders import qualified Hasql.Private.Encoders.Params as ParamsEncoders-import qualified Data.DList as DList-+import Hasql.Private.Errors+import Hasql.Private.Prelude+import qualified Hasql.Private.PreparedStatementRegistry as PreparedStatementRegistry  {-# INLINE acquireConnection #-} acquireConnection :: ByteString -> IO LibPQ.Connection@@ -48,7 +46,7 @@ getIntegerDatetimes c =   fmap decodeValue $ LibPQ.parameterStatus c "integer_datetimes"   where-    decodeValue = +    decodeValue =       \case         Just "on" -> True         _ -> False@@ -61,7 +59,7 @@ {-# INLINE getResults #-} getResults :: LibPQ.Connection -> Bool -> ResultsDecoders.Results a -> IO (Either CommandError a) getResults connection integerDatetimes decoder =-  {-# SCC "getResults" #-} +  {-# SCC "getResults" #-}   (<*) <$> get <*> dropRemainders   where     get =@@ -71,11 +69,13 @@  {-# INLINE getPreparedStatementKey #-} getPreparedStatementKey ::-  LibPQ.Connection -> PreparedStatementRegistry.PreparedStatementRegistry ->-  ByteString -> [LibPQ.Oid] ->+  LibPQ.Connection ->+  PreparedStatementRegistry.PreparedStatementRegistry ->+  ByteString ->+  [LibPQ.Oid] ->   IO (Either CommandError ByteString) getPreparedStatementKey connection registry template oidList =-  {-# SCC "getPreparedStatementKey" #-} +  {-# SCC "getPreparedStatementKey" #-}   PreparedStatementRegistry.update localKey onNewRemoteKey onOldRemoteKey registry   where     localKey =@@ -86,7 +86,7 @@     onNewRemoteKey key =       do         sent <- LibPQ.sendPrepare connection key template (mfilter (not . null) (Just oidList))-        let resultsDecoder = +        let resultsDecoder =               if sent                 then ResultsDecoders.single ResultDecoders.noResult                 else ResultsDecoders.clientError@@ -116,17 +116,15 @@   a ->   IO (Either CommandError ()) sendPreparedParametricStatement connection registry integerDatetimes template (ParamsEncoders.Params (Op encoderOp)) input =-  let-    (oidList, valueAndFormatList) =-      let-        step (oid, format, encoder, _) ~(oidList, bytesAndFormatList) =-          (,)-            (oid : oidList)-            (fmap (\bytes -> (bytes, format)) (encoder integerDatetimes) : bytesAndFormatList)-        in foldr step ([], []) (encoderOp input)-    in runExceptT $ do-      key <- ExceptT $ getPreparedStatementKey connection registry template oidList-      ExceptT $ checkedSend connection $ LibPQ.sendQueryPrepared connection key valueAndFormatList LibPQ.Binary+  let (oidList, valueAndFormatList) =+        let step (oid, format, encoder, _) ~(oidList, bytesAndFormatList) =+              (,)+                (oid : oidList)+                (fmap (\bytes -> (bytes, format)) (encoder integerDatetimes) : bytesAndFormatList)+         in foldr step ([], []) (encoderOp input)+   in runExceptT $ do+        key <- ExceptT $ getPreparedStatementKey connection registry template oidList+        ExceptT $ checkedSend connection $ LibPQ.sendQueryPrepared connection key valueAndFormatList LibPQ.Binary  {-# INLINE sendUnpreparedParametricStatement #-} sendUnpreparedParametricStatement ::@@ -137,18 +135,16 @@   a ->   IO (Either CommandError ()) sendUnpreparedParametricStatement connection integerDatetimes template (ParamsEncoders.Params (Op encoderOp)) input =-  let-    params =-      let-        step (oid, format, encoder, _) acc =-          ((,,) <$> pure oid <*> encoder integerDatetimes <*> pure format) : acc-        in foldr step [] (encoderOp input)-    in checkedSend connection $ LibPQ.sendQueryParams connection template params LibPQ.Binary+  let params =+        let step (oid, format, encoder, _) acc =+              ((,,) <$> pure oid <*> encoder integerDatetimes <*> pure format) : acc+         in foldr step [] (encoderOp input)+   in checkedSend connection $ LibPQ.sendQueryParams connection template params LibPQ.Binary  {-# INLINE sendParametricStatement #-} sendParametricStatement ::   LibPQ.Connection ->-  Bool -> +  Bool ->   PreparedStatementRegistry.PreparedStatementRegistry ->   ByteString ->   ParamsEncoders.Params a ->@@ -156,7 +152,7 @@   a ->   IO (Either CommandError ()) sendParametricStatement connection integerDatetimes registry template encoder prepared params =-  {-# SCC "sendParametricStatement" #-} +  {-# SCC "sendParametricStatement" #-}   if prepared     then sendPreparedParametricStatement connection registry integerDatetimes template encoder params     else sendUnpreparedParametricStatement connection integerDatetimes template encoder params
library/Hasql/Private/PTI.hs view
@@ -1,14 +1,13 @@ module Hasql.Private.PTI where -import Hasql.Private.Prelude hiding (bool) import qualified Database.PostgreSQL.LibPQ as LibPQ-+import Hasql.Private.Prelude hiding (bool)  -- | A Postgresql type info-data PTI = PTI { ptiOID :: !OID, ptiArrayOID :: !(Maybe OID) }+data PTI = PTI {ptiOID :: !OID, ptiArrayOID :: !(Maybe OID)}  -- | A Word32 and a LibPQ representation of an OID-data OID = OID { oidWord32 :: !Word32, oidPQ :: !LibPQ.Oid, oidFormat :: !LibPQ.Format }+data OID = OID {oidWord32 :: !Word32, oidPQ :: !LibPQ.Oid, oidFormat :: !LibPQ.Format}  mkOID :: LibPQ.Format -> Word32 -> OID mkOID format x =@@ -18,77 +17,144 @@ mkPTI format oid arrayOID =   PTI (mkOID format oid) (fmap (mkOID format) arrayOID) - -- * Constants+ ------------------------- -abstime         = mkPTI LibPQ.Binary 702  (Just 1023)-aclitem         = mkPTI LibPQ.Binary 1033 (Just 1034)-bit             = mkPTI LibPQ.Binary 1560 (Just 1561)-bool            = mkPTI LibPQ.Binary 16   (Just 1000)-box             = mkPTI LibPQ.Binary 603  (Just 1020)-bpchar          = mkPTI LibPQ.Binary 1042 (Just 1014)-bytea           = mkPTI LibPQ.Binary 17   (Just 1001)-char            = mkPTI LibPQ.Binary 18   (Just 1002)-cid             = mkPTI LibPQ.Binary 29   (Just 1012)-cidr            = mkPTI LibPQ.Binary 650  (Just 651)-circle          = mkPTI LibPQ.Binary 718  (Just 719)-cstring         = mkPTI LibPQ.Binary 2275 (Just 1263)-date            = mkPTI LibPQ.Binary 1082 (Just 1182)-daterange       = mkPTI LibPQ.Binary 3912 (Just 3913)-float4          = mkPTI LibPQ.Binary 700  (Just 1021)-float8          = mkPTI LibPQ.Binary 701  (Just 1022)-gtsvector       = mkPTI LibPQ.Binary 3642 (Just 3644)-inet            = mkPTI LibPQ.Binary 869  (Just 1041)-int2            = mkPTI LibPQ.Binary 21   (Just 1005)-int2vector      = mkPTI LibPQ.Binary 22   (Just 1006)-int4            = mkPTI LibPQ.Binary 23   (Just 1007)-int4range       = mkPTI LibPQ.Binary 3904 (Just 3905)-int8            = mkPTI LibPQ.Binary 20   (Just 1016)-int8range       = mkPTI LibPQ.Binary 3926 (Just 3927)-interval        = mkPTI LibPQ.Binary 1186 (Just 1187)-json            = mkPTI LibPQ.Binary 114  (Just 199)-jsonb           = mkPTI LibPQ.Binary 3802 (Just 3807)-line            = mkPTI LibPQ.Binary 628  (Just 629)-lseg            = mkPTI LibPQ.Binary 601  (Just 1018)-macaddr         = mkPTI LibPQ.Binary 829  (Just 1040)-money           = mkPTI LibPQ.Binary 790  (Just 791)-name            = mkPTI LibPQ.Binary 19   (Just 1003)-numeric         = mkPTI LibPQ.Binary 1700 (Just 1231)-numrange        = mkPTI LibPQ.Binary 3906 (Just 3907)-oid             = mkPTI LibPQ.Binary 26   (Just 1028)-oidvector       = mkPTI LibPQ.Binary 30   (Just 1013)-path            = mkPTI LibPQ.Binary 602  (Just 1019)-point           = mkPTI LibPQ.Binary 600  (Just 1017)-polygon         = mkPTI LibPQ.Binary 604  (Just 1027)-record          = mkPTI LibPQ.Binary 2249 (Just 2287)-refcursor       = mkPTI LibPQ.Binary 1790 (Just 2201)-regclass        = mkPTI LibPQ.Binary 2205 (Just 2210)-regconfig       = mkPTI LibPQ.Binary 3734 (Just 3735)-regdictionary   = mkPTI LibPQ.Binary 3769 (Just 3770)-regoper         = mkPTI LibPQ.Binary 2203 (Just 2208)-regoperator     = mkPTI LibPQ.Binary 2204 (Just 2209)-regproc         = mkPTI LibPQ.Binary 24   (Just 1008)-regprocedure    = mkPTI LibPQ.Binary 2202 (Just 2207)-regtype         = mkPTI LibPQ.Binary 2206 (Just 2211)-reltime         = mkPTI LibPQ.Binary 703  (Just 1024)-text            = mkPTI LibPQ.Binary 25   (Just 1009)-tid             = mkPTI LibPQ.Binary 27   (Just 1010)-time            = mkPTI LibPQ.Binary 1083 (Just 1183)-timestamp       = mkPTI LibPQ.Binary 1114 (Just 1115)-timestamptz     = mkPTI LibPQ.Binary 1184 (Just 1185)-timetz          = mkPTI LibPQ.Binary 1266 (Just 1270)-tinterval       = mkPTI LibPQ.Binary 704  (Just 1025)-tsquery         = mkPTI LibPQ.Binary 3615 (Just 3645)-tsrange         = mkPTI LibPQ.Binary 3908 (Just 3909)-tstzrange       = mkPTI LibPQ.Binary 3910 (Just 3911)-tsvector        = mkPTI LibPQ.Binary 3614 (Just 3643)-txid_snapshot   = mkPTI LibPQ.Binary 2970 (Just 2949)-unknown         = mkPTI LibPQ.Text   705  (Just 705)-uuid            = mkPTI LibPQ.Binary 2950 (Just 2951)-varbit          = mkPTI LibPQ.Binary 1562 (Just 1563)-varchar         = mkPTI LibPQ.Binary 1043 (Just 1015)-void            = mkPTI LibPQ.Binary 2278 Nothing-xid             = mkPTI LibPQ.Binary 28   (Just 1011)-xml             = mkPTI LibPQ.Binary 142  (Just 143)+abstime = mkPTI LibPQ.Binary 702 (Just 1023) +aclitem = mkPTI LibPQ.Binary 1033 (Just 1034)++bit = mkPTI LibPQ.Binary 1560 (Just 1561)++bool = mkPTI LibPQ.Binary 16 (Just 1000)++box = mkPTI LibPQ.Binary 603 (Just 1020)++bpchar = mkPTI LibPQ.Binary 1042 (Just 1014)++bytea = mkPTI LibPQ.Binary 17 (Just 1001)++char = mkPTI LibPQ.Binary 18 (Just 1002)++cid = mkPTI LibPQ.Binary 29 (Just 1012)++cidr = mkPTI LibPQ.Binary 650 (Just 651)++circle = mkPTI LibPQ.Binary 718 (Just 719)++cstring = mkPTI LibPQ.Binary 2275 (Just 1263)++date = mkPTI LibPQ.Binary 1082 (Just 1182)++daterange = mkPTI LibPQ.Binary 3912 (Just 3913)++float4 = mkPTI LibPQ.Binary 700 (Just 1021)++float8 = mkPTI LibPQ.Binary 701 (Just 1022)++gtsvector = mkPTI LibPQ.Binary 3642 (Just 3644)++inet = mkPTI LibPQ.Binary 869 (Just 1041)++int2 = mkPTI LibPQ.Binary 21 (Just 1005)++int2vector = mkPTI LibPQ.Binary 22 (Just 1006)++int4 = mkPTI LibPQ.Binary 23 (Just 1007)++int4range = mkPTI LibPQ.Binary 3904 (Just 3905)++int8 = mkPTI LibPQ.Binary 20 (Just 1016)++int8range = mkPTI LibPQ.Binary 3926 (Just 3927)++interval = mkPTI LibPQ.Binary 1186 (Just 1187)++json = mkPTI LibPQ.Binary 114 (Just 199)++jsonb = mkPTI LibPQ.Binary 3802 (Just 3807)++line = mkPTI LibPQ.Binary 628 (Just 629)++lseg = mkPTI LibPQ.Binary 601 (Just 1018)++macaddr = mkPTI LibPQ.Binary 829 (Just 1040)++money = mkPTI LibPQ.Binary 790 (Just 791)++name = mkPTI LibPQ.Binary 19 (Just 1003)++numeric = mkPTI LibPQ.Binary 1700 (Just 1231)++numrange = mkPTI LibPQ.Binary 3906 (Just 3907)++oid = mkPTI LibPQ.Binary 26 (Just 1028)++oidvector = mkPTI LibPQ.Binary 30 (Just 1013)++path = mkPTI LibPQ.Binary 602 (Just 1019)++point = mkPTI LibPQ.Binary 600 (Just 1017)++polygon = mkPTI LibPQ.Binary 604 (Just 1027)++record = mkPTI LibPQ.Binary 2249 (Just 2287)++refcursor = mkPTI LibPQ.Binary 1790 (Just 2201)++regclass = mkPTI LibPQ.Binary 2205 (Just 2210)++regconfig = mkPTI LibPQ.Binary 3734 (Just 3735)++regdictionary = mkPTI LibPQ.Binary 3769 (Just 3770)++regoper = mkPTI LibPQ.Binary 2203 (Just 2208)++regoperator = mkPTI LibPQ.Binary 2204 (Just 2209)++regproc = mkPTI LibPQ.Binary 24 (Just 1008)++regprocedure = mkPTI LibPQ.Binary 2202 (Just 2207)++regtype = mkPTI LibPQ.Binary 2206 (Just 2211)++reltime = mkPTI LibPQ.Binary 703 (Just 1024)++text = mkPTI LibPQ.Binary 25 (Just 1009)++tid = mkPTI LibPQ.Binary 27 (Just 1010)++time = mkPTI LibPQ.Binary 1083 (Just 1183)++timestamp = mkPTI LibPQ.Binary 1114 (Just 1115)++timestamptz = mkPTI LibPQ.Binary 1184 (Just 1185)++timetz = mkPTI LibPQ.Binary 1266 (Just 1270)++tinterval = mkPTI LibPQ.Binary 704 (Just 1025)++tsquery = mkPTI LibPQ.Binary 3615 (Just 3645)++tsrange = mkPTI LibPQ.Binary 3908 (Just 3909)++tstzrange = mkPTI LibPQ.Binary 3910 (Just 3911)++tsvector = mkPTI LibPQ.Binary 3614 (Just 3643)++txid_snapshot = mkPTI LibPQ.Binary 2970 (Just 2949)++unknown = mkPTI LibPQ.Text 705 (Just 705)++uuid = mkPTI LibPQ.Binary 2950 (Just 2951)++varbit = mkPTI LibPQ.Binary 1562 (Just 1563)++varchar = mkPTI LibPQ.Binary 1043 (Just 1015)++void = mkPTI LibPQ.Binary 2278 Nothing++xid = mkPTI LibPQ.Binary 28 (Just 1011)++xml = mkPTI LibPQ.Binary 142 (Just 143)
library/Hasql/Private/Prelude.hs view
@@ -1,36 +1,45 @@ module Hasql.Private.Prelude-(-  module Exports,-  LazyByteString,-  ByteStringBuilder,-  LazyText,-  TextBuilder,-  forMToZero_,-  forMFromZero_,-  strictCons,-  mapLeft,-)+  ( module Exports,+    LazyByteString,+    ByteStringBuilder,+    LazyText,+    TextBuilder,+    forMToZero_,+    forMFromZero_,+    strictCons,+    mapLeft,+  ) where ---- base---------------------------import Control.Applicative as Exports hiding (WrappedArrow(..))+import Control.Applicative as Exports hiding (WrappedArrow (..)) import Control.Arrow as Exports hiding (first, second) import Control.Category as Exports import Control.Concurrent as Exports import Control.Exception as Exports-import Control.Monad as Exports hiding (fail, mapM_, sequence_, forM_, msum, mapM, sequence, forM)-import Control.Monad.IO.Class as Exports+import Control.Monad as Exports hiding (fail, forM, forM_, mapM, mapM_, msum, sequence, sequence_)+import Control.Monad.Error.Class as Exports (MonadError (..)) import Control.Monad.Fail as Exports import Control.Monad.Fix as Exports hiding (fix)+import Control.Monad.IO.Class as Exports+import Control.Monad.Reader.Class as Exports (MonadReader (..)) import Control.Monad.ST as Exports+import Control.Monad.Trans.Class as Exports+import Control.Monad.Trans.Cont as Exports hiding (callCC, shift)+import Control.Monad.Trans.Except as Exports (Except, ExceptT (ExceptT), catchE, except, mapExcept, mapExceptT, runExcept, runExceptT, throwE, withExcept, withExceptT)+import Control.Monad.Trans.Maybe as Exports+import Control.Monad.Trans.Reader as Exports (Reader, ReaderT (ReaderT), mapReader, mapReaderT, runReader, runReaderT, withReader, withReaderT)+import Control.Monad.Trans.State.Strict as Exports (State, StateT (StateT), evalState, evalStateT, execState, execStateT, mapState, mapStateT, runState, runStateT, withState, withStateT)+import Control.Monad.Trans.Writer.Strict as Exports (Writer, WriterT (..), execWriter, execWriterT, mapWriter, mapWriterT, runWriter) import Data.Bifunctor as Exports import Data.Bits as Exports import Data.Bool as Exports+import Data.ByteString as Exports (ByteString)+import qualified Data.ByteString.Builder+import qualified Data.ByteString.Lazy import Data.Char as Exports import Data.Coerce as Exports import Data.Complex as Exports+import Data.DList as Exports (DList) import Data.Data as Exports import Data.Dynamic as Exports import Data.Either as Exports@@ -40,22 +49,30 @@ import Data.Functor as Exports import Data.Functor.Compose as Exports import Data.Functor.Contravariant as Exports-import Data.Int as Exports+import Data.Functor.Contravariant.Divisible as Exports+import Data.Functor.Identity as Exports+import Data.Hashable as Exports (Hashable (..)) import Data.IORef as Exports+import Data.Int as Exports import Data.Ix as Exports-import Data.List as Exports hiding (sortOn, isSubsequenceOf, uncons, concat, foldr, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, find, maximumBy, minimumBy, mapAccumL, mapAccumR, foldl')-import Data.List.NonEmpty as Exports (NonEmpty(..))+import Data.List as Exports hiding (all, and, any, concat, concatMap, elem, find, foldl, foldl', foldl1, foldr, foldr1, isSubsequenceOf, mapAccumL, mapAccumR, maximum, maximumBy, minimum, minimumBy, notElem, or, product, sortOn, sum, uncons)+import Data.List.NonEmpty as Exports (NonEmpty (..)) import Data.Maybe as Exports import Data.Monoid as Exports hiding (Alt, (<>)) import Data.Ord as Exports+import Data.Profunctor.Unsafe as Exports import Data.Proxy as Exports import Data.Ratio as Exports-import Data.Semigroup as Exports hiding (First(..), Last(..)) import Data.STRef as Exports+import Data.Semigroup as Exports hiding (First (..), Last (..)) import Data.String as Exports+import Data.Text as Exports (Text)+import qualified Data.Text.Lazy+import qualified Data.Text.Lazy.Builder import Data.Traversable as Exports import Data.Tuple as Exports import Data.Unique as Exports+import Data.Vector as Exports (Vector) import Data.Version as Exports import Data.Void as Exports import Data.Word as Exports@@ -64,13 +81,13 @@ import Foreign.Ptr as Exports import Foreign.StablePtr as Exports import Foreign.Storable as Exports-import GHC.Conc as Exports hiding (orElse, withMVar, threadWaitWriteSTM, threadWaitWrite, threadWaitReadSTM, threadWaitRead)-import GHC.Exts as Exports (IsList(..), lazy, inline, sortWith, groupWith)+import GHC.Conc as Exports hiding (orElse, threadWaitRead, threadWaitReadSTM, threadWaitWrite, threadWaitWriteSTM, withMVar)+import GHC.Exts as Exports (IsList (..), groupWith, inline, lazy, sortWith) import GHC.Generics as Exports (Generic) import GHC.IO.Exception as Exports import GHC.OverloadedLabels as Exports import Numeric as Exports-import Prelude as Exports hiding (Read, fail, concat, foldr, mapM_, sequence_, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, mapM, sequence, id, (.))+import PostgreSQL.Binary.Data as Exports (UUID) import System.Environment as Exports import System.Exit as Exports import System.IO as Exports (Handle, hClose)@@ -80,67 +97,10 @@ import System.Mem.StableName as Exports import System.Timeout as Exports import Text.ParserCombinators.ReadP as Exports (ReadP, readP_to_S, readS_to_P)-import Text.ParserCombinators.ReadPrec as Exports (ReadPrec, readPrec_to_P, readP_to_Prec, readPrec_to_S, readS_to_Prec)-import Text.Printf as Exports (printf, hPrintf)+import Text.ParserCombinators.ReadPrec as Exports (ReadPrec, readP_to_Prec, readPrec_to_P, readPrec_to_S, readS_to_Prec)+import Text.Printf as Exports (hPrintf, printf) import Unsafe.Coerce as Exports---- transformers---------------------------import Control.Monad.IO.Class as Exports-import Control.Monad.Trans.Class as Exports-import Control.Monad.Trans.Cont as Exports hiding (shift, callCC)-import Control.Monad.Trans.Except as Exports (ExceptT(ExceptT), Except, except, runExcept, runExceptT, mapExcept, mapExceptT, withExcept, withExceptT, throwE, catchE)-import Control.Monad.Trans.Maybe as Exports-import Control.Monad.Trans.Reader as Exports (Reader, runReader, mapReader, withReader, ReaderT(ReaderT), runReaderT, mapReaderT, withReaderT)-import Control.Monad.Trans.State.Strict as Exports (State, runState, evalState, execState, mapState, withState, StateT(StateT), runStateT, evalStateT, execStateT, mapStateT, withStateT)-import Control.Monad.Trans.Writer.Strict as Exports (Writer, runWriter, execWriter, mapWriter, WriterT(..), execWriterT, mapWriterT)-import Data.Functor.Compose as Exports-import Data.Functor.Identity as Exports---- mtl---------------------------import Control.Monad.Error.Class as Exports (MonadError (..))-import Control.Monad.Reader.Class as Exports (MonadReader (..))---- profunctors---------------------------import Data.Profunctor.Unsafe as Exports---- contravariant---------------------------import Data.Functor.Contravariant.Divisible as Exports---- hashable---------------------------import Data.Hashable as Exports (Hashable(..))---- text---------------------------import Data.Text as Exports (Text)---- bytestring---------------------------import Data.ByteString as Exports (ByteString)---- vector---------------------------import Data.Vector as Exports (Vector)---- dlist---------------------------import Data.DList as Exports (DList)---- postgresql-binary---------------------------import PostgreSQL.Binary.Data as Exports (UUID)---- custom---------------------------import qualified Data.Text.Lazy-import qualified Data.Text.Lazy.Builder-import qualified Data.ByteString.Lazy-import qualified Data.ByteString.Builder-+import Prelude as Exports hiding (Read, all, and, any, concat, concatMap, elem, fail, foldl, foldl1, foldr, foldr1, id, mapM, mapM_, maximum, minimum, notElem, or, product, sequence, sequence_, sum, (.))  type LazyByteString =   Data.ByteString.Lazy.ByteString
library/Hasql/Private/PreparedStatementRegistry.hs view
@@ -1,26 +1,24 @@ module Hasql.Private.PreparedStatementRegistry-(-  PreparedStatementRegistry,-  new,-  update,-  LocalKey(..),-)+  ( PreparedStatementRegistry,+    new,+    update,+    LocalKey (..),+  ) where -import Hasql.Private.Prelude hiding (lookup)-import qualified Data.HashTable.IO as A import qualified ByteString.StrictBuilder as B-+import qualified Data.HashTable.IO as A+import Hasql.Private.Prelude hiding (lookup) -data PreparedStatementRegistry =-  PreparedStatementRegistry !(A.BasicHashTable LocalKey ByteString) !(IORef Word)+data PreparedStatementRegistry+  = PreparedStatementRegistry !(A.BasicHashTable LocalKey ByteString) !(IORef Word) -{-# INLINABLE new #-}+{-# INLINEABLE new #-} new :: IO PreparedStatementRegistry new =   PreparedStatementRegistry <$> A.new <*> newIORef 0 -{-# INLINABLE update #-}+{-# INLINEABLE update #-} update :: LocalKey -> (ByteString -> IO (Bool, a)) -> (ByteString -> IO a) -> PreparedStatementRegistry -> IO a update localKey onNewRemoteKey onOldRemoteKey (PreparedStatementRegistry table counter) =   lookup >>= maybe new old@@ -43,11 +41,10 @@     old =       onOldRemoteKey - -- | -- Local statement key.-data LocalKey =-  LocalKey !ByteString ![Word32]+data LocalKey+  = LocalKey !ByteString ![Word32]   deriving (Show, Eq)  instance Hashable LocalKey where
library/Hasql/Private/Session.hs view
@@ -1,23 +1,21 @@-module Hasql.Private.Session-where+module Hasql.Private.Session where -import Hasql.Private.Prelude-import Hasql.Private.Errors import qualified Database.PostgreSQL.LibPQ as LibPQ-import qualified Hasql.Private.Decoders.Results as Decoders.Results+import qualified Hasql.Private.Connection as Connection import qualified Hasql.Private.Decoders.Result as Decoders.Result-import qualified Hasql.Private.Encoders.Params as Encoders.Params+import qualified Hasql.Private.Decoders.Results as Decoders.Results import qualified Hasql.Private.Encoders as Encoders-import qualified Hasql.Private.Settings as Settings+import qualified Hasql.Private.Encoders.Params as Encoders.Params+import Hasql.Private.Errors import qualified Hasql.Private.IO as IO+import Hasql.Private.Prelude+import qualified Hasql.Private.Settings as Settings import qualified Hasql.Statement as Statement-import qualified Hasql.Private.Connection as Connection - -- | -- A batch of actions to be executed in the context of a database connection.-newtype Session a =-  Session (ReaderT Connection.Connection (ExceptT QueryError IO) a)+newtype Session a+  = Session (ReaderT Connection.Connection (ExceptT QueryError IO) a)   deriving (Functor, Applicative, Monad, MonadError QueryError, MonadIO, MonadReader Connection.Connection)  -- |@@ -25,7 +23,7 @@ run :: Session a -> Connection.Connection -> IO (Either QueryError a) run (Session impl) connection =   runExceptT $-  runReaderT impl connection+    runReaderT impl connection  -- | -- Possibly a multi-statement query,@@ -33,11 +31,14 @@ -- nor can any results of it be collected. sql :: ByteString -> Session () sql sql =-  Session $ ReaderT $ \(Connection.Connection pqConnectionRef integerDatetimes registry) ->-    ExceptT $ fmap (mapLeft (QueryError sql [])) $ withMVar pqConnectionRef $ \pqConnection -> do-      r1 <- IO.sendNonparametricStatement pqConnection sql-      r2 <- IO.getResults pqConnection integerDatetimes decoder-      return $ r1 *> r2+  Session $+    ReaderT $ \(Connection.Connection pqConnectionRef integerDatetimes registry) ->+      ExceptT $+        fmap (mapLeft (QueryError sql [])) $+          withMVar pqConnectionRef $ \pqConnection -> do+            r1 <- IO.sendNonparametricStatement pqConnection sql+            r2 <- IO.getResults pqConnection integerDatetimes decoder+            return $ r1 *> r2   where     decoder =       Decoders.Results.single Decoders.Result.noResult@@ -46,15 +47,17 @@ -- 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 (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 paramsEncoder preparable input-      r2 <- IO.getResults pqConnection integerDatetimes (unsafeCoerce decoder)-      return $ r1 *> r2+  Session $+    ReaderT $ \(Connection.Connection pqConnectionRef integerDatetimes registry) ->+      ExceptT $+        fmap (mapLeft (QueryError template inputReps)) $+          withMVar pqConnectionRef $ \pqConnection -> do+            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) = paramsEncoder-        step (_, _, _, rendering) acc =-          rendering : acc-        in foldr step [] (encoderOp input)+      let Encoders.Params.Params (Op encoderOp) = paramsEncoder+          step (_, _, _, rendering) acc =+            rendering : acc+       in foldr step [] (encoderOp input)
library/Hasql/Private/Settings.hs view
@@ -1,14 +1,12 @@ module Hasql.Private.Settings where -import Hasql.Private.Prelude import qualified Data.ByteString as B import qualified Data.ByteString.Builder as BB import qualified Data.ByteString.Lazy as BL--+import Hasql.Private.Prelude --- | --- All settings encoded in a single byte-string according to +-- |+-- All settings encoded in a single byte-string according to -- <http://www.postgresql.org/docs/9.4/static/libpq-connect.html#LIBPQ-CONNSTRING the PostgreSQL format>. type Settings =   ByteString@@ -18,21 +16,19 @@ {-# INLINE settings #-} settings :: ByteString -> Word16 -> ByteString -> ByteString -> ByteString -> Settings settings host port user password database =-  BL.toStrict $ BB.toLazyByteString $ mconcat $ intersperse (BB.char7 ' ') $ catMaybes $-  [-    mappend (BB.string7 "host=") . BB.byteString <$> -    mfilter (not . B.null) (pure host)-    ,-    mappend (BB.string7 "port=") . BB.word16Dec <$> -    mfilter (/= 0) (pure port)-    ,-    mappend (BB.string7 "user=") . BB.byteString <$> -    mfilter (not . B.null) (pure user)-    ,-    mappend (BB.string7 "password=") . BB.byteString <$> -    mfilter (not . B.null) (pure password)-    ,-    mappend (BB.string7 "dbname=") . BB.byteString <$> -    mfilter (not . B.null) (pure database)-  ]-+  BL.toStrict $+    BB.toLazyByteString $+      mconcat $+        intersperse (BB.char7 ' ') $+          catMaybes $+            [ mappend (BB.string7 "host=") . BB.byteString+                <$> mfilter (not . B.null) (pure host),+              mappend (BB.string7 "port=") . BB.word16Dec+                <$> mfilter (/= 0) (pure port),+              mappend (BB.string7 "user=") . BB.byteString+                <$> mfilter (not . B.null) (pure user),+              mappend (BB.string7 "password=") . BB.byteString+                <$> mfilter (not . B.null) (pure password),+              mappend (BB.string7 "dbname=") . BB.byteString+                <$> mfilter (not . B.null) (pure database)+            ]
library/Hasql/Session.hs view
@@ -1,14 +1,15 @@ module Hasql.Session-(-  Session,-  sql,-  statement,-  -- * Execution-  run,-  -- * Errors-  module Hasql.Private.Errors,-)+  ( Session,+    sql,+    statement,++    -- * Execution+    run,++    -- * Errors+    module Hasql.Private.Errors,+  ) where -import Hasql.Private.Session import Hasql.Private.Errors+import Hasql.Private.Session
library/Hasql/Statement.hs view
@@ -1,57 +1,56 @@ module Hasql.Statement-(-  Statement(..),-  refineResult,-  -- * Recipies+  ( Statement (..),+    refineResult, -  -- ** Insert many-  -- $insertMany+    -- * Recipies -  -- ** IN and NOT IN-  -- $inAndNotIn-)+    -- ** 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 import qualified Hasql.Private.Decoders as Decoders--{-|-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 a positional notation, as in the following:-@$1@, @$2@, @$3@ and etc.-Those references must be used in accordance with the order in which-the 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.nonNullable' Encoders.'Hasql.Encoders.int8'))-  decoder = Decoders.'Hasql.Decoders.singleRow' (Decoders.'Hasql.Decoders.column' (Decoders.'Hasql.Decoders.nonNullable' Decoders.'Hasql.Decoders.int8'))-@+import Hasql.Private.Prelude -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+-- |+-- 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 a positional notation, as in the following:+-- @$1@, @$2@, @$3@ and etc.+-- Those references must be used in accordance with the order in which+-- the 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.nonNullable' Encoders.'Hasql.Encoders.int8'))+--   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  instance Functor (Statement a) where   {-# INLINE fmap #-}@@ -62,63 +61,59 @@   dimap f1 f2 (Statement template encoder decoder preparable) =     Statement template (contramap f1 encoder) (fmap f2 decoder) preparable -{-|-Refine a result of a statement,-causing the running session to fail with the `UnexpectedResult` error in case of refinement failure.--This function is especially useful for refining the results of statements produced with-<http://hackage.haskell.org/package/hasql-th the \"hasql-th\" library>.--}+-- |+-- Refine a result of a statement,+-- causing the running session to fail with the `UnexpectedResult` error in case of refinement failure.+--+-- This function is especially useful for refining the results of statements produced with+-- <http://hackage.haskell.org/package/hasql-th the \"hasql-th\" library>. refineResult :: (a -> Either Text b) -> Statement params a -> Statement params b refineResult refiner (Statement template encoder decoder preparable) =   Statement template encoder (Decoders.refineResult refiner 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)@+-- $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. -For details see-<https://www.postgresql.org/docs/9.6/static/functions-comparisons.html#AEN20944 the Postgresql docs>.--}+-- $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+-- <https://www.postgresql.org/docs/9.6/static/functions-comparisons.html#AEN20944 the Postgresql docs>.
profiling/Main.hs view
@@ -1,13 +1,12 @@ module Main where -import Prelude+import qualified Data.Vector as F import qualified Hasql.Connection as A-import qualified Hasql.Session as B-import qualified Hasql.Statement as C import qualified Hasql.Decoders as D import qualified Hasql.Encoders as E-import qualified Data.Vector as F-+import qualified Hasql.Session as B+import qualified Hasql.Statement as C+import Prelude  main =   do@@ -29,9 +28,7 @@             password = ""             database = "postgres" - -- * Sessions--------------------------  sessionWithManySmallParameters :: Vector (Int64, Int64) -> B.Session () sessionWithManySmallParameters =@@ -49,9 +46,7 @@ sessionWithManySmallResults =   F.replicateM 1000 (B.statement () statementWithSingleRow) - -- * Statements--------------------------  statementWithManyParameters :: C.Statement (Vector (Int64, Int64)) () statementWithManyParameters =
tasty/Main.hs view
@@ -1,488 +1,434 @@ module Main where +import Contravariant.Extras+import qualified Hasql.Decoders as Decoders+import qualified Hasql.Encoders as Encoders+import qualified Hasql.Session as Session+import qualified Hasql.Statement as Statement+import qualified Main.Connection as Connection+import qualified Main.DSL as DSL import Main.Prelude hiding (assert)+import qualified Main.Statements as Statements+import qualified Test.QuickCheck as QuickCheck import Test.QuickCheck.Instances import Test.Tasty-import Test.Tasty.Runners import Test.Tasty.HUnit import Test.Tasty.QuickCheck-import Contravariant.Extras-import qualified Test.QuickCheck as QuickCheck-import qualified Main.Statements as Statements-import qualified Main.DSL as DSL-import qualified Main.Connection as Connection-import qualified Hasql.Statement as Statement-import qualified Hasql.Encoders as Encoders-import qualified Hasql.Decoders as Decoders-import qualified Hasql.Session as Session+import Test.Tasty.Runners  main =   defaultMain tree  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 =-        Statement.Statement "select true where 1 = any ($1) and $2" encoder decoder True-        where-          encoder =-            contrazip2-              (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.nonNullable) Decoders.bool))-      session =-        Session.statement ([3, 7], "a") statement-      in do-        x <- Connection.with (Session.run session)-        assertBool (show x) $ case x of-          Right (Left (Session.QueryError "select true where 1 = any ($1) and $2" ["[3, 7]", "\"a\""] _)) -> True-          _ -> False-    ,-    testCase "IN simulation" $-    let-      statement =-        Statement.Statement "select true where 1 = any ($1)" encoder decoder True-        where-          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.nonNullable) Decoders.bool))-      session =-        do-          result1 <- Session.statement [1, 2] statement-          result2 <- Session.statement [2, 3] statement-          return (result1, result2)-      in do-        x <- Connection.with (Session.run session)-        assertEqual (show x) (Right (Right (True, False))) x-    ,-    testCase "NOT IN simulation" $-    let-      statement =-        Statement.Statement "select true where 3 <> all ($1)" encoder decoder True-        where-          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.nonNullable) Decoders.bool))-      session =-        do-          result1 <- Session.statement [1, 2] statement-          result2 <- Session.statement [2, 3] statement-          return (result1, result2)-      in do-        x <- Connection.with (Session.run session)-        assertEqual (show x) (Right (Right (True, False))) x-    ,-    testCase "Composite decoding" $-    let-      statement =-        Statement.Statement sql encoder decoder True-        where-          sql =-            "select (1, true)"-          encoder = -            mempty-          decoder =-            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-        x <- Connection.with (Session.run session)-        assertEqual (show x) (Right (Right (1, True))) x-    ,-    testCase "Complex composite decoding" $-    let-      statement =-        Statement.Statement sql encoder decoder True-        where-          sql =-            "select (1, true) as entity1, ('hello', 3) as entity2"-          encoder =-            mempty-          decoder =-            Decoders.singleRow $-            (,) <$> (Decoders.column . Decoders.nonNullable) entity1 <*> (Decoders.column . Decoders.nonNullable) entity2-            where-              entity1 =-                Decoders.composite $-                (,) <$> (Decoders.field . Decoders.nonNullable) Decoders.int8 <*> (Decoders.field . Decoders.nonNullable) Decoders.bool-              entity2 =-                Decoders.composite $-                (,) <$> (Decoders.field . Decoders.nonNullable) Decoders.text <*> (Decoders.field . Decoders.nonNullable) Decoders.int8-      session =-        Session.statement () statement-      in do-        x <- Connection.with (Session.run session)-        assertEqual (show x) (Right (Right ((1, True), ("hello", 3)))) x-    ,-    testCase "Empty array" $-    let-      io =-        do-          x <- Connection.with (Session.run session)-          assertEqual (show x) (Right (Right [])) x-        where-          session =-            Session.statement () statement-            where-              statement =+    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 =+                Statement.Statement "select true where 1 = any ($1) and $2" encoder decoder True+                where+                  encoder =+                    contrazip2+                      (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.nonNullable) Decoders.bool))+              session =+                Session.statement ([3, 7], "a") statement+           in do+                x <- Connection.with (Session.run session)+                assertBool (show x) $ case x of+                  Right (Left (Session.QueryError "select true where 1 = any ($1) and $2" ["[3, 7]", "\"a\""] _)) -> True+                  _ -> False,+        testCase "IN simulation" $+          let statement =+                Statement.Statement "select true where 1 = any ($1)" encoder decoder True+                where+                  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.nonNullable) Decoders.bool))+              session =+                do+                  result1 <- Session.statement [1, 2] statement+                  result2 <- Session.statement [2, 3] statement+                  return (result1, result2)+           in do+                x <- Connection.with (Session.run session)+                assertEqual (show x) (Right (Right (True, False))) x,+        testCase "NOT IN simulation" $+          let statement =+                Statement.Statement "select true where 3 <> all ($1)" encoder decoder True+                where+                  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.nonNullable) Decoders.bool))+              session =+                do+                  result1 <- Session.statement [1, 2] statement+                  result2 <- Session.statement [2, 3] statement+                  return (result1, result2)+           in do+                x <- Connection.with (Session.run session)+                assertEqual (show x) (Right (Right (True, False))) x,+        testCase "Composite decoding" $+          let statement =                 Statement.Statement sql encoder decoder True                 where                   sql =-                    "select array[]::int8[]"+                    "select (1, true)"                   encoder =                     mempty                   decoder =-                    Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.array (Decoders.dimension replicateM (Decoders.element (Decoders.nonNullable Decoders.int8)))))-      in io-    ,-    testCase "Failing prepared statements" $-    let-      io =-        Connection.with (Session.run session) >>=-        (assertBool <$> show <*> resultTest)-        where-          resultTest =-            \case-              Right (Left (Session.QueryError _ _ (Session.ResultError (Session.ServerError "26000" _ _ _)))) -> False-              _ -> True-          session =-            catchError session (const (pure ())) *> session-            where+                    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+                x <- Connection.with (Session.run session)+                assertEqual (show x) (Right (Right (1, True))) x,+        testCase "Complex composite decoding" $+          let statement =+                Statement.Statement sql encoder decoder True                 where-                  statement =-                    Statement.Statement sql encoder decoder True+                  sql =+                    "select (1, true) as entity1, ('hello', 3) as entity2"+                  encoder =+                    mempty+                  decoder =+                    Decoders.singleRow $+                      (,) <$> (Decoders.column . Decoders.nonNullable) entity1 <*> (Decoders.column . Decoders.nonNullable) entity2                     where-                      sql =-                        "absurd"-                      encoder =-                        mempty-                      decoder =-                        Decoders.noResult-      in io-    ,-    testCase "Prepared statements after error" $-    let-      io =-        Connection.with (Session.run session) >>=-        \x -> assertBool (show x) (either (const False) isRight x)-        where-          session =-            try *> fail *> try-            where-              try =-                Session.statement 1 statement+                      entity1 =+                        Decoders.composite $+                          (,) <$> (Decoders.field . Decoders.nonNullable) Decoders.int8 <*> (Decoders.field . Decoders.nonNullable) Decoders.bool+                      entity2 =+                        Decoders.composite $+                          (,) <$> (Decoders.field . Decoders.nonNullable) Decoders.text <*> (Decoders.field . Decoders.nonNullable) Decoders.int8+              session =+                Session.statement () statement+           in do+                x <- Connection.with (Session.run session)+                assertEqual (show x) (Right (Right ((1, True), ("hello", 3)))) x,+        testCase "Empty array" $+          let io =+                do+                  x <- Connection.with (Session.run session)+                  assertEqual (show x) (Right (Right [])) x                 where-                  statement =-                    Statement.Statement sql encoder decoder True+                  session =+                    Session.statement () statement                     where-                      sql =-                        "select $1 :: int8"-                      encoder =-                        Encoders.param (Encoders.nonNullable (Encoders.int8))-                      decoder =-                        Decoders.singleRow $ (Decoders.column . Decoders.nonNullable) Decoders.int8-              fail =-                catchError (Session.sql "absurd") (const (pure ()))-      in io-    ,-    testCase "\"in progress after error\" bugfix" $-    let-      sumStatement :: Statement.Statement (Int64, Int64) Int64-      sumStatement =-        Statement.Statement sql encoder decoder True-        where-          sql =-            "select ($1 + $2)"-          encoder =-            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-      sumSession =-        Session.sql "begin" *> Session.statement (1, 1) sumStatement <* Session.sql "end"-      errorSession :: Session.Session ()-      errorSession =-        Session.sql "asldfjsldk"-      io =-        Connection.with $ \c -> do-          Session.run errorSession c-          Session.run sumSession c-      in io >>= \x -> assertBool (show x) (either (const False) isRight x)-    ,-    testCase "\"another command is already in progress\" bugfix" $-    let-      sumStatement :: Statement.Statement (Int64, Int64) Int64-      sumStatement =-        Statement.Statement sql encoder decoder True-        where-          sql =-            "select ($1 + $2)"-          encoder =-            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-      session =-        do-          Session.sql "begin;"-          s <- Session.statement (1,1) sumStatement-          Session.sql "end;"-          return s-      in DSL.session session >>= \x -> assertEqual (show x) (Right 2) x-    ,-    testCase "Executing the same query twice" $-    pure ()-    ,-    testCase "Interval Encoding" $-    let-      actualIO =-        DSL.session $ do-          let-            statement =-              Statement.Statement sql encoder decoder True-              where-                sql =-                  "select $1 = interval '10 seconds'"-                decoder =-                  (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.bool)))-                encoder =-                  Encoders.param (Encoders.nonNullable (Encoders.interval))-            in DSL.statement (10 :: DiffTime) statement-      in actualIO >>= \x -> assertEqual (show x) (Right True) x-    ,-    testCase "Interval Decoding" $-    let-      actualIO =-        DSL.session $ do-          let-            statement =-              Statement.Statement sql encoder decoder True-              where-                sql =-                  "select interval '10 seconds'"-                decoder =-                  (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.interval)))-                encoder =-                  Encoders.noParams-            in DSL.statement () statement-      in actualIO >>= \x -> assertEqual (show x) (Right (10 :: DiffTime)) x-    ,-    testCase "Interval Encoding/Decoding" $-    let-      actualIO =-        DSL.session $ do-          let-            statement =-              Statement.Statement sql encoder decoder True-              where-                sql =-                  "select $1"-                decoder =-                  (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.interval)))-                encoder =-                  Encoders.param (Encoders.nonNullable (Encoders.interval))-            in DSL.statement (10 :: DiffTime) statement-      in actualIO >>= \x -> assertEqual (show x) (Right (10 :: DiffTime)) x-    ,-    testCase "Unknown" $-    let-      actualIO =-        DSL.session $ do-          let-            statement =-              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.noResult True-              where-                sql =-                  "create type mood as enum ('sad', 'ok', 'happy')"-            in DSL.statement () statement-          let-            statement =-              Statement.Statement sql encoder decoder True-              where-                sql =-                  "select $1 = ('ok' :: mood)"-                decoder =-                  (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.bool)))-                encoder =-                  Encoders.param (Encoders.nonNullable (Encoders.unknown))-            in DSL.statement "ok" statement-      in actualIO >>= assertEqual "" (Right True)-    ,-    testCase "Textual Unknown" $-    let-      actualIO =-        DSL.session $ do-          let-            statement =-              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.noResult True-              where-                sql =-                  "create or replace function overloaded(a text, b text, c text) returns text as $$ select a || b || c $$ language sql;"-            in DSL.statement () statement-          let-            statement =-              Statement.Statement sql encoder decoder True-              where-                sql =-                  "select overloaded($1, $2) || overloaded($3, $4, $5)"-                decoder =-                  (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.text)))-                encoder =-                  contramany (Encoders.param (Encoders.nonNullable (Encoders.unknown)))-            in DSL.statement ["1", "2", "4", "5", "6"] statement-      in actualIO >>= assertEqual "" (Right "3456")-    ,-    testCase "Enum" $-    let-      actualIO =-        DSL.session $ do-          let-            statement =-              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.noResult True-              where-                sql =-                  "create type mood as enum ('sad', 'ok', 'happy')"-            in DSL.statement () statement-          let-            statement =-              Statement.Statement sql encoder decoder True-              where-                sql =-                  "select ($1 :: mood)"-                decoder =-                  (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.enum (Just . id))))-                encoder =-                  Encoders.param (Encoders.nonNullable ((Encoders.enum id)))-            in DSL.statement "ok" statement-      in actualIO >>= assertEqual "" (Right "ok")-    ,-    testCase "The same prepared statement used on different types" $ -    let-      actualIO =-        DSL.session $ do-          let-            effect1 =-              DSL.statement "ok" statement-              where-                statement =-                  Statement.Statement sql encoder decoder True-                  where-                    sql =-                      "select $1"-                    encoder =-                      Encoders.param (Encoders.nonNullable (Encoders.text))-                    decoder =-                      (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.text)))-            effect2 =-              DSL.statement 1 statement-              where-                statement =-                  Statement.Statement sql encoder decoder True+                      statement =+                        Statement.Statement sql encoder decoder True+                        where+                          sql =+                            "select array[]::int8[]"+                          encoder =+                            mempty+                          decoder =+                            Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.array (Decoders.dimension replicateM (Decoders.element (Decoders.nonNullable Decoders.int8)))))+           in io,+        testCase "Failing prepared statements" $+          let io =+                Connection.with (Session.run session)+                  >>= (assertBool <$> show <*> resultTest)+                where+                  resultTest =+                    \case+                      Right (Left (Session.QueryError _ _ (Session.ResultError (Session.ServerError "26000" _ _ _)))) -> False+                      _ -> True+                  session =+                    catchError session (const (pure ())) *> session+                    where+                      session =+                        Session.statement () statement+                        where+                          statement =+                            Statement.Statement sql encoder decoder True+                            where+                              sql =+                                "absurd"+                              encoder =+                                mempty+                              decoder =+                                Decoders.noResult+           in io,+        testCase "Prepared statements after error" $+          let io =+                Connection.with (Session.run session)+                  >>= \x -> assertBool (show x) (either (const False) isRight x)+                where+                  session =+                    try *> fail *> try+                    where+                      try =+                        Session.statement 1 statement+                        where+                          statement =+                            Statement.Statement sql encoder decoder True+                            where+                              sql =+                                "select $1 :: int8"+                              encoder =+                                Encoders.param (Encoders.nonNullable (Encoders.int8))+                              decoder =+                                Decoders.singleRow $ (Decoders.column . Decoders.nonNullable) Decoders.int8+                      fail =+                        catchError (Session.sql "absurd") (const (pure ()))+           in io,+        testCase "\"in progress after error\" bugfix" $+          let sumStatement :: Statement.Statement (Int64, Int64) Int64+              sumStatement =+                Statement.Statement sql encoder decoder True+                where+                  sql =+                    "select ($1 + $2)"+                  encoder =+                    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+              sumSession =+                Session.sql "begin" *> Session.statement (1, 1) sumStatement <* Session.sql "end"+              errorSession :: Session.Session ()+              errorSession =+                Session.sql "asldfjsldk"+              io =+                Connection.with $ \c -> do+                  Session.run errorSession c+                  Session.run sumSession c+           in io >>= \x -> assertBool (show x) (either (const False) isRight x),+        testCase "\"another command is already in progress\" bugfix" $+          let sumStatement :: Statement.Statement (Int64, Int64) Int64+              sumStatement =+                Statement.Statement sql encoder decoder True+                where+                  sql =+                    "select ($1 + $2)"+                  encoder =+                    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+              session =+                do+                  Session.sql "begin;"+                  s <- Session.statement (1, 1) sumStatement+                  Session.sql "end;"+                  return s+           in DSL.session session >>= \x -> assertEqual (show x) (Right 2) x,+        testCase "Executing the same query twice" $+          pure (),+        testCase "Interval Encoding" $+          let actualIO =+                DSL.session $ do+                  let statement =+                        Statement.Statement sql encoder decoder True+                        where+                          sql =+                            "select $1 = interval '10 seconds'"+                          decoder =+                            (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.bool)))+                          encoder =+                            Encoders.param (Encoders.nonNullable (Encoders.interval))+                   in DSL.statement (10 :: DiffTime) statement+           in actualIO >>= \x -> assertEqual (show x) (Right True) x,+        testCase "Interval Decoding" $+          let actualIO =+                DSL.session $ do+                  let statement =+                        Statement.Statement sql encoder decoder True+                        where+                          sql =+                            "select interval '10 seconds'"+                          decoder =+                            (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.interval)))+                          encoder =+                            Encoders.noParams+                   in DSL.statement () statement+           in actualIO >>= \x -> assertEqual (show x) (Right (10 :: DiffTime)) x,+        testCase "Interval Encoding/Decoding" $+          let actualIO =+                DSL.session $ do+                  let statement =+                        Statement.Statement sql encoder decoder True+                        where+                          sql =+                            "select $1"+                          decoder =+                            (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.interval)))+                          encoder =+                            Encoders.param (Encoders.nonNullable (Encoders.interval))+                   in DSL.statement (10 :: DiffTime) statement+           in actualIO >>= \x -> assertEqual (show x) (Right (10 :: DiffTime)) x,+        testCase "Unknown" $+          let actualIO =+                DSL.session $ do+                  let statement =+                        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.noResult True+                        where+                          sql =+                            "create type mood as enum ('sad', 'ok', 'happy')"+                   in DSL.statement () statement+                  let statement =+                        Statement.Statement sql encoder decoder True+                        where+                          sql =+                            "select $1 = ('ok' :: mood)"+                          decoder =+                            (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.bool)))+                          encoder =+                            Encoders.param (Encoders.nonNullable (Encoders.unknown))+                   in DSL.statement "ok" statement+           in actualIO >>= assertEqual "" (Right True),+        testCase "Textual Unknown" $+          let actualIO =+                DSL.session $ do+                  let statement =+                        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.noResult True+                        where+                          sql =+                            "create or replace function overloaded(a text, b text, c text) returns text as $$ select a || b || c $$ language sql;"+                   in DSL.statement () statement+                  let statement =+                        Statement.Statement sql encoder decoder True+                        where+                          sql =+                            "select overloaded($1, $2) || overloaded($3, $4, $5)"+                          decoder =+                            (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.text)))+                          encoder =+                            contramany (Encoders.param (Encoders.nonNullable (Encoders.unknown)))+                   in DSL.statement ["1", "2", "4", "5", "6"] statement+           in actualIO >>= assertEqual "" (Right "3456"),+        testCase "Enum" $+          let actualIO =+                DSL.session $ do+                  let statement =+                        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.noResult True+                        where+                          sql =+                            "create type mood as enum ('sad', 'ok', 'happy')"+                   in DSL.statement () statement+                  let statement =+                        Statement.Statement sql encoder decoder True+                        where+                          sql =+                            "select ($1 :: mood)"+                          decoder =+                            (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.enum (Just . id))))+                          encoder =+                            Encoders.param (Encoders.nonNullable ((Encoders.enum id)))+                   in DSL.statement "ok" statement+           in actualIO >>= assertEqual "" (Right "ok"),+        testCase "The same prepared statement used on different types" $+          let actualIO =+                DSL.session $ do+                  let effect1 =+                        DSL.statement "ok" statement+                        where+                          statement =+                            Statement.Statement sql encoder decoder True+                            where+                              sql =+                                "select $1"+                              encoder =+                                Encoders.param (Encoders.nonNullable (Encoders.text))+                              decoder =+                                (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.text)))+                      effect2 =+                        DSL.statement 1 statement+                        where+                          statement =+                            Statement.Statement sql encoder decoder True+                            where+                              sql =+                                "select $1"+                              encoder =+                                Encoders.param (Encoders.nonNullable (Encoders.int8))+                              decoder =+                                (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) Decoders.int8))+                   in (,) <$> effect1 <*> effect2+           in actualIO >>= assertEqual "" (Right ("ok", 1)),+        testCase "Affected rows counting" $+          replicateM_ 13 $+            let actualIO =+                  DSL.session $ do+                    dropTable+                    createTable+                    replicateM_ 100 insertRow+                    deleteRows <* dropTable                   where-                    sql =-                      "select $1"-                    encoder =-                      Encoders.param (Encoders.nonNullable (Encoders.int8))-                    decoder =-                      (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) Decoders.int8))-            in (,) <$> effect1 <*> effect2-      in actualIO >>= assertEqual "" (Right ("ok", 1))-    ,-    testCase "Affected rows counting" $-    replicateM_ 13 $-    let-      actualIO =-        DSL.session $ do-          dropTable-          createTable-          replicateM_ 100 insertRow-          deleteRows <* dropTable-        where-          dropTable =-            DSL.statement () $ Statements.plain $ -            "drop table if exists a"-          createTable =-            DSL.statement () $ Statements.plain $-            "create table a (id bigserial not null, name varchar not null, primary key (id))"-          insertRow =-            DSL.statement () $ Statements.plain $-            "insert into a (name) values ('a')"  -          deleteRows =-            DSL.statement () $ Statement.Statement sql mempty decoder False-            where-              sql =-                "delete from a"-              decoder =-                Decoders.rowsAffected-      in actualIO >>= assertEqual "" (Right 100)-    ,-    testCase "Result of an auto-incremented column" $-    let-      actualIO =-        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.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-    ,-    testCase "List decoding" $-    let-      actualIO =-        DSL.session $ DSL.statement () $ Statements.selectList-      in assertEqual "" (Right [(1, 2), (3, 4), (5, 6)]) =<< actualIO -  ]-+                    dropTable =+                      DSL.statement () $+                        Statements.plain $+                          "drop table if exists a"+                    createTable =+                      DSL.statement () $+                        Statements.plain $+                          "create table a (id bigserial not null, name varchar not null, primary key (id))"+                    insertRow =+                      DSL.statement () $+                        Statements.plain $+                          "insert into a (name) values ('a')"+                    deleteRows =+                      DSL.statement () $ Statement.Statement sql mempty decoder False+                      where+                        sql =+                          "delete from a"+                        decoder =+                          Decoders.rowsAffected+             in actualIO >>= assertEqual "" (Right 100),+        testCase "Result of an auto-incremented column" $+          let actualIO =+                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.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,+        testCase "List decoding" $+          let actualIO =+                DSL.session $ DSL.statement () $ Statements.selectList+           in assertEqual "" (Right [(1, 2), (3, 4), (5, 6)]) =<< actualIO+      ]
tasty/Main/Connection.hs view
@@ -1,11 +1,9 @@-module Main.Connection-where+module Main.Connection where -import Main.Prelude import qualified Hasql.Connection as HC-import qualified Hasql.Statement as HQ import qualified Hasql.Session-+import qualified Hasql.Statement as HQ+import Main.Prelude  with :: (HC.Connection -> IO a) -> IO (Either HC.ConnectionError a) with handler =
tasty/Main/DSL.hs view
@@ -1,27 +1,25 @@ module Main.DSL-(-  Session,-  SessionError(..),-  session,-  Hasql.Session.statement,-  Hasql.Session.sql,-)+  ( Session,+    SessionError (..),+    session,+    Hasql.Session.statement,+    Hasql.Session.sql,+  ) where -import Main.Prelude import qualified Hasql.Connection as HC-import qualified Hasql.Statement as HQ-import qualified Hasql.Encoders as HE import qualified Hasql.Decoders as HD+import qualified Hasql.Encoders as HE import qualified Hasql.Session-+import qualified Hasql.Statement as HQ+import Main.Prelude  type Session =   Hasql.Session.Session -data SessionError =-  ConnectionError (HC.ConnectionError) |-  SessionError (Hasql.Session.QueryError)+data SessionError+  = ConnectionError (HC.ConnectionError)+  | SessionError (Hasql.Session.QueryError)   deriving (Show, Eq)  session :: Session a -> IO (Either SessionError a)@@ -41,7 +39,7 @@             database = "postgres"     use connection =       ExceptT $-      fmap (mapLeft SessionError) $-      Hasql.Session.run session connection+        fmap (mapLeft SessionError) $+          Hasql.Session.run session connection     release connection =       lift $ HC.release connection
tasty/Main/Prelude.hs view
@@ -1,10 +1,6 @@ module Main.Prelude-(-  module Exports,-)+  ( module Exports,+  ) where ---- rerebase-------------------------- import Prelude as Exports
tasty/Main/Statements.hs view
@@ -1,12 +1,11 @@ module Main.Statements where -import Main.Prelude-import qualified Hasql.Statement as HQ-import qualified Hasql.Encoders as HE import qualified Hasql.Decoders as HD+import qualified Hasql.Encoders as HE+import qualified Hasql.Statement as HQ+import Main.Prelude import qualified Main.Prelude as Prelude - plain :: ByteString -> HQ.Statement () () plain sql =   HQ.Statement sql mempty HD.noResult False@@ -19,8 +18,9 @@ createEnum :: ByteString -> [ByteString] -> HQ.Statement () () createEnum name values =   plain $-    "create type " <> name <> " as enum (" <> -    mconcat (intersperse ", " (map (\x -> "'" <> x <> "'") values)) <> ")"+    "create type " <> name <> " as enum ("+      <> mconcat (intersperse ", " (map (\x -> "'" <> x <> "'") values))+      <> ")"  selectList :: HQ.Statement () ([] (Int64, Int64)) selectList =
threads-test/Main.hs view
@@ -1,13 +1,12 @@ module Main where -import Prelude import qualified Hasql.Connection-import qualified Hasql.Statement-import qualified Hasql.Encoders import qualified Hasql.Decoders+import qualified Hasql.Encoders import qualified Hasql.Session+import qualified Hasql.Statement import qualified Main.Statements as Statements-+import Prelude  main =   acquire >>= use@@ -17,8 +16,8 @@       where         acquire =           join $-          fmap (either (fail . show) return) $-          Hasql.Connection.acquire connectionSettings+            fmap (either (fail . show) return) $+              Hasql.Connection.acquire connectionSettings           where             connectionSettings =               Hasql.Connection.settings "localhost" 5432 "postgres" "" "postgres"@@ -41,5 +40,5 @@         bool exitFailure exitSuccess . traceShowId =<< takeMVar finishVar       where         session connection session =-          Hasql.Session.run session connection >>=-          either (fail . show) return+          Hasql.Session.run session connection+            >>= either (fail . show) return
threads-test/Main/Statements.hs view
@@ -1,10 +1,9 @@ module Main.Statements where -import Prelude-import Hasql.Statement-import qualified Hasql.Encoders as E import qualified Hasql.Decoders as D-+import qualified Hasql.Encoders as E+import Hasql.Statement+import Prelude  selectSleep :: Statement Double () selectSleep =@@ -16,5 +15,3 @@       E.param (E.nonNullable E.float8)     decoder =       D.noResult--