packages feed

hasql 0.14.0.3 → 0.15.0.2

raw patch · 31 files changed

+1815/−1818 lines, 31 files

Files

benchmark/Main.hs view
@@ -5,8 +5,8 @@ import qualified Hasql.Connection as HC import qualified Hasql.Settings as HS import qualified Hasql.Query as HQ-import qualified Hasql.Encoding as HE-import qualified Hasql.Decoding as HD+import qualified Hasql.Encoders as HE+import qualified Hasql.Decoders as HD import qualified Main.Queries as Q
benchmark/Main/Queries.hs view
@@ -2,8 +2,8 @@  import Main.Prelude import qualified Hasql.Query as HQ-import qualified Hasql.Encoding as HE-import qualified Hasql.Decoding as HD+import qualified Hasql.Encoders as HE+import qualified Hasql.Decoders as HD   select1 :: Int -> HQ.Query () (Vector Int64)
hasql.cabal view
@@ -1,7 +1,7 @@ name:   hasql version:-  0.14.0.3+  0.15.0.2 category:   Hasql, Database, PostgreSQL synopsis:@@ -50,20 +50,20 @@     Hasql.PTI     Hasql.IO     Hasql.Commands-    Hasql.Decoding.Array-    Hasql.Decoding.Composite-    Hasql.Decoding.Value-    Hasql.Decoding.Row-    Hasql.Decoding.Result-    Hasql.Decoding.Results-    Hasql.Encoding.Array-    Hasql.Encoding.Value-    Hasql.Encoding.Params+    Hasql.Decoders.Array+    Hasql.Decoders.Composite+    Hasql.Decoders.Value+    Hasql.Decoders.Row+    Hasql.Decoders.Result+    Hasql.Decoders.Results+    Hasql.Encoders.Array+    Hasql.Encoders.Value+    Hasql.Encoders.Params     Hasql.PreparedStatementRegistry     Hasql.Connection.Impl   exposed-modules:-    Hasql.Decoding-    Hasql.Encoding+    Hasql.Decoders+    Hasql.Encoders     Hasql.Settings     Hasql.Connection     Hasql.Query@@ -99,8 +99,6 @@     base >= 4.6 && < 5  --- Note that this test-suite is supposed to be single-threaded.--- Hence the absense of the appropriate GHC flags. test-suite tasty   type:     exitcode-stdio-1.0
library/Hasql/Commands.hs view
@@ -2,7 +2,7 @@ (   Commands,   asBytes,-  setEncodingToUTF8,+  setEncodersToUTF8,   setMinClientMessagesToWarning, ) where@@ -22,8 +22,8 @@ asBytes (Commands list) =   BL.toStrict $ BB.toLazyByteString $ foldMap (<> BB.char7 ';') $ list -setEncodingToUTF8 :: Commands-setEncodingToUTF8 =+setEncodersToUTF8 :: Commands+setEncodersToUTF8 =   Commands (pure "SET client_encoding = 'UTF8'")  setMinClientMessagesToWarning :: Commands
+ library/Hasql/Decoders.hs view
@@ -0,0 +1,669 @@+-- |+-- A DSL for declaration of result decoders.+module Hasql.Decoders+(+  -- * Result+  Result,+  unit,+  rowsAffected,+  singleRow,+  -- ** Specialized multi-row results+  maybeRow,+  rowsVector,+  rowsList,+  -- ** Multi-row traversers+  foldlRows,+  foldrRows,+  -- * Row+  Row,+  value,+  nullableValue,+  -- * Value+  Value,+  bool,+  int2,+  int4,+  int8,+  float4,+  float8,+  numeric,+  char,+  text,+  bytea,+  date,+  timestamp,+  timestamptz,+  time,+  timetz,+  interval,+  uuid,+  json,+  array,+  composite,+  hstore,+  enum,+  -- * Array+  Array,+  arrayDimension,+  arrayValue,+  arrayNullableValue,+  -- * Composite+  Composite,+  compositeValue,+  compositeNullableValue,+)+where++import Hasql.Prelude hiding (maybe, bool)+import qualified Data.Aeson as Aeson+import qualified Data.Vector as Vector+import qualified PostgreSQL.Binary.Decoder as Decoder+import qualified Hasql.Decoders.Results as Results+import qualified Hasql.Decoders.Result as Result+import qualified Hasql.Decoders.Row as Row+import qualified Hasql.Decoders.Value as Value+import qualified Hasql.Decoders.Array as Array+import qualified Hasql.Decoders.Composite as Composite+import qualified Hasql.Prelude as Prelude+++-- * Result+-------------------------++-- |+-- Decoder of a query result.+-- +newtype Result a =+  Result (Results.Results a)+  deriving (Functor)++-- |+-- Decode no value from the result.+-- +-- Useful for statements like @INSERT@ or @CREATE@.+-- +{-# INLINABLE unit #-}+unit :: Result ()+unit =+  Result (Results.single Result.unit)++-- |+-- Get the amount of rows affected by such statements as+-- @UPDATE@ or @DELETE@.+-- +{-# INLINABLE rowsAffected #-}+rowsAffected :: Result Int64+rowsAffected =+  Result (Results.single Result.rowsAffected)++-- |+-- Exactly one row.+-- Will raise the 'Hasql.Query.UnexpectedAmountOfRows' error if it's any other.+-- +{-# INLINABLE singleRow #-}+singleRow :: Row a -> Result a+singleRow (Row row) =+  Result (Results.single (Result.single row))++-- ** Multi-row traversers+-------------------------++-- |+-- Foldl multiple rows.+-- +{-# INLINABLE foldlRows #-}+foldlRows :: (a -> b -> a) -> a -> Row b -> Result a+foldlRows step init (Row row) =+  Result (Results.single (Result.foldl step init row))++-- |+-- Foldr multiple rows.+-- +{-# INLINABLE foldrRows #-}+foldrRows :: (b -> a -> a) -> a -> Row b -> Result a+foldrRows step init (Row row) =+  Result (Results.single (Result.foldr step init row))++-- ** Specialized multi-row results+-------------------------++-- |+-- Maybe one row or none.+-- +{-# INLINABLE maybeRow #-}+maybeRow :: Row a -> Result (Maybe a)+maybeRow (Row row) =+  Result (Results.single (Result.maybe row))++-- |+-- Zero or more rows packed into the vector.+-- +-- It's recommended to prefer this function to 'rowsList',+-- since it performs notably better.+-- +{-# INLINABLE rowsVector #-}+rowsVector :: Row a -> Result (Vector a)+rowsVector (Row row) =+  Result (Results.single (Result.vector row))++-- |+-- Zero or more rows packed into the list.+-- +{-# INLINABLE rowsList #-}+rowsList :: Row a -> Result [a]+rowsList =+  foldrRows strictCons []+++-- ** Instances+-------------------------++-- | Maps to 'unit'.+instance Default (Result ()) where+  {-# INLINE def #-}+  def =+    unit++-- | Maps to 'rowsAffected'.+instance Default (Result Int64) where+  {-# INLINE def #-}+  def =+    rowsAffected++-- | Maps to @('maybeRow' def)@.+instance Default (Row a) => Default (Result (Maybe a)) where+  {-# INLINE def #-}+  def =+    maybeRow def++-- | Maps to @('rowsVector' def)@.+instance Default (Row a) => Default (Result (Vector a)) where+  {-# INLINE def #-}+  def =+    rowsVector def++-- | Maps to @('rowsList' def)@.+instance Default (Row a) => Default (Result ([] a)) where+  {-# INLINE def #-}+  def =+    rowsList def++-- | Maps to @(fmap Identity ('singleRow' def)@.+instance Default (Row a) => Default (Result (Identity a)) where+  {-# INLINE def #-}+  def =+    fmap Identity (singleRow def)+++-- * Row+-------------------------++-- |+-- Decoder of an individual row,+-- which gets composed of column value decoders.+-- +-- E.g.:+-- +-- >x :: Row (Maybe Int64, Text, TimeOfDay)+-- >x =+-- >  (,,) <$> nullableValue int8 <*> value text <*> value time+-- +newtype Row a =+  Row (Row.Row a)+  deriving (Functor, Applicative, Monad)++-- |+-- Lift an individual non-nullable value decoder to a composable row decoder.+-- +{-# INLINABLE value #-}+value :: Value a -> Row a+value (Value imp) =+  Row (Row.nonNullValue imp)++-- |+-- Lift an individual nullable value decoder to a composable row decoder.+-- +{-# INLINABLE nullableValue #-}+nullableValue :: Value a -> Row (Maybe a)+nullableValue (Value imp) =+  Row (Row.value imp)+++-- ** Instances+-------------------------++instance Default (Value a) => Default (Row (Identity a)) where+  {-# INLINE def #-}+  def =+    fmap Identity (value def)++instance Default (Value a) => Default (Row (Maybe a)) where+  {-# INLINE def #-}+  def =+    nullableValue def++instance (Default (Value a1), Default (Value a2)) => Default (Row (a1, a2)) where+  {-# INLINE def #-}+  def =+    ap (fmap (,) (value def)) (value def)+++-- * Value+-------------------------++-- |+-- Decoder of an individual value.+-- +newtype Value a =+  Value (Value.Value a)+  deriving (Functor)+++-- ** Plain value decoders+-------------------------++-- |+-- Decoder of the @BOOL@ values.+-- +{-# INLINABLE bool #-}+bool :: Value Bool+bool =+  Value (Value.decoder (const Decoder.bool))++-- |+-- Decoder of the @INT2@ values.+-- +{-# INLINABLE int2 #-}+int2 :: Value Int16+int2 =+  Value (Value.decoder (const Decoder.int))++-- |+-- Decoder of the @INT4@ values.+-- +{-# INLINABLE int4 #-}+int4 :: Value Int32+int4 =+  Value (Value.decoder (const Decoder.int))++-- |+-- Decoder of the @INT8@ values.+-- +{-# INLINABLE int8 #-}+int8 :: Value Int64+int8 =+  {-# SCC "int8" #-} +  Value (Value.decoder (const ({-# SCC "int8.int" #-} Decoder.int)))++-- |+-- Decoder of the @FLOAT4@ values.+-- +{-# INLINABLE float4 #-}+float4 :: Value Float+float4 =+  Value (Value.decoder (const Decoder.float4))++-- |+-- Decoder of the @FLOAT8@ values.+-- +{-# INLINABLE float8 #-}+float8 :: Value Double+float8 =+  Value (Value.decoder (const Decoder.float8))++-- |+-- Decoder of the @NUMERIC@ values.+-- +{-# INLINABLE numeric #-}+numeric :: Value Scientific+numeric =+  Value (Value.decoder (const Decoder.numeric))++-- |+-- Decoder of the @CHAR@ values.+-- Note that it supports UTF-8 values.+{-# INLINABLE char #-}+char :: Value Char+char =+  Value (Value.decoder (const Decoder.char))++-- |+-- Decoder of the @TEXT@ values.+-- +{-# INLINABLE text #-}+text :: Value Text+text =+  Value (Value.decoder (const Decoder.text_strict))++-- |+-- Decoder of the @BYTEA@ values.+-- +{-# INLINABLE bytea #-}+bytea :: Value ByteString+bytea =+  Value (Value.decoder (const Decoder.bytea_strict))++-- |+-- Decoder of the @DATE@ values.+-- +{-# INLINABLE date #-}+date :: Value Day+date =+  Value (Value.decoder (const Decoder.date))++-- |+-- Decoder of the @TIMESTAMP@ values.+-- +{-# INLINABLE timestamp #-}+timestamp :: Value LocalTime+timestamp =+  Value (Value.decoder (Prelude.bool Decoder.timestamp_float Decoder.timestamp_int))++-- |+-- Decoder of the @TIMESTAMPTZ@ values.+-- +-- /NOTICE/+-- +-- Postgres does not store the timezone information of @TIMESTAMPTZ@.+-- Instead it stores a UTC value and performs silent conversions+-- to the currently set timezone, when dealt with in the text format.+-- However this library bypasses the silent conversions+-- and communicates with Postgres using the UTC values directly.+{-# INLINABLE timestamptz #-}+timestamptz :: Value UTCTime+timestamptz =+  Value (Value.decoder (Prelude.bool Decoder.timestamptz_float Decoder.timestamptz_int))++-- |+-- Decoder of the @TIME@ values.+-- +{-# INLINABLE time #-}+time :: Value TimeOfDay+time =+  Value (Value.decoder (Prelude.bool Decoder.time_float Decoder.time_int))++-- |+-- Decoder of the @TIMETZ@ values.+-- +-- Unlike in case of @TIMESTAMPTZ@, +-- Postgres does store the timezone information for @TIMETZ@.+-- However the Haskell's \"time\" library does not contain any composite type,+-- that fits the task, so we use a pair of 'TimeOfDay' and 'TimeZone'+-- to represent a value on the Haskell's side.+{-# INLINABLE timetz #-}+timetz :: Value (TimeOfDay, TimeZone)+timetz =+  Value (Value.decoder (Prelude.bool Decoder.timetz_float Decoder.timetz_int))++-- |+-- Decoder of the @INTERVAL@ values.+-- +{-# INLINABLE interval #-}+interval :: Value DiffTime+interval =+  Value (Value.decoder (Prelude.bool Decoder.interval_float Decoder.interval_int))++-- |+-- Decoder of the @UUID@ values.+-- +{-# INLINABLE uuid #-}+uuid :: Value UUID+uuid =+  Value (Value.decoder (const Decoder.uuid))++-- |+-- Decoder of the @JSON@ values.+-- +{-# INLINABLE json #-}+json :: Value Aeson.Value+json =+  Value (Value.decoder (const Decoder.json))+++-- ** Composite value decoders+-------------------------++-- |+-- Lifts the 'Array' decoder to the 'Value' decoder.+-- +{-# INLINABLE array #-}+array :: Array a -> Value a+array (Array imp) =+  Value (Value.decoder (Array.run imp))++-- |+-- Lifts the 'Composite' decoder to the 'Value' decoder.+-- +{-# INLINABLE composite #-}+composite :: Composite a -> Value a+composite (Composite imp) =+  Value (Value.decoder (Composite.run imp))++-- |+-- A generic decoder of @HSTORE@ values.+-- +-- Here's how you can use it to construct a specific value:+-- +-- @+-- x :: Value [(Text, Maybe Text)]+-- x =+--   hstore 'replicateM'+-- @+-- +{-# INLINABLE hstore #-}+hstore :: (forall m. Monad m => Int -> m (Text, Maybe Text) -> m a) -> Value a+hstore replicateM =+  Value (Value.decoder (const (Decoder.hstore replicateM Decoder.text_strict Decoder.text_strict)))++-- |+-- Given a partial mapping from text to value,+-- produces a decoder of that value.+enum :: (Text -> Maybe a) -> Value a+enum mapping =+  Value (Value.decoder (const (Decoder.enum mapping)))+++-- ** Instances+-------------------------++-- |+-- Maps to 'bool'.+instance Default (Value Bool) where+  {-# INLINE def #-}+  def =+    bool++-- |+-- Maps to 'int2'.+instance Default (Value Int16) where+  {-# INLINE def #-}+  def =+    int2++-- |+-- Maps to 'int4'.+instance Default (Value Int32) where+  {-# INLINE def #-}+  def =+    int4++-- |+-- Maps to 'int8'.+instance Default (Value Int64) where+  {-# INLINE def #-}+  def =+    int8++-- |+-- Maps to 'float4'.+instance Default (Value Float) where+  {-# INLINE def #-}+  def =+    float4++-- |+-- Maps to 'float8'.+instance Default (Value Double) where+  {-# INLINE def #-}+  def =+    float8++-- |+-- Maps to 'numeric'.+instance Default (Value Scientific) where+  {-# INLINE def #-}+  def =+    numeric++-- |+-- Maps to 'char'.+instance Default (Value Char) where+  {-# INLINE def #-}+  def =+    char++-- |+-- Maps to 'text'.+instance Default (Value Text) where+  {-# INLINE def #-}+  def =+    text++-- |+-- Maps to 'bytea'.+instance Default (Value ByteString) where+  {-# INLINE def #-}+  def =+    bytea++-- |+-- Maps to 'date'.+instance Default (Value Day) where+  {-# INLINE def #-}+  def =+    date++-- |+-- Maps to 'timestamp'.+instance Default (Value LocalTime) where+  {-# INLINE def #-}+  def =+    timestamp++-- |+-- Maps to 'timestamptz'.+instance Default (Value UTCTime) where+  {-# INLINE def #-}+  def =+    timestamptz++-- |+-- Maps to 'time'.+instance Default (Value TimeOfDay) where+  {-# INLINE def #-}+  def =+    time++-- |+-- Maps to 'timetz'.+instance Default (Value (TimeOfDay, TimeZone)) where+  {-# INLINE def #-}+  def =+    timetz++-- |+-- Maps to 'interval'.+instance Default (Value DiffTime) where+  {-# INLINE def #-}+  def =+    interval++-- |+-- Maps to 'uuid'.+instance Default (Value UUID) where+  {-# INLINE def #-}+  def =+    uuid++-- |+-- Maps to 'json'.+instance Default (Value Aeson.Value) where+  {-# INLINE def #-}+  def =+    json+++-- * Array decoders+-------------------------++-- |+-- A generic array decoder.+-- +-- Here's how you can use it to produce a specific array value decoder:+-- +-- @+-- x :: Value [[Text]]+-- x =+--   array (arrayDimension 'replicateM' (arrayDimension 'replicateM' (arrayValue 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 'arrayDimension',+-- 'arrayValue' or 'arrayNullableValue'.+-- +{-# INLINABLE arrayDimension #-}+arrayDimension :: (forall m. Monad m => Int -> m a -> m b) -> Array a -> Array b+arrayDimension replicateM (Array imp) =+  Array (Array.dimension replicateM imp)++-- |+-- Lift a 'Value' decoder into an 'Array' decoder for parsing of non-nullable leaf values.+{-# INLINABLE arrayValue #-}+arrayValue :: Value a -> Array a+arrayValue (Value imp) =+  Array (Array.nonNullValue (Value.run imp))++-- |+-- Lift a 'Value' decoder into an 'Array' decoder for parsing of nullable leaf values.+{-# INLINABLE arrayNullableValue #-}+arrayNullableValue :: Value a -> Array (Maybe a)+arrayNullableValue (Value imp) =+  Array (Array.value (Value.run imp))+++-- * Composite decoders+-------------------------++-- |+-- Composable decoder of composite values (rows, records).+newtype Composite a =+  Composite (Composite.Composite a)+  deriving (Functor, Applicative, Monad)++-- |+-- Lift a 'Value' decoder into a 'Composite' decoder for parsing of non-nullable leaf values.+{-# INLINABLE compositeValue #-}+compositeValue :: Value a -> Composite a+compositeValue (Value imp) =+  Composite (Composite.nonNullValue (Value.run imp))++-- |+-- Lift a 'Value' decoder into a 'Composite' decoder for parsing of nullable leaf values.+{-# INLINABLE compositeNullableValue #-}+compositeNullableValue :: Value a -> Composite (Maybe a)+compositeNullableValue (Value imp) =+  Composite (Composite.value (Value.run imp))+
+ library/Hasql/Decoders/Array.hs view
@@ -0,0 +1,31 @@+module Hasql.Decoders.Array where++import Hasql.Prelude+import qualified Database.PostgreSQL.LibPQ as LibPQ+import qualified PostgreSQL.Binary.Decoder as Decoder+++newtype Array a =+  Array (ReaderT Bool Decoder.ArrayDecoder a)+  deriving (Functor)++{-# INLINE run #-}+run :: Array a -> Bool -> Decoder.Decoder a+run (Array imp) env =+  Decoder.array (runReaderT imp env)++{-# INLINE dimension #-}+dimension :: (forall m. Monad m => Int -> m a -> m b) -> Array a -> Array b+dimension replicateM (Array imp) =+  Array $ ReaderT $ \env -> Decoder.arrayDimension replicateM (runReaderT imp env)++{-# INLINE value #-}+value :: (Bool -> Decoder.Decoder a) -> Array (Maybe a)+value decoder' =+  Array $ ReaderT $ Decoder.arrayValue . decoder'++{-# INLINE nonNullValue #-}+nonNullValue :: (Bool -> Decoder.Decoder a) -> Array a+nonNullValue decoder' =+  Array $ ReaderT $ Decoder.arrayNonNullValue . decoder'+
+ library/Hasql/Decoders/Composite.hs view
@@ -0,0 +1,26 @@+module Hasql.Decoders.Composite where++import Hasql.Prelude+import qualified Database.PostgreSQL.LibPQ as LibPQ+import qualified PostgreSQL.Binary.Decoder as Decoder+++newtype Composite a =+  Composite (ReaderT Bool Decoder.CompositeDecoder a)+  deriving (Functor, Applicative, Monad)++{-# INLINE run #-}+run :: Composite a -> Bool -> Decoder.Decoder a+run (Composite imp) env =+  Decoder.composite (runReaderT imp env)++{-# INLINE value #-}+value :: (Bool -> Decoder.Decoder a) -> Composite (Maybe a)+value decoder' =+  Composite $ ReaderT $ Decoder.compositeValue . decoder'++{-# INLINE nonNullValue #-}+nonNullValue :: (Bool -> Decoder.Decoder a) -> Composite a+nonNullValue decoder' =+  Composite $ ReaderT $ Decoder.compositeNonNullValue . decoder'+
+ library/Hasql/Decoders/Result.hs view
@@ -0,0 +1,232 @@+module Hasql.Decoders.Result where++import Hasql.Prelude hiding (maybe, many)+import qualified Database.PostgreSQL.LibPQ as LibPQ+import qualified Hasql.Decoders.Row as Row+import qualified Data.Attoparsec.ByteString.Char8 as Attoparsec+import qualified Data.ByteString as ByteString+import qualified Hasql.Prelude as Prelude+import qualified Data.Vector as Vector+import qualified Data.Vector.Mutable as MutableVector+++newtype Result a =+  Result (ReaderT (Bool, LibPQ.Result) (EitherT Error IO) a)+  deriving (Functor, Applicative, Monad)++data Error =+  -- | +  -- An error reported by the DB. Code, message, details, hint.+  -- +  -- * The SQLSTATE code for the error. The SQLSTATE code identifies the type of error that has occurred; +  -- it can be used by front-end applications to perform specific operations (such as error handling) +  -- in response to a particular database error. +  -- For a list of the possible SQLSTATE codes, see Appendix A.+  -- This field is not localizable, and is always present.+  -- +  -- * The primary human-readable error message (typically one line). Always present.+  -- +  -- * Detail: an optional secondary error message carrying more detail about the problem. +  -- Might run to multiple lines.+  -- +  -- * Hint: an optional suggestion 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 index of the row.+  RowError !Int !Row.Error |+  -- |+  -- An unexpected amount of rows.+  UnexpectedAmountOfRows !Int+  deriving (Show)++{-# INLINE run #-}+run :: Result a -> (Bool, LibPQ.Result) -> IO (Either Error a)+run (Result reader) env =+  runEitherT (runReaderT reader env)++{-# INLINE unit #-}+unit :: Result ()+unit =+  checkExecStatus $ \case+    LibPQ.CommandOk -> True+    LibPQ.TuplesOk -> True+    _ -> False++{-# INLINE rowsAffected #-}+rowsAffected :: Result Int64+rowsAffected =+  do+    checkExecStatus $ \case+      LibPQ.CommandOk -> True+      _ -> False+    Result $ ReaderT $ \(_, result) -> EitherT $+      LibPQ.cmdTuples result & fmap cmdTuplesReader+  where+    cmdTuplesReader =+      notNothing >=> notEmpty >=> decimal+      where+        notNothing =+          Prelude.maybe (Left (UnexpectedResult "No bytes")) Right+        notEmpty bytes =+          if ByteString.null bytes+            then Left (UnexpectedResult "Empty bytes")+            else Right bytes+        decimal bytes =+          mapLeft (\m -> UnexpectedResult ("Decimal parsing failure: " <> fromString m)) $+          Attoparsec.parseOnly (Attoparsec.decimal <* Attoparsec.endOfInput) bytes++{-# INLINE checkExecStatus #-}+checkExecStatus :: (LibPQ.ExecStatus -> Bool) -> Result ()+checkExecStatus predicate =+  {-# SCC "checkExecStatus" #-} +  do+    status <- Result $ ReaderT $ \(_, result) -> lift $ LibPQ.resultStatus result+    unless (predicate status) $ do+      case status of+        LibPQ.BadResponse   -> serverError+        LibPQ.NonfatalError -> serverError+        LibPQ.FatalError    -> serverError+        _ -> Result $ lift $ EitherT $ pure $ Left $ UnexpectedResult $ "Unexpected result status: " <> (fromString $ show status)++{-# INLINE serverError #-}+serverError :: Result ()+serverError =+  Result $ ReaderT $ \(_, result) -> EitherT $ do+    code <- +      fmap (fromMaybe ($bug "No code")) $+      LibPQ.resultErrorField result LibPQ.DiagSqlstate+    message <- +      fmap (fromMaybe ($bug "No message")) $+      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)+maybe rowDec =+  do+    checkExecStatus $ \case+      LibPQ.TuplesOk -> True+      _ -> False+    Result $ ReaderT $ \(integerDatetimes, result) -> EitherT $ do+      maxRows <- LibPQ.ntuples result+      case maxRows of+        0 -> return (Right Nothing)+        1 -> do+          maxCols <- LibPQ.nfields result+          fmap (fmap Just . mapLeft (RowError 0)) $ Row.run rowDec (result, 0, maxCols, integerDatetimes)+        _ -> return (Left (UnexpectedAmountOfRows (rowToInt maxRows)))+  where+    rowToInt (LibPQ.Row n) =+      fromIntegral n+    intToRow =+      LibPQ.Row . fromIntegral++{-# INLINE single #-}+single :: Row.Row a -> Result a+single rowDec =+  do+    checkExecStatus $ \case+      LibPQ.TuplesOk -> True+      _ -> False+    Result $ ReaderT $ \(integerDatetimes, result) -> EitherT $ do+      maxRows <- LibPQ.ntuples result+      case maxRows of+        1 -> do+          maxCols <- LibPQ.nfields result+          fmap (mapLeft (RowError 0)) $ Row.run rowDec (result, 0, maxCols, integerDatetimes)+        _ -> return (Left (UnexpectedAmountOfRows (rowToInt maxRows)))+  where+    rowToInt (LibPQ.Row n) =+      fromIntegral n+    intToRow =+      LibPQ.Row . fromIntegral++{-# INLINE vector #-}+vector :: Row.Row a -> Result (Vector a)+vector rowDec =+  do+    checkExecStatus $ \case+      LibPQ.TuplesOk -> True+      _ -> False+    Result $ ReaderT $ \(integerDatetimes, result) -> EitherT $ 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 !x -> writeIORef failureRef (Just (RowError rowIndex 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+    intToRow =+      LibPQ.Row . fromIntegral++{-# INLINE foldl #-}+foldl :: (a -> b -> a) -> a -> Row.Row b -> Result a+foldl step init rowDec =+  {-# SCC "foldl" #-} +  do+    checkExecStatus $ \case+      LibPQ.TuplesOk -> True+      _ -> False+    Result $ ReaderT $ \(integerDatetimes, result) -> EitherT $ {-# 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 !x -> writeIORef failureRef (Just (RowError rowIndex 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+    intToRow =+      LibPQ.Row . fromIntegral++{-# INLINE foldr #-}+foldr :: (b -> a -> a) -> a -> Row.Row b -> Result a+foldr step init rowDec =+  {-# SCC "foldr" #-} +  do+    checkExecStatus $ \case+      LibPQ.TuplesOk -> True+      _ -> False+    Result $ ReaderT $ \(integerDatetimes, result) -> EitherT $ 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 !x -> writeIORef failureRef (Just (RowError rowIndex 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+    intToRow =+      LibPQ.Row . fromIntegral
+ library/Hasql/Decoders/Results.hs view
@@ -0,0 +1,90 @@+-- |+-- 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.Decoders.Results where++import Hasql.Prelude hiding (maybe, many)+import qualified Database.PostgreSQL.LibPQ as LibPQ+import qualified Hasql.Prelude as Prelude+import qualified Hasql.Decoders.Result as Result+import qualified Hasql.Decoders.Row as Row+++newtype Results a =+  Results (ReaderT (Bool, LibPQ.Connection) (EitherT Error IO) a)+  deriving (Functor, Applicative, Monad)++data Error =+  -- |+  -- An error on the client-side,+  -- with a message generated by the \"libpq\" library.+  -- Usually indicates problems with the connection.+  ClientError !(Maybe ByteString) |+  ResultError !Result.Error++{-# INLINE run #-}+run :: Results a -> (Bool, LibPQ.Connection) -> IO (Either Error a)+run (Results stack) env =+  runEitherT (runReaderT stack env)++{-# INLINE clientError #-}+clientError :: Results a+clientError =+  Results $ ReaderT $ \(_, connection) -> EitherT $+  fmap (Left . ClientError) (LibPQ.errorMessage connection)++-- |+-- Parse a single result.+{-# INLINE single #-}+single :: Result.Result a -> Results a+single resultDec =+  Results $ ReaderT $ \(integerDatetimes, connection) -> EitherT $ 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) -> EitherT $ do+    resultMaybe <- LibPQ.getResult connection+    case resultMaybe of+      Just result -> pure (Right result)+      Nothing -> fmap (Left . ClientError) (LibPQ.errorMessage connection)++-- |+-- Fetch a single result.+{-# INLINE getResultMaybe #-}+getResultMaybe :: Results (Maybe LibPQ.Result)+getResultMaybe =+  Results $ ReaderT $ \(_, connection) -> lift $ LibPQ.getResult connection++{-# INLINE dropRemainders #-}+dropRemainders :: Results ()+dropRemainders =+  {-# SCC "dropRemainders" #-} +  Results $ ReaderT $ \(integerDatetimes, connection) -> loop integerDatetimes connection+  where+    loop integerDatetimes connection =+      getResultMaybe >>= Prelude.maybe (pure ()) onResult+      where+        getResultMaybe =+          lift $ LibPQ.getResult connection+        onResult result =+          checkErrors *> loop integerDatetimes connection+          where+            checkErrors =+              EitherT $ fmap (mapLeft ResultError) $ Result.run Result.unit (integerDatetimes, result)
+ library/Hasql/Decoders/Row.hs view
@@ -0,0 +1,65 @@+module Hasql.Decoders.Row where++import Hasql.Prelude+import qualified Database.PostgreSQL.LibPQ as LibPQ+import qualified PostgreSQL.Binary.Decoder as Decoder+import qualified Hasql.Decoders.Value as Value+++newtype Row a =+  Row (ReaderT Env (EitherT Error IO) a)+  deriving (Functor, Applicative, Monad)++data Env =+  Env !LibPQ.Result !LibPQ.Row !LibPQ.Column !Bool !(IORef LibPQ.Column)++data Error =+  EndOfInput |+  UnexpectedNull |+  ValueError !Text+  deriving (Show)+++-- * Functions+-------------------------++{-# INLINE run #-}+run :: Row a -> (LibPQ.Result, LibPQ.Row, LibPQ.Column, Bool) -> IO (Either Error a)+run (Row impl) (result, row, columnsAmount, integerDatetimes) =+  do+    columnRef <- newIORef 0+    runEitherT (runReaderT impl (Env result row columnsAmount integerDatetimes columnRef))++{-# INLINE error #-}+error :: Error -> Row a+error x =+  Row (ReaderT (const (EitherT (pure (Left x)))))++-- |+-- Next value, decoded using the provided value decoder.+{-# INLINE value #-}+value :: Value.Value a -> Row (Maybe a)+value valueDec =+  {-# SCC "value" #-} +  Row $ ReaderT $ \(Env result row columnsAmount integerDatetimes columnRef) -> EitherT $ 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" #-} Decoder.run (Value.run valueDec integerDatetimes) value+      else pure (Left EndOfInput)++-- |+-- Next value, decoded using the provided value decoder.+{-# INLINE nonNullValue #-}+nonNullValue :: Value.Value a -> Row a+nonNullValue valueDec =+  {-# SCC "nonNullValue" #-} +  value valueDec >>= maybe (error UnexpectedNull) pure
+ library/Hasql/Decoders/Value.hs view
@@ -0,0 +1,23 @@+module Hasql.Decoders.Value where++import Hasql.Prelude+import qualified Database.PostgreSQL.LibPQ as LibPQ+import qualified PostgreSQL.Binary.Decoder as Decoder+++newtype Value a =+  Value (ReaderT Bool Decoder.Decoder a)+  deriving (Functor)+++{-# INLINE run #-}+run :: Value a -> Bool -> Decoder.Decoder a+run (Value imp) integerDatetimes =+  runReaderT imp integerDatetimes++{-# INLINE decoder #-}+decoder :: (Bool -> Decoder.Decoder a) -> Value a+decoder =+  {-# SCC "decoder" #-} +  Value . ReaderT+
− library/Hasql/Decoding.hs 
@@ -1,669 +0,0 @@--- |--- A DSL for declaration of result decoders.-module Hasql.Decoding-(-  -- * Result-  Result,-  unit,-  rowsAffected,-  singleRow,-  -- ** Specialized multi-row results-  maybeRow,-  rowsVector,-  rowsList,-  -- ** Multi-row traversers-  foldlRows,-  foldrRows,-  -- * Row-  Row,-  value,-  nullableValue,-  -- * Value-  Value,-  bool,-  int2,-  int4,-  int8,-  float4,-  float8,-  numeric,-  char,-  text,-  bytea,-  date,-  timestamp,-  timestamptz,-  time,-  timetz,-  interval,-  uuid,-  json,-  array,-  composite,-  hstore,-  enum,-  -- * Array-  Array,-  arrayDimension,-  arrayValue,-  arrayNullableValue,-  -- * Composite-  Composite,-  compositeValue,-  compositeNullableValue,-)-where--import Hasql.Prelude hiding (maybe, bool)-import qualified Data.Aeson as Aeson-import qualified Data.Vector as Vector-import qualified PostgreSQL.Binary.Decoder as Decoder-import qualified Hasql.Decoding.Results as Results-import qualified Hasql.Decoding.Result as Result-import qualified Hasql.Decoding.Row as Row-import qualified Hasql.Decoding.Value as Value-import qualified Hasql.Decoding.Array as Array-import qualified Hasql.Decoding.Composite as Composite-import qualified Hasql.Prelude as Prelude----- * Result------------------------------ |--- Decoder of a query result.--- -newtype Result a =-  Result (Results.Results a)-  deriving (Functor)---- |--- Decode no value from the result.--- --- Useful for statements like @INSERT@ or @CREATE@.--- -{-# INLINABLE unit #-}-unit :: Result ()-unit =-  Result (Results.single Result.unit)---- |--- Get the amount of rows affected by such statements as--- @UPDATE@ or @DELETE@.--- -{-# INLINABLE rowsAffected #-}-rowsAffected :: Result Int64-rowsAffected =-  Result (Results.single Result.rowsAffected)---- |--- Exactly one row.--- Will raise the 'Hasql.Query.UnexpectedAmountOfRows' error if it's any other.--- -{-# INLINABLE singleRow #-}-singleRow :: Row a -> Result a-singleRow (Row row) =-  Result (Results.single (Result.single row))---- ** Multi-row traversers------------------------------ |--- Foldl multiple rows.--- -{-# INLINABLE foldlRows #-}-foldlRows :: (a -> b -> a) -> a -> Row b -> Result a-foldlRows step init (Row row) =-  Result (Results.single (Result.foldl step init row))---- |--- Foldr multiple rows.--- -{-# INLINABLE foldrRows #-}-foldrRows :: (b -> a -> a) -> a -> Row b -> Result a-foldrRows step init (Row row) =-  Result (Results.single (Result.foldr step init row))---- ** Specialized multi-row results------------------------------ |--- Maybe one row or none.--- -{-# INLINABLE maybeRow #-}-maybeRow :: Row a -> Result (Maybe a)-maybeRow (Row row) =-  Result (Results.single (Result.maybe row))---- |--- Zero or more rows packed into the vector.--- --- It's recommended to prefer this function to 'rowsList',--- since it performs notably better.--- -{-# INLINABLE rowsVector #-}-rowsVector :: Row a -> Result (Vector a)-rowsVector (Row row) =-  Result (Results.single (Result.vector row))---- |--- Zero or more rows packed into the list.--- -{-# INLINABLE rowsList #-}-rowsList :: Row a -> Result [a]-rowsList =-  foldrRows strictCons []----- ** Instances------------------------------ | Maps to 'unit'.-instance Default (Result ()) where-  {-# INLINE def #-}-  def =-    unit---- | Maps to 'rowsAffected'.-instance Default (Result Int64) where-  {-# INLINE def #-}-  def =-    rowsAffected---- | Maps to @('maybeRow' def)@.-instance Default (Row a) => Default (Result (Maybe a)) where-  {-# INLINE def #-}-  def =-    maybeRow def---- | Maps to @('rowsVector' def)@.-instance Default (Row a) => Default (Result (Vector a)) where-  {-# INLINE def #-}-  def =-    rowsVector def---- | Maps to @('rowsList' def)@.-instance Default (Row a) => Default (Result ([] a)) where-  {-# INLINE def #-}-  def =-    rowsList def---- | Maps to @(fmap Identity ('singleRow' def)@.-instance Default (Row a) => Default (Result (Identity a)) where-  {-# INLINE def #-}-  def =-    fmap Identity (singleRow def)----- * Row------------------------------ |--- Decoder of an individual row,--- which gets composed of column value decoders.--- --- E.g.:--- --- >x :: Row (Maybe Int64, Text, TimeOfDay)--- >x =--- >  (,,) <$> nullableValue int8 <*> value text <*> value time--- -newtype Row a =-  Row (Row.Row a)-  deriving (Functor, Applicative, Monad)---- |--- Lift an individual non-nullable value decoder to a composable row decoder.--- -{-# INLINABLE value #-}-value :: Value a -> Row a-value (Value imp) =-  Row (Row.nonNullValue imp)---- |--- Lift an individual nullable value decoder to a composable row decoder.--- -{-# INLINABLE nullableValue #-}-nullableValue :: Value a -> Row (Maybe a)-nullableValue (Value imp) =-  Row (Row.value imp)----- ** Instances----------------------------instance Default (Value a) => Default (Row (Identity a)) where-  {-# INLINE def #-}-  def =-    fmap Identity (value def)--instance Default (Value a) => Default (Row (Maybe a)) where-  {-# INLINE def #-}-  def =-    nullableValue def--instance (Default (Value a1), Default (Value a2)) => Default (Row (a1, a2)) where-  {-# INLINE def #-}-  def =-    ap (fmap (,) (value def)) (value def)----- * Value------------------------------ |--- Decoder of an individual value.--- -newtype Value a =-  Value (Value.Value a)-  deriving (Functor)----- ** Plain value decoders------------------------------ |--- Decoder of the @BOOL@ values.--- -{-# INLINABLE bool #-}-bool :: Value Bool-bool =-  Value (Value.decoder (const Decoder.bool))---- |--- Decoder of the @INT2@ values.--- -{-# INLINABLE int2 #-}-int2 :: Value Int16-int2 =-  Value (Value.decoder (const Decoder.int))---- |--- Decoder of the @INT4@ values.--- -{-# INLINABLE int4 #-}-int4 :: Value Int32-int4 =-  Value (Value.decoder (const Decoder.int))---- |--- Decoder of the @INT8@ values.--- -{-# INLINABLE int8 #-}-int8 :: Value Int64-int8 =-  {-# SCC "int8" #-} -  Value (Value.decoder (const ({-# SCC "int8.int" #-} Decoder.int)))---- |--- Decoder of the @FLOAT4@ values.--- -{-# INLINABLE float4 #-}-float4 :: Value Float-float4 =-  Value (Value.decoder (const Decoder.float4))---- |--- Decoder of the @FLOAT8@ values.--- -{-# INLINABLE float8 #-}-float8 :: Value Double-float8 =-  Value (Value.decoder (const Decoder.float8))---- |--- Decoder of the @NUMERIC@ values.--- -{-# INLINABLE numeric #-}-numeric :: Value Scientific-numeric =-  Value (Value.decoder (const Decoder.numeric))---- |--- Decoder of the @CHAR@ values.--- Note that it supports UTF-8 values.-{-# INLINABLE char #-}-char :: Value Char-char =-  Value (Value.decoder (const Decoder.char))---- |--- Decoder of the @TEXT@ values.--- -{-# INLINABLE text #-}-text :: Value Text-text =-  Value (Value.decoder (const Decoder.text_strict))---- |--- Decoder of the @BYTEA@ values.--- -{-# INLINABLE bytea #-}-bytea :: Value ByteString-bytea =-  Value (Value.decoder (const Decoder.bytea_strict))---- |--- Decoder of the @DATE@ values.--- -{-# INLINABLE date #-}-date :: Value Day-date =-  Value (Value.decoder (const Decoder.date))---- |--- Decoder of the @TIMESTAMP@ values.--- -{-# INLINABLE timestamp #-}-timestamp :: Value LocalTime-timestamp =-  Value (Value.decoder (Prelude.bool Decoder.timestamp_float Decoder.timestamp_int))---- |--- Decoder of the @TIMESTAMPTZ@ values.--- --- /NOTICE/--- --- Postgres does not store the timezone information of @TIMESTAMPTZ@.--- Instead it stores a UTC value and performs silent conversions--- to the currently set timezone, when dealt with in the text format.--- However this library bypasses the silent conversions--- and communicates with Postgres using the UTC values directly.-{-# INLINABLE timestamptz #-}-timestamptz :: Value UTCTime-timestamptz =-  Value (Value.decoder (Prelude.bool Decoder.timestamptz_float Decoder.timestamptz_int))---- |--- Decoder of the @TIME@ values.--- -{-# INLINABLE time #-}-time :: Value TimeOfDay-time =-  Value (Value.decoder (Prelude.bool Decoder.time_float Decoder.time_int))---- |--- Decoder of the @TIMETZ@ values.--- --- Unlike in case of @TIMESTAMPTZ@, --- Postgres does store the timezone information for @TIMETZ@.--- However the Haskell's \"time\" library does not contain any composite type,--- that fits the task, so we use a pair of 'TimeOfDay' and 'TimeZone'--- to represent a value on the Haskell's side.-{-# INLINABLE timetz #-}-timetz :: Value (TimeOfDay, TimeZone)-timetz =-  Value (Value.decoder (Prelude.bool Decoder.timetz_float Decoder.timetz_int))---- |--- Decoder of the @INTERVAL@ values.--- -{-# INLINABLE interval #-}-interval :: Value DiffTime-interval =-  Value (Value.decoder (Prelude.bool Decoder.interval_float Decoder.interval_int))---- |--- Decoder of the @UUID@ values.--- -{-# INLINABLE uuid #-}-uuid :: Value UUID-uuid =-  Value (Value.decoder (const Decoder.uuid))---- |--- Decoder of the @JSON@ values.--- -{-# INLINABLE json #-}-json :: Value Aeson.Value-json =-  Value (Value.decoder (const Decoder.json))----- ** Composite value decoders------------------------------ |--- Lifts the 'Array' decoder to the 'Value' decoder.--- -{-# INLINABLE array #-}-array :: Array a -> Value a-array (Array imp) =-  Value (Value.decoder (Array.run imp))---- |--- Lifts the 'Composite' decoder to the 'Value' decoder.--- -{-# INLINABLE composite #-}-composite :: Composite a -> Value a-composite (Composite imp) =-  Value (Value.decoder (Composite.run imp))---- |--- A generic decoder of @HSTORE@ values.--- --- Here's how you can use it to construct a specific value:--- --- @--- x :: Value [(Text, Maybe Text)]--- x =---   hstore 'replicateM'--- @--- -{-# INLINABLE hstore #-}-hstore :: (forall m. Monad m => Int -> m (Text, Maybe Text) -> m a) -> Value a-hstore replicateM =-  Value (Value.decoder (const (Decoder.hstore replicateM Decoder.text_strict Decoder.text_strict)))---- |--- Given a partial mapping from text to value,--- produces a decoder of that value.-enum :: (Text -> Maybe a) -> Value a-enum mapping =-  Value (Value.decoder (const (Decoder.enum mapping)))----- ** Instances------------------------------ |--- Maps to 'bool'.-instance Default (Value Bool) where-  {-# INLINE def #-}-  def =-    bool---- |--- Maps to 'int2'.-instance Default (Value Int16) where-  {-# INLINE def #-}-  def =-    int2---- |--- Maps to 'int4'.-instance Default (Value Int32) where-  {-# INLINE def #-}-  def =-    int4---- |--- Maps to 'int8'.-instance Default (Value Int64) where-  {-# INLINE def #-}-  def =-    int8---- |--- Maps to 'float4'.-instance Default (Value Float) where-  {-# INLINE def #-}-  def =-    float4---- |--- Maps to 'float8'.-instance Default (Value Double) where-  {-# INLINE def #-}-  def =-    float8---- |--- Maps to 'numeric'.-instance Default (Value Scientific) where-  {-# INLINE def #-}-  def =-    numeric---- |--- Maps to 'char'.-instance Default (Value Char) where-  {-# INLINE def #-}-  def =-    char---- |--- Maps to 'text'.-instance Default (Value Text) where-  {-# INLINE def #-}-  def =-    text---- |--- Maps to 'bytea'.-instance Default (Value ByteString) where-  {-# INLINE def #-}-  def =-    bytea---- |--- Maps to 'date'.-instance Default (Value Day) where-  {-# INLINE def #-}-  def =-    date---- |--- Maps to 'timestamp'.-instance Default (Value LocalTime) where-  {-# INLINE def #-}-  def =-    timestamp---- |--- Maps to 'timestamptz'.-instance Default (Value UTCTime) where-  {-# INLINE def #-}-  def =-    timestamptz---- |--- Maps to 'time'.-instance Default (Value TimeOfDay) where-  {-# INLINE def #-}-  def =-    time---- |--- Maps to 'timetz'.-instance Default (Value (TimeOfDay, TimeZone)) where-  {-# INLINE def #-}-  def =-    timetz---- |--- Maps to 'interval'.-instance Default (Value DiffTime) where-  {-# INLINE def #-}-  def =-    interval---- |--- Maps to 'uuid'.-instance Default (Value UUID) where-  {-# INLINE def #-}-  def =-    uuid---- |--- Maps to 'json'.-instance Default (Value Aeson.Value) where-  {-# INLINE def #-}-  def =-    json----- * Array decoders------------------------------ |--- A generic array decoder.--- --- Here's how you can use it to produce a specific array value decoder:--- --- @--- x :: Value [[Text]]--- x =---   array (arrayDimension 'replicateM' (arrayDimension 'replicateM' (arrayValue 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 'arrayDimension',--- 'arrayValue' or 'arrayNullableValue'.--- -{-# INLINABLE arrayDimension #-}-arrayDimension :: (forall m. Monad m => Int -> m a -> m b) -> Array a -> Array b-arrayDimension replicateM (Array imp) =-  Array (Array.dimension replicateM imp)---- |--- Lift a 'Value' decoder into an 'Array' decoder for parsing of non-nullable leaf values.-{-# INLINABLE arrayValue #-}-arrayValue :: Value a -> Array a-arrayValue (Value imp) =-  Array (Array.nonNullValue (Value.run imp))---- |--- Lift a 'Value' decoder into an 'Array' decoder for parsing of nullable leaf values.-{-# INLINABLE arrayNullableValue #-}-arrayNullableValue :: Value a -> Array (Maybe a)-arrayNullableValue (Value imp) =-  Array (Array.value (Value.run imp))----- * Composite decoders------------------------------ |--- Composable decoder of composite values (rows, records).-newtype Composite a =-  Composite (Composite.Composite a)-  deriving (Functor, Applicative, Monad)---- |--- Lift a 'Value' decoder into a 'Composite' decoder for parsing of non-nullable leaf values.-{-# INLINABLE compositeValue #-}-compositeValue :: Value a -> Composite a-compositeValue (Value imp) =-  Composite (Composite.nonNullValue (Value.run imp))---- |--- Lift a 'Value' decoder into a 'Composite' decoder for parsing of nullable leaf values.-{-# INLINABLE compositeNullableValue #-}-compositeNullableValue :: Value a -> Composite (Maybe a)-compositeNullableValue (Value imp) =-  Composite (Composite.value (Value.run imp))-
− library/Hasql/Decoding/Array.hs 
@@ -1,31 +0,0 @@-module Hasql.Decoding.Array where--import Hasql.Prelude-import qualified Database.PostgreSQL.LibPQ as LibPQ-import qualified PostgreSQL.Binary.Decoder as Decoder---newtype Array a =-  Array (ReaderT Bool Decoder.ArrayDecoder a)-  deriving (Functor)--{-# INLINE run #-}-run :: Array a -> Bool -> Decoder.Decoder a-run (Array imp) env =-  Decoder.array (runReaderT imp env)--{-# INLINE dimension #-}-dimension :: (forall m. Monad m => Int -> m a -> m b) -> Array a -> Array b-dimension replicateM (Array imp) =-  Array $ ReaderT $ \env -> Decoder.arrayDimension replicateM (runReaderT imp env)--{-# INLINE value #-}-value :: (Bool -> Decoder.Decoder a) -> Array (Maybe a)-value decoder' =-  Array $ ReaderT $ Decoder.arrayValue . decoder'--{-# INLINE nonNullValue #-}-nonNullValue :: (Bool -> Decoder.Decoder a) -> Array a-nonNullValue decoder' =-  Array $ ReaderT $ Decoder.arrayNonNullValue . decoder'-
− library/Hasql/Decoding/Composite.hs 
@@ -1,26 +0,0 @@-module Hasql.Decoding.Composite where--import Hasql.Prelude-import qualified Database.PostgreSQL.LibPQ as LibPQ-import qualified PostgreSQL.Binary.Decoder as Decoder---newtype Composite a =-  Composite (ReaderT Bool Decoder.CompositeDecoder a)-  deriving (Functor, Applicative, Monad)--{-# INLINE run #-}-run :: Composite a -> Bool -> Decoder.Decoder a-run (Composite imp) env =-  Decoder.composite (runReaderT imp env)--{-# INLINE value #-}-value :: (Bool -> Decoder.Decoder a) -> Composite (Maybe a)-value decoder' =-  Composite $ ReaderT $ Decoder.compositeValue . decoder'--{-# INLINE nonNullValue #-}-nonNullValue :: (Bool -> Decoder.Decoder a) -> Composite a-nonNullValue decoder' =-  Composite $ ReaderT $ Decoder.compositeNonNullValue . decoder'-
− library/Hasql/Decoding/Result.hs 
@@ -1,232 +0,0 @@-module Hasql.Decoding.Result where--import Hasql.Prelude hiding (maybe, many)-import qualified Database.PostgreSQL.LibPQ as LibPQ-import qualified Hasql.Decoding.Row as Row-import qualified Data.Attoparsec.ByteString.Char8 as Attoparsec-import qualified Data.ByteString as ByteString-import qualified Hasql.Prelude as Prelude-import qualified Data.Vector as Vector-import qualified Data.Vector.Mutable as MutableVector---newtype Result a =-  Result (ReaderT (Bool, LibPQ.Result) (EitherT Error IO) a)-  deriving (Functor, Applicative, Monad)--data Error =-  -- | -  -- An error reported by the DB. Code, message, details, hint.-  -- -  -- * The SQLSTATE code for the error. The SQLSTATE code identifies the type of error that has occurred; -  -- it can be used by front-end applications to perform specific operations (such as error handling) -  -- in response to a particular database error. -  -- For a list of the possible SQLSTATE codes, see Appendix A.-  -- This field is not localizable, and is always present.-  -- -  -- * The primary human-readable error message (typically one line). Always present.-  -- -  -- * Detail: an optional secondary error message carrying more detail about the problem. -  -- Might run to multiple lines.-  -- -  -- * Hint: an optional suggestion 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 index of the row.-  RowError !Int !Row.Error |-  -- |-  -- An unexpected amount of rows.-  UnexpectedAmountOfRows !Int-  deriving (Show)--{-# INLINE run #-}-run :: Result a -> (Bool, LibPQ.Result) -> IO (Either Error a)-run (Result reader) env =-  runEitherT (runReaderT reader env)--{-# INLINE unit #-}-unit :: Result ()-unit =-  checkExecStatus $ \case-    LibPQ.CommandOk -> True-    LibPQ.TuplesOk -> True-    _ -> False--{-# INLINE rowsAffected #-}-rowsAffected :: Result Int64-rowsAffected =-  do-    checkExecStatus $ \case-      LibPQ.CommandOk -> True-      _ -> False-    Result $ ReaderT $ \(_, result) -> EitherT $-      LibPQ.cmdTuples result & fmap cmdTuplesReader-  where-    cmdTuplesReader =-      notNothing >=> notEmpty >=> decimal-      where-        notNothing =-          Prelude.maybe (Left (UnexpectedResult "No bytes")) Right-        notEmpty bytes =-          if ByteString.null bytes-            then Left (UnexpectedResult "Empty bytes")-            else Right bytes-        decimal bytes =-          mapLeft (\m -> UnexpectedResult ("Decimal parsing failure: " <> fromString m)) $-          Attoparsec.parseOnly (Attoparsec.decimal <* Attoparsec.endOfInput) bytes--{-# INLINE checkExecStatus #-}-checkExecStatus :: (LibPQ.ExecStatus -> Bool) -> Result ()-checkExecStatus predicate =-  {-# SCC "checkExecStatus" #-} -  do-    status <- Result $ ReaderT $ \(_, result) -> lift $ LibPQ.resultStatus result-    unless (predicate status) $ do-      case status of-        LibPQ.BadResponse   -> serverError-        LibPQ.NonfatalError -> serverError-        LibPQ.FatalError    -> serverError-        _ -> Result $ lift $ EitherT $ pure $ Left $ UnexpectedResult $ "Unexpected result status: " <> (fromString $ show status)--{-# INLINE serverError #-}-serverError :: Result ()-serverError =-  Result $ ReaderT $ \(_, result) -> EitherT $ do-    code <- -      fmap (fromMaybe ($bug "No code")) $-      LibPQ.resultErrorField result LibPQ.DiagSqlstate-    message <- -      fmap (fromMaybe ($bug "No message")) $-      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)-maybe rowDec =-  do-    checkExecStatus $ \case-      LibPQ.TuplesOk -> True-      _ -> False-    Result $ ReaderT $ \(integerDatetimes, result) -> EitherT $ do-      maxRows <- LibPQ.ntuples result-      case maxRows of-        0 -> return (Right Nothing)-        1 -> do-          maxCols <- LibPQ.nfields result-          fmap (fmap Just . mapLeft (RowError 0)) $ Row.run rowDec (result, 0, maxCols, integerDatetimes)-        _ -> return (Left (UnexpectedAmountOfRows (rowToInt maxRows)))-  where-    rowToInt (LibPQ.Row n) =-      fromIntegral n-    intToRow =-      LibPQ.Row . fromIntegral--{-# INLINE single #-}-single :: Row.Row a -> Result a-single rowDec =-  do-    checkExecStatus $ \case-      LibPQ.TuplesOk -> True-      _ -> False-    Result $ ReaderT $ \(integerDatetimes, result) -> EitherT $ do-      maxRows <- LibPQ.ntuples result-      case maxRows of-        1 -> do-          maxCols <- LibPQ.nfields result-          fmap (mapLeft (RowError 0)) $ Row.run rowDec (result, 0, maxCols, integerDatetimes)-        _ -> return (Left (UnexpectedAmountOfRows (rowToInt maxRows)))-  where-    rowToInt (LibPQ.Row n) =-      fromIntegral n-    intToRow =-      LibPQ.Row . fromIntegral--{-# INLINE vector #-}-vector :: Row.Row a -> Result (Vector a)-vector rowDec =-  do-    checkExecStatus $ \case-      LibPQ.TuplesOk -> True-      _ -> False-    Result $ ReaderT $ \(integerDatetimes, result) -> EitherT $ 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 !x -> writeIORef failureRef (Just (RowError rowIndex 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-    intToRow =-      LibPQ.Row . fromIntegral--{-# INLINE foldl #-}-foldl :: (a -> b -> a) -> a -> Row.Row b -> Result a-foldl step init rowDec =-  {-# SCC "foldl" #-} -  do-    checkExecStatus $ \case-      LibPQ.TuplesOk -> True-      _ -> False-    Result $ ReaderT $ \(integerDatetimes, result) -> EitherT $ {-# 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 !x -> writeIORef failureRef (Just (RowError rowIndex 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-    intToRow =-      LibPQ.Row . fromIntegral--{-# INLINE foldr #-}-foldr :: (b -> a -> a) -> a -> Row.Row b -> Result a-foldr step init rowDec =-  {-# SCC "foldr" #-} -  do-    checkExecStatus $ \case-      LibPQ.TuplesOk -> True-      _ -> False-    Result $ ReaderT $ \(integerDatetimes, result) -> EitherT $ 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 !x -> writeIORef failureRef (Just (RowError rowIndex 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-    intToRow =-      LibPQ.Row . fromIntegral
− library/Hasql/Decoding/Results.hs 
@@ -1,90 +0,0 @@--- |--- 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.Decoding.Results where--import Hasql.Prelude hiding (maybe, many)-import qualified Database.PostgreSQL.LibPQ as LibPQ-import qualified Hasql.Prelude as Prelude-import qualified Hasql.Decoding.Result as Result-import qualified Hasql.Decoding.Row as Row---newtype Results a =-  Results (ReaderT (Bool, LibPQ.Connection) (EitherT Error IO) a)-  deriving (Functor, Applicative, Monad)--data Error =-  -- |-  -- An error on the client-side,-  -- with a message generated by the \"libpq\" library.-  -- Usually indicates problems with the connection.-  ClientError !(Maybe ByteString) |-  ResultError !Result.Error--{-# INLINE run #-}-run :: Results a -> (Bool, LibPQ.Connection) -> IO (Either Error a)-run (Results stack) env =-  runEitherT (runReaderT stack env)--{-# INLINE clientError #-}-clientError :: Results a-clientError =-  Results $ ReaderT $ \(_, connection) -> EitherT $-  fmap (Left . ClientError) (LibPQ.errorMessage connection)---- |--- Parse a single result.-{-# INLINE single #-}-single :: Result.Result a -> Results a-single resultDec =-  Results $ ReaderT $ \(integerDatetimes, connection) -> EitherT $ 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) -> EitherT $ do-    resultMaybe <- LibPQ.getResult connection-    case resultMaybe of-      Just result -> pure (Right result)-      Nothing -> fmap (Left . ClientError) (LibPQ.errorMessage connection)---- |--- Fetch a single result.-{-# INLINE getResultMaybe #-}-getResultMaybe :: Results (Maybe LibPQ.Result)-getResultMaybe =-  Results $ ReaderT $ \(_, connection) -> lift $ LibPQ.getResult connection--{-# INLINE dropRemainders #-}-dropRemainders :: Results ()-dropRemainders =-  {-# SCC "dropRemainders" #-} -  Results $ ReaderT $ \(integerDatetimes, connection) -> loop integerDatetimes connection-  where-    loop integerDatetimes connection =-      getResultMaybe >>= Prelude.maybe (pure ()) onResult-      where-        getResultMaybe =-          lift $ LibPQ.getResult connection-        onResult result =-          checkErrors *> loop integerDatetimes connection-          where-            checkErrors =-              EitherT $ fmap (mapLeft ResultError) $ Result.run Result.unit (integerDatetimes, result)
− library/Hasql/Decoding/Row.hs 
@@ -1,65 +0,0 @@-module Hasql.Decoding.Row where--import Hasql.Prelude-import qualified Database.PostgreSQL.LibPQ as LibPQ-import qualified PostgreSQL.Binary.Decoder as Decoder-import qualified Hasql.Decoding.Value as Value---newtype Row a =-  Row (ReaderT Env (EitherT Error IO) a)-  deriving (Functor, Applicative, Monad)--data Env =-  Env !LibPQ.Result !LibPQ.Row !LibPQ.Column !Bool !(IORef LibPQ.Column)--data Error =-  EndOfInput |-  UnexpectedNull |-  ValueError !Text-  deriving (Show)----- * Functions----------------------------{-# INLINE run #-}-run :: Row a -> (LibPQ.Result, LibPQ.Row, LibPQ.Column, Bool) -> IO (Either Error a)-run (Row impl) (result, row, columnsAmount, integerDatetimes) =-  do-    columnRef <- newIORef 0-    runEitherT (runReaderT impl (Env result row columnsAmount integerDatetimes columnRef))--{-# INLINE error #-}-error :: Error -> Row a-error x =-  Row (ReaderT (const (EitherT (pure (Left x)))))---- |--- Next value, decoded using the provided value decoder.-{-# INLINE value #-}-value :: Value.Value a -> Row (Maybe a)-value valueDec =-  {-# SCC "value" #-} -  Row $ ReaderT $ \(Env result row columnsAmount integerDatetimes columnRef) -> EitherT $ 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" #-} Decoder.run (Value.run valueDec integerDatetimes) value-      else pure (Left EndOfInput)---- |--- Next value, decoded using the provided value decoder.-{-# INLINE nonNullValue #-}-nonNullValue :: Value.Value a -> Row a-nonNullValue valueDec =-  {-# SCC "nonNullValue" #-} -  value valueDec >>= maybe (error UnexpectedNull) pure
− library/Hasql/Decoding/Value.hs 
@@ -1,23 +0,0 @@-module Hasql.Decoding.Value where--import Hasql.Prelude-import qualified Database.PostgreSQL.LibPQ as LibPQ-import qualified PostgreSQL.Binary.Decoder as Decoder---newtype Value a =-  Value (ReaderT Bool Decoder.Decoder a)-  deriving (Functor)---{-# INLINE run #-}-run :: Value a -> Bool -> Decoder.Decoder a-run (Value imp) integerDatetimes =-  runReaderT imp integerDatetimes--{-# INLINE decoder #-}-decoder :: (Bool -> Decoder.Decoder a) -> Value a-decoder =-  {-# SCC "decoder" #-} -  Value . ReaderT-
+ library/Hasql/Encoders.hs view
@@ -0,0 +1,483 @@+-- |+-- A DSL for declaration of query parameter encoders.+module Hasql.Encoders+(+  -- * Params+  Params,+  unit,+  value,+  nullableValue,+  -- * Value+  Value,+  bool,+  int2,+  int4,+  int8,+  float4,+  float8,+  numeric,+  char,+  text,+  bytea,+  date,+  timestamp,+  timestamptz,+  time,+  timetz,+  interval,+  uuid,+  json,+  array,+  enum,+  -- * Array+  Array,+  arrayValue,+  arrayNullableValue,+  arrayDimension,+)+where++import Hasql.Prelude hiding (bool)+import qualified PostgreSQL.Binary.Encoder as Encoder+import qualified Data.Aeson as Aeson+import qualified Hasql.Encoders.Params as Params+import qualified Hasql.Encoders.Value as Value+import qualified Hasql.Encoders.Array as Array+import qualified Hasql.PTI as PTI+import qualified Hasql.Prelude as Prelude+++-- * Parameters Product Encoder+-------------------------++-- |+-- Encoder of some representation of the parameters product.+-- +-- Has instances of 'Contravariant', 'Divisible' and 'Monoid',+-- which you can use to compose multiple parameters together.+-- E.g.,+-- +-- @+-- someParamsEncoder :: 'Params' (Int64, Maybe Text)+-- someParamsEncoder =+--   'contramap' 'fst' ('value' 'int8') '<>'+--   'contramap' 'snd' ('nullableValue' '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' ('value' 'int8') ('nullableValue' 'text')+-- @+-- +-- Here's how you can implement encoders for custom composite types:+-- +-- @+-- data Person =+--   Person { name :: Text, gender :: Gender, age :: Int }+-- +-- data Gender =+--   Male | Female+-- +-- personParams :: 'Params' Person+-- personParams =+--   'contramap' name ('value' 'text') '<>'+--   'contramap' gender ('value' genderValue) '<>'+--   'contramap' (fromIntegral . age) ('value' 'int8')+-- +-- genderValue :: 'Value' Gender+-- genderValue =+--   'contramap' genderText 'text'+--   where+--     genderText gender =+--       case gender of+--         Male -> "male"+--         Female -> "female"+-- @+-- +newtype Params a =+  Params (Params.Params a)+  deriving (Contravariant, Divisible, Monoid)++-- |+-- Encode no parameters.+-- +{-# INLINABLE unit #-}+unit :: Params ()+unit =+  Params mempty++-- |+-- Lift an individual value encoder to a parameters encoder.+-- +{-# INLINABLE value #-}+value :: Value a -> Params a+value (Value x) =+  Params (Params.value x)++-- |+-- Lift an individual nullable value encoder to a parameters encoder.+-- +{-# INLINABLE nullableValue #-}+nullableValue :: Value a -> Params (Maybe a)+nullableValue (Value x) =+  Params (Params.nullableValue x)+++-- ** Instances+-------------------------++-- |+-- Maps to 'unit'.+instance Default (Params ()) where+  {-# INLINE def #-}+  def =+    unit++instance Default (Value a) => Default (Params (Identity a)) where+  {-# INLINE def #-}+  def =+    contramap runIdentity (value def)++instance (Default (Value a1), Default (Value a2)) => Default (Params (a1, a2)) where+  {-# INLINE def #-}+  def =+    contrazip2 (value def) (value def)++instance (Default (Value a1), Default (Value a2), Default (Value a3)) => Default (Params (a1, a2, a3)) where+  {-# INLINE def #-}+  def =+    contrazip3 (value def) (value def) (value def)++instance (Default (Value a1), Default (Value a2), Default (Value a3), Default (Value a4)) => Default (Params (a1, a2, a3, a4)) where+  {-# INLINE def #-}+  def =+    contrazip4 (value def) (value def) (value def) (value def)++instance (Default (Value a1), Default (Value a2), Default (Value a3), Default (Value a4), Default (Value a5)) => Default (Params (a1, a2, a3, a4, a5)) where+  {-# INLINE def #-}+  def =+    contrazip5 (value def) (value def) (value def) (value def) (value def)+++-- * Value Encoder+-------------------------++-- |+-- An individual value encoder.+-- Will be mapped to a single placeholder in the query.+-- +newtype Value a =+  Value (Value.Value a)+  deriving (Contravariant)++-- |+-- Encoder of @BOOL@ values.+{-# INLINABLE bool #-}+bool :: Value Bool+bool =+  Value (Value.unsafePTI PTI.bool (const Encoder.bool))++-- |+-- Encoder of @INT2@ values.+{-# INLINABLE int2 #-}+int2 :: Value Int16+int2 =+  Value (Value.unsafePTI PTI.int2 (const Encoder.int2_int16))++-- |+-- Encoder of @INT4@ values.+{-# INLINABLE int4 #-}+int4 :: Value Int32+int4 =+  Value (Value.unsafePTI PTI.int4 (const Encoder.int4_int32))++-- |+-- Encoder of @INT8@ values.+{-# INLINABLE int8 #-}+int8 :: Value Int64+int8 =+  Value (Value.unsafePTI PTI.int8 (const Encoder.int8_int64))++-- |+-- Encoder of @FLOAT4@ values.+{-# INLINABLE float4 #-}+float4 :: Value Float+float4 =+  Value (Value.unsafePTI PTI.float4 (const Encoder.float4))++-- |+-- Encoder of @FLOAT8@ values.+{-# INLINABLE float8 #-}+float8 :: Value Double+float8 =+  Value (Value.unsafePTI PTI.float8 (const Encoder.float8))++-- |+-- Encoder of @NUMERIC@ values.+{-# INLINABLE numeric #-}+numeric :: Value Scientific+numeric =+  Value (Value.unsafePTI PTI.numeric (const Encoder.numeric))++-- |+-- Encoder of @CHAR@ values.+-- Note that it supports UTF-8 values and+-- identifies itself under the @TEXT@ OID because of that.+{-# INLINABLE char #-}+char :: Value Char+char =+  Value (Value.unsafePTI PTI.text (const Encoder.char))++-- |+-- Encoder of @TEXT@ values.+{-# INLINABLE text #-}+text :: Value Text+text =+  Value (Value.unsafePTI PTI.text (const Encoder.text_strict))++-- |+-- Encoder of @BYTEA@ values.+{-# INLINABLE bytea #-}+bytea :: Value ByteString+bytea =+  Value (Value.unsafePTI PTI.bytea (const Encoder.bytea_strict))++-- |+-- Encoder of @DATE@ values.+{-# INLINABLE date #-}+date :: Value Day+date =+  Value (Value.unsafePTI PTI.date (const Encoder.date))++-- |+-- Encoder of @TIMESTAMP@ values.+{-# INLINABLE timestamp #-}+timestamp :: Value LocalTime+timestamp =+  Value (Value.unsafePTI PTI.timestamp (Prelude.bool Encoder.timestamp_int Encoder.timestamp_float))++-- |+-- Encoder of @TIMESTAMPTZ@ values.+{-# INLINABLE timestamptz #-}+timestamptz :: Value UTCTime+timestamptz =+  Value (Value.unsafePTI PTI.timestamptz (Prelude.bool Encoder.timestamptz_int Encoder.timestamptz_float))++-- |+-- Encoder of @TIME@ values.+{-# INLINABLE time #-}+time :: Value TimeOfDay+time =+  Value (Value.unsafePTI PTI.time (Prelude.bool Encoder.time_int Encoder.time_float))++-- |+-- Encoder of @TIMETZ@ values.+{-# INLINABLE timetz #-}+timetz :: Value (TimeOfDay, TimeZone)+timetz =+  Value (Value.unsafePTI PTI.timetz (Prelude.bool Encoder.timetz_int Encoder.timetz_float))++-- |+-- Encoder of @INTERVAL@ values.+{-# INLINABLE interval #-}+interval :: Value DiffTime+interval =+  Value (Value.unsafePTI PTI.interval (Prelude.bool Encoder.interval_int Encoder.interval_float))++-- |+-- Encoder of @UUID@ values.+{-# INLINABLE uuid #-}+uuid :: Value UUID+uuid =+  Value (Value.unsafePTI PTI.uuid (const Encoder.uuid))++-- |+-- Encoder of @JSON@ values.+{-# INLINABLE json #-}+json :: Value Aeson.Value+json =+  Value (Value.unsafePTI PTI.json (const Encoder.json))++-- |+-- Unlifts the 'Array' encoder to the plain 'Value' encoder.+{-# INLINABLE array #-}+array :: Array a -> Value a+array (Array imp) =+  Array.run imp & \(arrayOID, encoder') ->+    Value (Value.Value arrayOID arrayOID encoder')++-- |+-- Given a function,+-- which maps the value into the textual enum label from the DB side,+-- produces a encoder of that value.+{-# INLINABLE enum #-}+enum :: (a -> Text) -> Value a+enum mapping =+  Value (Value.unsafePTI PTI.text (const (Encoder.enum mapping)))+++-- ** Instances+-------------------------++-- | Maps to 'bool'.+instance Default (Value Bool) where+  {-# INLINE def #-}+  def =+    bool++-- | Maps to 'int2'.+instance Default (Value Int16) where+  {-# INLINE def #-}+  def =+    int2++-- | Maps to 'int4'.+instance Default (Value Int32) where+  {-# INLINE def #-}+  def =+    int4++-- | Maps to 'int8'.+instance Default (Value Int64) where+  {-# INLINE def #-}+  def =+    int8++-- | Maps to 'float4'.+instance Default (Value Float) where+  {-# INLINE def #-}+  def =+    float4++-- | Maps to 'float8'.+instance Default (Value Double) where+  {-# INLINE def #-}+  def =+    float8++-- | Maps to 'numeric'.+instance Default (Value Scientific) where+  {-# INLINE def #-}+  def =+    numeric++-- | Maps to 'char'.+instance Default (Value Char) where+  {-# INLINE def #-}+  def =+    char++-- | Maps to 'text'.+instance Default (Value Text) where+  {-# INLINE def #-}+  def =+    text++-- | Maps to 'bytea'.+instance Default (Value ByteString) where+  {-# INLINE def #-}+  def =+    bytea++-- | Maps to 'date'.+instance Default (Value Day) where+  {-# INLINE def #-}+  def =+    date++-- | Maps to 'timestamp'.+instance Default (Value LocalTime) where+  {-# INLINE def #-}+  def =+    timestamp++-- | Maps to 'timestamptz'.+instance Default (Value UTCTime) where+  {-# INLINE def #-}+  def =+    timestamptz++-- | Maps to 'time'.+instance Default (Value TimeOfDay) where+  {-# INLINE def #-}+  def =+    time++-- | Maps to 'timetz'.+instance Default (Value (TimeOfDay, TimeZone)) where+  {-# INLINE def #-}+  def =+    timetz++-- | Maps to 'interval'.+instance Default (Value DiffTime) where+  {-# INLINE def #-}+  def =+    interval++-- | Maps to 'uuid'.+instance Default (Value UUID) where+  {-# INLINE def #-}+  def =+    uuid++-- | Maps to 'json'.+instance Default (Value Aeson.Value) where+  {-# INLINE def #-}+  def =+    json+++-- * Array+-------------------------++-- |+-- A generic array encoder.+-- +-- Here's an example of its usage:+-- +-- >x :: Value [[Int64]]+-- >x =+-- >  array (arrayDimension foldl' (arrayDimension foldl' (arrayValue int8)))+-- +newtype Array a =+  Array (Array.Array a)++-- |+-- Lifts the 'Value' encoder into the 'Array' encoder of a non-nullable value.+{-# INLINABLE arrayValue #-}+arrayValue :: Value a -> Array a+arrayValue (Value (Value.Value elementOID arrayOID encoder')) =+  Array (Array.value elementOID arrayOID encoder')++-- |+-- Lifts the 'Value' encoder into the 'Array' encoder of a nullable value.+{-# INLINABLE arrayNullableValue #-}+arrayNullableValue :: Value a -> Array (Maybe a)+arrayNullableValue (Value (Value.Value elementOID arrayOID encoder')) =+  Array (Array.nullableValue elementOID arrayOID encoder')++-- |+-- An encoder of an array dimension,+-- which thus provides support for multidimensional arrays.+-- +-- Accepts:+-- +-- * An implementation of the left-fold operation,+-- such as @Data.Foldable.'foldl''@,+-- which determines the input value.+-- +-- * A component encoder, which can be either another 'arrayDimension',+-- 'arrayValue' or 'arrayNullableValue'.+-- +{-# INLINABLE arrayDimension #-}+arrayDimension :: (forall a. (a -> b -> a) -> a -> c -> a) -> Array b -> Array c+arrayDimension foldl (Array imp) =+  Array (Array.dimension foldl imp)+
+ library/Hasql/Encoders/Array.hs view
@@ -0,0 +1,31 @@+module Hasql.Encoders.Array where++import Hasql.Prelude+import qualified Database.PostgreSQL.LibPQ as LibPQ+import qualified PostgreSQL.Binary.Encoder as Encoder+import qualified Hasql.PTI as PTI+++data Array a =+  Array PTI.OID PTI.OID (Bool -> Encoder.ArrayEncoder a)++{-# INLINE run #-}+run :: Array a -> (PTI.OID, Bool -> Encoder.Encoder a)+run (Array valueOID arrayOID encoder') =+  (arrayOID, \env -> Encoder.array (PTI.oidWord32 valueOID) (encoder' env))++{-# INLINE value #-}+value :: PTI.OID -> PTI.OID -> (Bool -> Encoder.Encoder a) -> Array a+value valueOID arrayOID encoder' =+  Array valueOID arrayOID (Encoder.arrayValue . encoder')++{-# INLINE nullableValue #-}+nullableValue :: PTI.OID -> PTI.OID -> (Bool -> Encoder.Encoder a) -> Array (Maybe a)+nullableValue valueOID arrayOID encoder' =+  Array valueOID arrayOID (Encoder.arrayNullableValue . encoder')++{-# INLINE dimension #-}+dimension :: (forall a. (a -> b -> a) -> a -> c -> a) -> Array b -> Array c+dimension foldl (Array valueOID arrayOID encoder') =+  Array valueOID arrayOID (Encoder.arrayDimension foldl . encoder')+
+ library/Hasql/Encoders/Params.hs view
@@ -0,0 +1,49 @@+module Hasql.Encoders.Params where++import Hasql.Prelude+import qualified Database.PostgreSQL.LibPQ as LibPQ+import qualified PostgreSQL.Binary.Encoder as Encoder+import qualified Hasql.Encoders.Value as Value+import qualified Hasql.PTI as PTI+++-- |+-- Encoder of some representation of a parameters product.+newtype Params a =+  Params (Op (DList (LibPQ.Oid, Bool -> Maybe ByteString)) a)+  deriving (Contravariant, Divisible, Monoid)++run :: Params a -> a -> DList (LibPQ.Oid, Bool -> Maybe ByteString)+run (Params (Op op)) params =+  {-# SCC "run" #-} +  op params++run' :: Params a -> a -> Bool -> ([LibPQ.Oid], [Maybe (ByteString, LibPQ.Format)])+run' (Params (Op op)) params integerDatetimes =+  {-# SCC "run'" #-} +  foldr step ([], []) (op params)+  where+    step (oid, bytesGetter) ~(oidList, bytesAndFormatList) =+      (,)+        (oid : oidList)+        (fmap (\bytes -> (bytes, LibPQ.Binary)) (bytesGetter integerDatetimes) : bytesAndFormatList)++run'' :: Params a -> a -> Bool -> [Maybe (LibPQ.Oid, ByteString, LibPQ.Format)]+run'' (Params (Op op)) params integerDatetimes =+  {-# SCC "run''" #-} +  foldr step [] (op params)+  where+    step a b =+      mapping a : b+      where+        mapping (oid, bytesGetter) =+          (,,) <$> pure oid <*> bytesGetter integerDatetimes <*> pure LibPQ.Binary++value :: Value.Value a -> Params a+value =+  contramap Just . nullableValue++nullableValue :: Value.Value a -> Params (Maybe a)+nullableValue (Value.Value valueOID arrayOID encoder') =+  Params $ Op $ \input -> +    pure (PTI.oidPQ valueOID, \env -> fmap (Encoder.run (encoder' env)) input)
+ library/Hasql/Encoders/Value.hs view
@@ -0,0 +1,27 @@+module Hasql.Encoders.Value where++import Hasql.Prelude+import qualified Database.PostgreSQL.LibPQ as LibPQ+import qualified PostgreSQL.Binary.Encoder as Encoder+import qualified Hasql.PTI as PTI+++data Value a =+  Value PTI.OID PTI.OID (Bool -> Encoder.Encoder a)++instance Contravariant Value where+  {-# INLINE contramap #-}+  contramap f (Value valueOID arrayOID encoder) =+    Value valueOID arrayOID (\integerDatetimes input -> encoder integerDatetimes (f input))++{-# INLINE run #-}+run :: Value a -> (PTI.OID, PTI.OID, Bool -> Encoder.Encoder a)+run (Value valueOID arrayOID encoder') =+  (valueOID, arrayOID, encoder')++{-# INLINE unsafePTI #-}+unsafePTI :: PTI.PTI -> (Bool -> Encoder.Encoder a) -> Value a+unsafePTI pti encoder' =+  Value (PTI.ptiOID pti) (fromMaybe ($bug "No array OID") (PTI.ptiArrayOID pti)) encoder'++
− library/Hasql/Encoding.hs 
@@ -1,483 +0,0 @@--- |--- A DSL for declaration of query parameter encoders.-module Hasql.Encoding-(-  -- * Params-  Params,-  unit,-  value,-  nullableValue,-  -- * Value-  Value,-  bool,-  int2,-  int4,-  int8,-  float4,-  float8,-  numeric,-  char,-  text,-  bytea,-  date,-  timestamp,-  timestamptz,-  time,-  timetz,-  interval,-  uuid,-  json,-  array,-  enum,-  -- * Array-  Array,-  arrayValue,-  arrayNullableValue,-  arrayDimension,-)-where--import Hasql.Prelude hiding (bool)-import qualified PostgreSQL.Binary.Encoder as Encoder-import qualified Data.Aeson as Aeson-import qualified Hasql.Encoding.Params as Params-import qualified Hasql.Encoding.Value as Value-import qualified Hasql.Encoding.Array as Array-import qualified Hasql.PTI as PTI-import qualified Hasql.Prelude as Prelude----- * Parameters Product Encoder------------------------------ |--- Encoder of some representation of the parameters product.--- --- Has instances of 'Contravariant', 'Divisible' and 'Monoid',--- which you can use to compose multiple parameters together.--- E.g.,--- --- @--- someParamsEncoder :: 'Params' (Int64, Maybe Text)--- someParamsEncoder =---   'contramap' 'fst' ('value' 'int8') '<>'---   'contramap' 'snd' ('nullableValue' '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' ('value' 'int8') ('nullableValue' 'text')--- @--- --- Here's how you can implement encoders for custom composite types:--- --- @--- data Person =---   Person { name :: Text, gender :: Gender, age :: Int }--- --- data Gender =---   Male | Female--- --- personParams :: 'Params' Person--- personParams =---   'contramap' name ('value' 'text') '<>'---   'contramap' gender ('value' genderValue) '<>'---   'contramap' (fromIntegral . age) ('value' 'int8')--- --- genderValue :: 'Value' Gender--- genderValue =---   'contramap' genderText 'text'---   where---     genderText gender =---       case gender of---         Male -> "male"---         Female -> "female"--- @--- -newtype Params a =-  Params (Params.Params a)-  deriving (Contravariant, Divisible, Monoid)---- |--- Encode no parameters.--- -{-# INLINABLE unit #-}-unit :: Params ()-unit =-  Params mempty---- |--- Lift an individual value encoder to a parameters encoder.--- -{-# INLINABLE value #-}-value :: Value a -> Params a-value (Value x) =-  Params (Params.value x)---- |--- Lift an individual nullable value encoder to a parameters encoder.--- -{-# INLINABLE nullableValue #-}-nullableValue :: Value a -> Params (Maybe a)-nullableValue (Value x) =-  Params (Params.nullableValue x)----- ** Instances------------------------------ |--- Maps to 'unit'.-instance Default (Params ()) where-  {-# INLINE def #-}-  def =-    unit--instance Default (Value a) => Default (Params (Identity a)) where-  {-# INLINE def #-}-  def =-    contramap runIdentity (value def)--instance (Default (Value a1), Default (Value a2)) => Default (Params (a1, a2)) where-  {-# INLINE def #-}-  def =-    contrazip2 (value def) (value def)--instance (Default (Value a1), Default (Value a2), Default (Value a3)) => Default (Params (a1, a2, a3)) where-  {-# INLINE def #-}-  def =-    contrazip3 (value def) (value def) (value def)--instance (Default (Value a1), Default (Value a2), Default (Value a3), Default (Value a4)) => Default (Params (a1, a2, a3, a4)) where-  {-# INLINE def #-}-  def =-    contrazip4 (value def) (value def) (value def) (value def)--instance (Default (Value a1), Default (Value a2), Default (Value a3), Default (Value a4), Default (Value a5)) => Default (Params (a1, a2, a3, a4, a5)) where-  {-# INLINE def #-}-  def =-    contrazip5 (value def) (value def) (value def) (value def) (value def)----- * Value Encoder------------------------------ |--- An individual value encoder.--- Will be mapped to a single placeholder in the query.--- -newtype Value a =-  Value (Value.Value a)-  deriving (Contravariant)---- |--- Encoder of @BOOL@ values.-{-# INLINABLE bool #-}-bool :: Value Bool-bool =-  Value (Value.unsafePTI PTI.bool (const Encoder.bool))---- |--- Encoder of @INT2@ values.-{-# INLINABLE int2 #-}-int2 :: Value Int16-int2 =-  Value (Value.unsafePTI PTI.int2 (const Encoder.int2_int16))---- |--- Encoder of @INT4@ values.-{-# INLINABLE int4 #-}-int4 :: Value Int32-int4 =-  Value (Value.unsafePTI PTI.int4 (const Encoder.int4_int32))---- |--- Encoder of @INT8@ values.-{-# INLINABLE int8 #-}-int8 :: Value Int64-int8 =-  Value (Value.unsafePTI PTI.int8 (const Encoder.int8_int64))---- |--- Encoder of @FLOAT4@ values.-{-# INLINABLE float4 #-}-float4 :: Value Float-float4 =-  Value (Value.unsafePTI PTI.float4 (const Encoder.float4))---- |--- Encoder of @FLOAT8@ values.-{-# INLINABLE float8 #-}-float8 :: Value Double-float8 =-  Value (Value.unsafePTI PTI.float8 (const Encoder.float8))---- |--- Encoder of @NUMERIC@ values.-{-# INLINABLE numeric #-}-numeric :: Value Scientific-numeric =-  Value (Value.unsafePTI PTI.numeric (const Encoder.numeric))---- |--- Encoder of @CHAR@ values.--- Note that it supports UTF-8 values and--- identifies itself under the @TEXT@ OID because of that.-{-# INLINABLE char #-}-char :: Value Char-char =-  Value (Value.unsafePTI PTI.text (const Encoder.char))---- |--- Encoder of @TEXT@ values.-{-# INLINABLE text #-}-text :: Value Text-text =-  Value (Value.unsafePTI PTI.text (const Encoder.text_strict))---- |--- Encoder of @BYTEA@ values.-{-# INLINABLE bytea #-}-bytea :: Value ByteString-bytea =-  Value (Value.unsafePTI PTI.bytea (const Encoder.bytea_strict))---- |--- Encoder of @DATE@ values.-{-# INLINABLE date #-}-date :: Value Day-date =-  Value (Value.unsafePTI PTI.date (const Encoder.date))---- |--- Encoder of @TIMESTAMP@ values.-{-# INLINABLE timestamp #-}-timestamp :: Value LocalTime-timestamp =-  Value (Value.unsafePTI PTI.timestamp (Prelude.bool Encoder.timestamp_int Encoder.timestamp_float))---- |--- Encoder of @TIMESTAMPTZ@ values.-{-# INLINABLE timestamptz #-}-timestamptz :: Value UTCTime-timestamptz =-  Value (Value.unsafePTI PTI.timestamptz (Prelude.bool Encoder.timestamptz_int Encoder.timestamptz_float))---- |--- Encoder of @TIME@ values.-{-# INLINABLE time #-}-time :: Value TimeOfDay-time =-  Value (Value.unsafePTI PTI.time (Prelude.bool Encoder.time_int Encoder.time_float))---- |--- Encoder of @TIMETZ@ values.-{-# INLINABLE timetz #-}-timetz :: Value (TimeOfDay, TimeZone)-timetz =-  Value (Value.unsafePTI PTI.timetz (Prelude.bool Encoder.timetz_int Encoder.timetz_float))---- |--- Encoder of @INTERVAL@ values.-{-# INLINABLE interval #-}-interval :: Value DiffTime-interval =-  Value (Value.unsafePTI PTI.interval (Prelude.bool Encoder.interval_int Encoder.interval_float))---- |--- Encoder of @UUID@ values.-{-# INLINABLE uuid #-}-uuid :: Value UUID-uuid =-  Value (Value.unsafePTI PTI.uuid (const Encoder.uuid))---- |--- Encoder of @JSON@ values.-{-# INLINABLE json #-}-json :: Value Aeson.Value-json =-  Value (Value.unsafePTI PTI.json (const Encoder.json))---- |--- Unlifts the 'Array' encoder to the plain 'Value' encoder.-{-# INLINABLE array #-}-array :: Array a -> Value a-array (Array imp) =-  Array.run imp & \(arrayOID, encoder') ->-    Value (Value.Value arrayOID arrayOID encoder')---- |--- Given a function,--- which maps the value into the textual enum label from the DB side,--- produces a encoder of that value.-{-# INLINABLE enum #-}-enum :: (a -> Text) -> Value a-enum mapping =-  Value (Value.unsafePTI PTI.text (const (Encoder.enum mapping)))----- ** Instances------------------------------ | Maps to 'bool'.-instance Default (Value Bool) where-  {-# INLINE def #-}-  def =-    bool---- | Maps to 'int2'.-instance Default (Value Int16) where-  {-# INLINE def #-}-  def =-    int2---- | Maps to 'int4'.-instance Default (Value Int32) where-  {-# INLINE def #-}-  def =-    int4---- | Maps to 'int8'.-instance Default (Value Int64) where-  {-# INLINE def #-}-  def =-    int8---- | Maps to 'float4'.-instance Default (Value Float) where-  {-# INLINE def #-}-  def =-    float4---- | Maps to 'float8'.-instance Default (Value Double) where-  {-# INLINE def #-}-  def =-    float8---- | Maps to 'numeric'.-instance Default (Value Scientific) where-  {-# INLINE def #-}-  def =-    numeric---- | Maps to 'char'.-instance Default (Value Char) where-  {-# INLINE def #-}-  def =-    char---- | Maps to 'text'.-instance Default (Value Text) where-  {-# INLINE def #-}-  def =-    text---- | Maps to 'bytea'.-instance Default (Value ByteString) where-  {-# INLINE def #-}-  def =-    bytea---- | Maps to 'date'.-instance Default (Value Day) where-  {-# INLINE def #-}-  def =-    date---- | Maps to 'timestamp'.-instance Default (Value LocalTime) where-  {-# INLINE def #-}-  def =-    timestamp---- | Maps to 'timestamptz'.-instance Default (Value UTCTime) where-  {-# INLINE def #-}-  def =-    timestamptz---- | Maps to 'time'.-instance Default (Value TimeOfDay) where-  {-# INLINE def #-}-  def =-    time---- | Maps to 'timetz'.-instance Default (Value (TimeOfDay, TimeZone)) where-  {-# INLINE def #-}-  def =-    timetz---- | Maps to 'interval'.-instance Default (Value DiffTime) where-  {-# INLINE def #-}-  def =-    interval---- | Maps to 'uuid'.-instance Default (Value UUID) where-  {-# INLINE def #-}-  def =-    uuid---- | Maps to 'json'.-instance Default (Value Aeson.Value) where-  {-# INLINE def #-}-  def =-    json----- * Array------------------------------ |--- A generic array encoder.--- --- Here's an example of its usage:--- --- >x :: Value [[Int64]]--- >x =--- >  array (arrayDimension foldl' (arrayDimension foldl' (arrayValue int8)))--- -newtype Array a =-  Array (Array.Array a)---- |--- Lifts the 'Value' encoder into the 'Array' encoder of a non-nullable value.-{-# INLINABLE arrayValue #-}-arrayValue :: Value a -> Array a-arrayValue (Value (Value.Value elementOID arrayOID encoder')) =-  Array (Array.value elementOID arrayOID encoder')---- |--- Lifts the 'Value' encoder into the 'Array' encoder of a nullable value.-{-# INLINABLE arrayNullableValue #-}-arrayNullableValue :: Value a -> Array (Maybe a)-arrayNullableValue (Value (Value.Value elementOID arrayOID encoder')) =-  Array (Array.nullableValue elementOID arrayOID encoder')---- |--- An encoder of an array dimension,--- which thus provides support for multidimensional arrays.--- --- Accepts:--- --- * An implementation of the left-fold operation,--- such as @Data.Foldable.'foldl''@,--- which determines the input value.--- --- * A component encoder, which can be either another 'arrayDimension',--- 'arrayValue' or 'arrayNullableValue'.--- -{-# INLINABLE arrayDimension #-}-arrayDimension :: (forall a. (a -> b -> a) -> a -> c -> a) -> Array b -> Array c-arrayDimension foldl (Array imp) =-  Array (Array.dimension foldl imp)-
− library/Hasql/Encoding/Array.hs 
@@ -1,31 +0,0 @@-module Hasql.Encoding.Array where--import Hasql.Prelude-import qualified Database.PostgreSQL.LibPQ as LibPQ-import qualified PostgreSQL.Binary.Encoder as Encoder-import qualified Hasql.PTI as PTI---data Array a =-  Array PTI.OID PTI.OID (Bool -> Encoder.ArrayEncoder a)--{-# INLINE run #-}-run :: Array a -> (PTI.OID, Bool -> Encoder.Encoder a)-run (Array valueOID arrayOID encoder') =-  (arrayOID, \env -> Encoder.array (PTI.oidWord32 valueOID) (encoder' env))--{-# INLINE value #-}-value :: PTI.OID -> PTI.OID -> (Bool -> Encoder.Encoder a) -> Array a-value valueOID arrayOID encoder' =-  Array valueOID arrayOID (Encoder.arrayValue . encoder')--{-# INLINE nullableValue #-}-nullableValue :: PTI.OID -> PTI.OID -> (Bool -> Encoder.Encoder a) -> Array (Maybe a)-nullableValue valueOID arrayOID encoder' =-  Array valueOID arrayOID (Encoder.arrayNullableValue . encoder')--{-# INLINE dimension #-}-dimension :: (forall a. (a -> b -> a) -> a -> c -> a) -> Array b -> Array c-dimension foldl (Array valueOID arrayOID encoder') =-  Array valueOID arrayOID (Encoder.arrayDimension foldl . encoder')-
− library/Hasql/Encoding/Params.hs 
@@ -1,49 +0,0 @@-module Hasql.Encoding.Params where--import Hasql.Prelude-import qualified Database.PostgreSQL.LibPQ as LibPQ-import qualified PostgreSQL.Binary.Encoder as Encoder-import qualified Hasql.Encoding.Value as Value-import qualified Hasql.PTI as PTI----- |--- Encoder of some representation of a parameters product.-newtype Params a =-  Params (Op (DList (LibPQ.Oid, Bool -> Maybe ByteString)) a)-  deriving (Contravariant, Divisible, Monoid)--run :: Params a -> a -> DList (LibPQ.Oid, Bool -> Maybe ByteString)-run (Params (Op op)) params =-  {-# SCC "run" #-} -  op params--run' :: Params a -> a -> Bool -> ([LibPQ.Oid], [Maybe (ByteString, LibPQ.Format)])-run' (Params (Op op)) params integerDatetimes =-  {-# SCC "run'" #-} -  foldr step ([], []) (op params)-  where-    step (oid, bytesGetter) ~(oidList, bytesAndFormatList) =-      (,)-        (oid : oidList)-        (fmap (\bytes -> (bytes, LibPQ.Binary)) (bytesGetter integerDatetimes) : bytesAndFormatList)--run'' :: Params a -> a -> Bool -> [Maybe (LibPQ.Oid, ByteString, LibPQ.Format)]-run'' (Params (Op op)) params integerDatetimes =-  {-# SCC "run''" #-} -  foldr step [] (op params)-  where-    step a b =-      mapping a : b-      where-        mapping (oid, bytesGetter) =-          (,,) <$> pure oid <*> bytesGetter integerDatetimes <*> pure LibPQ.Binary--value :: Value.Value a -> Params a-value =-  contramap Just . nullableValue--nullableValue :: Value.Value a -> Params (Maybe a)-nullableValue (Value.Value valueOID arrayOID encoder') =-  Params $ Op $ \input -> -    pure (PTI.oidPQ valueOID, \env -> fmap (Encoder.run (encoder' env)) input)
− library/Hasql/Encoding/Value.hs 
@@ -1,27 +0,0 @@-module Hasql.Encoding.Value where--import Hasql.Prelude-import qualified Database.PostgreSQL.LibPQ as LibPQ-import qualified PostgreSQL.Binary.Encoder as Encoder-import qualified Hasql.PTI as PTI---data Value a =-  Value PTI.OID PTI.OID (Bool -> Encoder.Encoder a)--instance Contravariant Value where-  {-# INLINE contramap #-}-  contramap f (Value valueOID arrayOID encoder) =-    Value valueOID arrayOID (\integerDatetimes input -> encoder integerDatetimes (f input))--{-# INLINE run #-}-run :: Value a -> (PTI.OID, PTI.OID, Bool -> Encoder.Encoder a)-run (Value valueOID arrayOID encoder') =-  (valueOID, arrayOID, encoder')--{-# INLINE unsafePTI #-}-unsafePTI :: PTI.PTI -> (Bool -> Encoder.Encoder a) -> Value a-unsafePTI pti encoder' =-  Value (PTI.ptiOID pti) (fromMaybe ($bug "No array OID") (PTI.ptiArrayOID pti)) encoder'--
library/Hasql/IO.hs view
@@ -7,9 +7,9 @@ import qualified Database.PostgreSQL.LibPQ as LibPQ import qualified Hasql.Commands as Commands import qualified Hasql.PreparedStatementRegistry as PreparedStatementRegistry-import qualified Hasql.Decoding.Result as ResultDecoding-import qualified Hasql.Decoding.Results as ResultsDecoding-import qualified Hasql.Encoding.Params as ParamsEncoding+import qualified Hasql.Decoders.Result as ResultDecoders+import qualified Hasql.Decoders.Results as ResultsDecoders+import qualified Hasql.Encoders.Params as ParamsEncoders import qualified Data.DList as DList  @@ -55,19 +55,19 @@ {-# INLINE initConnection #-} initConnection :: LibPQ.Connection -> IO () initConnection c =-  void $ LibPQ.exec c (Commands.asBytes (Commands.setEncodingToUTF8 <> Commands.setMinClientMessagesToWarning))+  void $ LibPQ.exec c (Commands.asBytes (Commands.setEncodersToUTF8 <> Commands.setMinClientMessagesToWarning))  {-# INLINE getResults #-}-getResults :: LibPQ.Connection -> Bool -> ResultsDecoding.Results a -> IO (Either ResultsDecoding.Error a)+getResults :: LibPQ.Connection -> Bool -> ResultsDecoders.Results a -> IO (Either ResultsDecoders.Error a) getResults connection integerDatetimes des =   {-# SCC "getResults" #-} -  ResultsDecoding.run (des <* ResultsDecoding.dropRemainders) (integerDatetimes, connection)+  ResultsDecoders.run (des <* ResultsDecoders.dropRemainders) (integerDatetimes, connection)  {-# INLINE getPreparedStatementKey #-} getPreparedStatementKey ::   LibPQ.Connection -> PreparedStatementRegistry.PreparedStatementRegistry ->   ByteString -> [LibPQ.Oid] ->-  IO (Either ResultsDecoding.Error ByteString)+  IO (Either ResultsDecoders.Error ByteString) getPreparedStatementKey connection registry template oidList =   {-# SCC "getPreparedStatementKey" #-}    do@@ -81,8 +81,8 @@           sent <- LibPQ.sendPrepare connection key template (mfilter (not . null) (Just oidList))           let resultsDecoder =                  if sent-                  then ResultsDecoding.single ResultDecoding.unit-                  else ResultsDecoding.clientError+                  then ResultsDecoders.single ResultDecoders.unit+                  else ResultsDecoders.clientError           runEitherT $ do             EitherT $ getResults connection undefined resultsDecoder             pure key@@ -91,10 +91,10 @@       map (\(LibPQ.Oid x) -> fromIntegral x) oidList  {-# INLINE checkedSend #-}-checkedSend :: LibPQ.Connection -> IO Bool -> IO (Either ResultsDecoding.Error ())+checkedSend :: LibPQ.Connection -> IO Bool -> IO (Either ResultsDecoders.Error ()) checkedSend connection send =   send >>= \case-    False -> fmap (Left . ResultsDecoding.ClientError) $ LibPQ.errorMessage connection+    False -> fmap (Left . ResultsDecoders.ClientError) $ LibPQ.errorMessage connection     True -> pure (Right ())  {-# INLINE sendPreparedParametricQuery #-}@@ -104,7 +104,7 @@   ByteString ->   [LibPQ.Oid] ->   [Maybe (ByteString, LibPQ.Format)] ->-  IO (Either ResultsDecoding.Error ())+  IO (Either ResultsDecoders.Error ()) sendPreparedParametricQuery connection registry template oidList valueAndFormatList =   runEitherT $ do     key <- EitherT $ getPreparedStatementKey connection registry template oidList@@ -115,7 +115,7 @@   LibPQ.Connection ->   ByteString ->   [Maybe (LibPQ.Oid, ByteString, LibPQ.Format)] ->-  IO (Either ResultsDecoding.Error ())+  IO (Either ResultsDecoders.Error ()) sendUnpreparedParametricQuery connection template paramList =   checkedSend connection $ LibPQ.sendQueryParams connection template paramList LibPQ.Binary @@ -125,27 +125,27 @@   Bool ->    PreparedStatementRegistry.PreparedStatementRegistry ->   ByteString ->-  ParamsEncoding.Params a ->+  ParamsEncoders.Params a ->   Bool ->   a ->-  IO (Either ResultsDecoding.Error ())+  IO (Either ResultsDecoders.Error ()) sendParametricQuery connection integerDatetimes registry template encoder prepared params =   {-# SCC "sendParametricQuery" #-}    if prepared     then       let         (oidList, valueAndFormatList) =-          ParamsEncoding.run' encoder params integerDatetimes+          ParamsEncoders.run' encoder params integerDatetimes         in           sendPreparedParametricQuery connection registry template oidList valueAndFormatList     else       let         paramList =-          ParamsEncoding.run'' encoder params integerDatetimes+          ParamsEncoders.run'' encoder params integerDatetimes         in           sendUnpreparedParametricQuery connection template paramList  {-# INLINE sendNonparametricQuery #-}-sendNonparametricQuery :: LibPQ.Connection -> ByteString -> IO (Either ResultsDecoding.Error ())+sendNonparametricQuery :: LibPQ.Connection -> ByteString -> IO (Either ResultsDecoders.Error ()) sendNonparametricQuery connection sql =   checkedSend connection $ LibPQ.sendQuery connection sql
library/Hasql/Query.hs view
@@ -12,10 +12,10 @@ import Hasql.Prelude import qualified Database.PostgreSQL.LibPQ as LibPQ import qualified Hasql.PreparedStatementRegistry as PreparedStatementRegistry-import qualified Hasql.Decoding.Results as ResultsDecoding-import qualified Hasql.Decoding as Decoding-import qualified Hasql.Encoding.Params as ParamsEncoding-import qualified Hasql.Encoding as Encoding+import qualified Hasql.Decoders.Results as ResultsDecoders+import qualified Hasql.Decoders as Decoders+import qualified Hasql.Encoders.Params as ParamsEncoders+import qualified Hasql.Encoders as Encoders import qualified Hasql.Settings as Settings import qualified Hasql.IO as IO import qualified Hasql.Connection.Impl as Connection@@ -103,7 +103,7 @@ -- According to the format, -- parameters must be referred to using the positional notation, as in the following: -- @$1@, @$2@, @$3@ and etc.--- Those references must be used to refer to the values of the 'Encoding.Params' encoder.+-- Those references must be used to refer to the values of the 'Encoders.Params' encoder. --  -- Following is an example of the declaration of a prepared statement with its associated codecs. -- @@ -115,17 +115,17 @@ --     sql = --       "select ($1 + $2)" --     encoder =---       'contramap' 'fst' (Hasql.Encoding.'Hasql.Encoding.value' Hasql.Encoding.'Hasql.Encoding.int8') '<>'---       'contramap' 'snd' (Hasql.Encoding.'Hasql.Encoding.value' Hasql.Encoding.'Hasql.Encoding.int8')+--       'contramap' 'fst' (Hasql.Encoders.'Hasql.Encoders.value' Hasql.Encoders.'Hasql.Encoders.int8') '<>'+--       'contramap' 'snd' (Hasql.Encoders.'Hasql.Encoders.value' Hasql.Encoders.'Hasql.Encoders.int8') --     decoder =---       Hasql.Decoding.'Hasql.Decoding.singleRow' (Hasql.Decoding.'Hasql.Decoding.value' Hasql.Decoding.'Hasql.Decoding.int8')+--       Hasql.Decoders.'Hasql.Decoders.singleRow' (Hasql.Decoders.'Hasql.Decoders.value' Hasql.Decoders.'Hasql.Decoders.int8') -- @ --  -- The statement above accepts a product of two parameters of type 'Int64' -- and produces a single result of type 'Int64'. --  data Query a b =-  Query !ByteString !(Encoding.Params a) !(Decoding.Result b) !Bool+  Query !ByteString !(Encoders.Params a) !(Decoders.Result b) !Bool   deriving (Functor)  instance Profunctor Query where@@ -150,16 +150,16 @@  -- | -- WARNING: We need to take special care that the structure of--- the "ResultsDecoding.Error" type in the public API is an exact copy of+-- the "ResultsDecoders.Error" type in the public API is an exact copy of -- "Error", since we're using coercion.-coerceResultsError :: ResultsDecoding.Error -> ResultsError+coerceResultsError :: ResultsDecoders.Error -> ResultsError coerceResultsError =   unsafeCoerce -coerceDecoder :: Decoding.Result a -> ResultsDecoding.Results a+coerceDecoder :: Decoders.Result a -> ResultsDecoders.Results a coerceDecoder =   unsafeCoerce -coerceEncoder :: Encoding.Params a -> ParamsEncoding.Params a+coerceEncoder :: Encoders.Params a -> ParamsEncoders.Params a coerceEncoder =   unsafeCoerce
tasty/Main.hs view
@@ -3,38 +3,40 @@ import Main.Prelude hiding (assert, isRight, isLeft) import Test.QuickCheck.Instances import Test.Tasty-import qualified Main.Queries as Queries-import qualified Test.Tasty.HUnit as HUnit-import qualified Test.Tasty.SmallCheck as SmallCheck-import qualified Test.Tasty.QuickCheck as QuickCheck+import Test.Tasty.Runners+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck import qualified Test.QuickCheck as QuickCheck+import qualified Main.Queries as Queries import qualified Main.DSL as DSL import qualified Hasql.Query as Query-import qualified Hasql.Encoding as Encoding-import qualified Hasql.Decoding as Decoding+import qualified Hasql.Encoders as Encoders+import qualified Hasql.Decoders as Decoders  main =   defaultMain tree  tree =+  localOption (NumThreads 1) $   testGroup "All tests"   [-    HUnit.testCase "Enum" $-    HUnit.assertEqual "" (Right "ok") $+    testCase "Executing the same query twice" $+    pure ()+    ,+    testCase "Enum" $     let-      actual =-        unsafePerformIO $+      actualIO =         DSL.session $ do           let             query =-              Query.Query sql mempty Decoding.unit True+              Query.Query sql mempty Decoders.unit True               where                 sql =                   "drop type if exists mood"             in DSL.query () query           let             query =-              Query.Query sql mempty Decoding.unit True+              Query.Query sql mempty Decoders.unit True               where                 sql =                   "create type mood as enum ('sad', 'ok', 'happy')"@@ -46,17 +48,15 @@                 sql =                   "select ($1 :: mood)"                 decoder =-                  (Decoding.singleRow (Decoding.value (Decoding.enum (Just . id))))+                  (Decoders.singleRow (Decoders.value (Decoders.enum (Just . id))))                 encoder =-                  Encoding.value (Encoding.enum id)+                  Encoders.value (Encoders.enum id)             in DSL.query "ok" query-      in actual+      in actualIO >>= assertEqual "" (Right "ok")     ,-    HUnit.testCase "The same prepared statement used on different types" $ -    HUnit.assertEqual "" (Right ("ok", 1)) $+    testCase "The same prepared statement used on different types" $      let-      actual =-        unsafePerformIO $+      actualIO =         DSL.session $ do           let             effect1 =@@ -68,9 +68,9 @@                     sql =                       "select $1"                     encoder =-                      Encoding.value Encoding.text+                      Encoders.value Encoders.text                     decoder =-                      (Decoding.singleRow (Decoding.value (Decoding.text)))+                      (Decoders.singleRow (Decoders.value (Decoders.text)))             effect2 =               DSL.query 1 query               where@@ -80,17 +80,16 @@                     sql =                       "select $1"                     encoder =-                      Encoding.value Encoding.int8+                      Encoders.value Encoders.int8                     decoder =-                      (Decoding.singleRow (Decoding.value Decoding.int8))+                      (Decoders.singleRow (Decoders.value Decoders.int8))             in (,) <$> effect1 <*> effect2-      in actual+      in actualIO >>= assertEqual "" (Right ("ok", 1))     ,-    HUnit.testCase "Affected rows counting" $-    HUnit.assertEqual "" (Right 100) $+    testCase "Affected rows counting" $+    replicateM_ 13 $     let-      actual =-        unsafePerformIO $+      actualIO =         DSL.session $ do           dropTable           createTable@@ -112,25 +111,25 @@               sql =                 "delete from a"               decoder =-                Decoding.rowsAffected-      in actual+                Decoders.rowsAffected+      in actualIO >>= assertEqual "" (Right 100)     ,-    HUnit.testCase "Result of an auto-incremented column" $+    testCase "Result of an auto-incremented column" $     let       actualIO =         DSL.session $ do           DSL.query () $ Queries.plain $ "drop table if exists a"           DSL.query () $ Queries.plain $ "create table a (id serial not null, v char not null, primary key (id))"-          id1 <- DSL.query () $ Query.Query "insert into a (v) values ('a') returning id" def (Decoding.singleRow (Decoding.value Decoding.int4)) False-          id2 <- DSL.query () $ Query.Query "insert into a (v) values ('b') returning id" def (Decoding.singleRow (Decoding.value Decoding.int4)) False+          id1 <- DSL.query () $ Query.Query "insert into a (v) values ('a') returning id" def (Decoders.singleRow (Decoders.value Decoders.int4)) False+          id2 <- DSL.query () $ Query.Query "insert into a (v) values ('b') returning id" def (Decoders.singleRow (Decoders.value Decoders.int4)) False           DSL.query () $ Queries.plain $ "drop table if exists a"           pure (id1, id2)-      in HUnit.assertEqual "" (Right (1, 2)) =<< actualIO+      in assertEqual "" (Right (1, 2)) =<< actualIO     ,-    HUnit.testCase "List decoding" $+    testCase "List decoding" $     let       actualIO =         DSL.session $ DSL.query () $ Queries.selectList-      in HUnit.assertEqual "" (Right [(1, 2), (3, 4), (5, 6)]) =<< actualIO+      in assertEqual "" (Right [(1, 2), (3, 4), (5, 6)]) =<< actualIO   ]
tasty/Main/DSL.hs view
@@ -4,8 +4,8 @@ import qualified Hasql.Connection as HC import qualified Hasql.Query as HQ import qualified Hasql.Settings as HS-import qualified Hasql.Encoding as HE-import qualified Hasql.Decoding as HD+import qualified Hasql.Encoders as HE+import qualified Hasql.Decoders as HD   newtype Session a =
tasty/Main/Queries.hs view
@@ -2,8 +2,8 @@  import Main.Prelude hiding (def) import qualified Hasql.Query as HQ-import qualified Hasql.Encoding as HE-import qualified Hasql.Decoding as HD+import qualified Hasql.Encoders as HE+import qualified Hasql.Decoders as HD import qualified Main.Prelude as Prelude