Merge branch 'master' into pipelining

* master:
  Set package version to 1.6.4.4
  Get rid of the decidable instance

# Conflicts:
#	library/Hasql/Session/Core.hs

CHANGELOG.md

@@ -1,3 +1,7 @@
+# 1.7
+
+- Decidable instance on `Encoders.Params` removed. It was useless and limited the design.
+
 # 1.6.3.1
 
 - Moved to "postgresql-libpq-0.10"

hasql.cabal

@@ -1,6 +1,6 @@
 cabal-version: 3.0
 name: hasql
-version: 1.6.4.3
+version: 1.6.4.4
 category: Hasql, Database, PostgreSQL
 synopsis: An efficient PostgreSQL driver with a flexible mapping API
 description:
@@ -27,8 +27,8 @@ source-repository head
 common base
   default-language: Haskell2010
   default-extensions:
-    Arrows
     ApplicativeDo
+    Arrows
     BangPatterns
     BlockArguments
     ConstraintKinds
@@ -53,8 +53,8 @@ common base
     MultiWayIf
     NoImplicitPrelude
     NoMonomorphismRestriction
-    OverloadedStrings
     OverloadedRecordDot
+    OverloadedStrings
     ParallelListComp
     PatternGuards
     QuasiQuotes
@@ -146,8 +146,9 @@ library testing-utils
   hs-source-dirs: testing-utils
   exposed-modules:
     Hasql.TestingUtils.Constants
-    Hasql.TestingUtils.TestingDsl
     Hasql.TestingUtils.Statements.GenerateSeries
+    Hasql.TestingUtils.TestingDsl
+
   build-depends:
     hasql,
     rerebase <2,
@@ -213,7 +214,6 @@ test-suite hspec
   main-is: Main.hs
   other-modules:
     Hasql.PipelineSpec
-    
 
   build-tool-depends: hspec-discover:hspec-discover
   build-depends:

library/Hasql/Encoders/All.hs

@@ -61,7 +61,7 @@ import Text.Builder qualified as C
 --     Female -> "female"
 -- @
 newtype Params a = Params (Params.Params a)
-  deriving (Contravariant, Divisible, Decidable, Monoid, Semigroup)
+  deriving (Contravariant, Divisible, Monoid, Semigroup)
 
 -- |
 -- No parameters. Same as `mempty` and `conquered`.

library/Hasql/Encoders/Params.hs

@@ -8,31 +8,76 @@ import PostgreSQL.Binary.Encoding qualified as B
 import Text.Builder qualified as E
 
 renderReadable :: Params a -> a -> [Text]
-renderReadable (Params (Op encoderOp)) params =
-  foldr step [] (encoderOp params)
-  where
-    step (_, _, _, rendering) acc =
-      rendering : acc
+renderReadable (Params _ _ _ printer) params =
+  printer params
+    & toList
 
 -- |
 -- Encoder of some representation of a parameters product.
-newtype Params a
-  = Params (Op (DList (A.Oid, A.Format, Bool -> Maybe ByteString, Text)) a)
-  deriving (Contravariant, Divisible, Decidable, Semigroup, Monoid)
+data Params a = Params
+  { size :: !Int,
+    columnsMetadata :: !(DList (A.Oid, A.Format)),
+    serializer :: Bool -> a -> DList (Maybe ByteString),
+    printer :: a -> DList Text
+  }
+
+instance Contravariant Params where
+  contramap fn (Params size columnsMetadata oldSerializer oldPrinter) = Params {..}
+    where
+      serializer idt = oldSerializer idt . fn
+      printer = oldPrinter . fn
+
+instance Divisible Params where
+  divide
+    divisor
+    (Params leftSize leftColumnsMetadata leftSerializer leftPrinter)
+    (Params rightSize rightColumnsMetadata rightSerializer rightPrinter) =
+      Params
+        { size = leftSize + rightSize,
+          columnsMetadata = leftColumnsMetadata <> rightColumnsMetadata,
+          serializer = \idt input -> case divisor input of
+            (leftInput, rightInput) -> leftSerializer idt leftInput <> rightSerializer idt rightInput,
+          printer = \input -> case divisor input of
+            (leftInput, rightInput) -> leftPrinter leftInput <> rightPrinter rightInput
+        }
+  conquer =
+    Params
+      { size = 0,
+        columnsMetadata = mempty,
+        serializer = mempty,
+        printer = mempty
+      }
+
+instance Semigroup (Params a) where
+  Params leftSize leftColumnsMetadata leftSerializer leftPrinter <> Params rightSize rightColumnsMetadata rightSerializer rightPrinter =
+    Params
+      { size = leftSize + rightSize,
+        columnsMetadata = leftColumnsMetadata <> rightColumnsMetadata,
+        serializer = \idt input -> leftSerializer idt input <> rightSerializer idt input,
+        printer = \input -> leftPrinter input <> rightPrinter input
+      }
+
+instance Monoid (Params a) where
+  mempty = conquer
 
 value :: C.Value a -> Params a
-value =
-  contramap Just . nullableValue
+value (C.Value valueOID _ serialize print) =
+  Params
+    { size = 1,
+      columnsMetadata = pure (pqOid, format),
+      serializer = \idt -> pure . Just . B.encodingBytes . serialize idt,
+      printer = pure . E.run . print
+    }
+  where
+    D.OID _ pqOid format = valueOID
 
 nullableValue :: C.Value a -> Params (Maybe a)
-nullableValue (C.Value valueOID arrayOID encode render) =
+nullableValue (C.Value valueOID _ serialize print) =
   Params
-    $ Op
-    $ \input ->
-      let D.OID _ pqOid format =
-            valueOID
-          encoder env =
-            fmap (B.encodingBytes . encode env) input
-          rendering =
-            maybe "null" (E.run . render) input
-       in pure (pqOid, format, encoder, rendering)
+    { size = 1,
+      columnsMetadata = pure (pqOid, format),
+      serializer = \idt -> pure . fmap (B.encodingBytes . serialize idt),
+      printer = pure . maybe "null" (E.run . print)
+    }
+  where
+    D.OID _ pqOid format = valueOID

library/Hasql/IO.hs

@@ -114,16 +114,17 @@ sendPreparedParametricStatement ::
   ParamsEncoders.Params a ->
   a ->
   IO (Either CommandError ())
-sendPreparedParametricStatement connection registry integerDatetimes template (ParamsEncoders.Params (Op encoderOp)) input =
-  let (oidList, valueAndFormatList) =
-        let step (oid, format, encoder, _) ~(oidList, bytesAndFormatList) =
-              (,)
-                (oid : oidList)
-                (fmap (\bytes -> (bytes, format)) (encoder integerDatetimes) : bytesAndFormatList)
-         in foldr step ([], []) (encoderOp input)
-   in runExceptT $ do
-        key <- ExceptT $ getPreparedStatementKey connection registry template oidList
-        ExceptT $ checkedSend connection $ LibPQ.sendQueryPrepared connection key valueAndFormatList LibPQ.Binary
+sendPreparedParametricStatement connection registry integerDatetimes template (ParamsEncoders.Params size columnsMetadata serializer _) input =
+  runExceptT $ do
+    key <- ExceptT $ getPreparedStatementKey connection registry template oidList
+    ExceptT $ checkedSend connection $ LibPQ.sendQueryPrepared connection key valueAndFormatList LibPQ.Binary
+  where
+    (oidList, formatList) =
+      columnsMetadata & toList & unzip
+    valueAndFormatList =
+      serializer integerDatetimes input
+        & toList
+        & zipWith (\format encoding -> (,format) <$> encoding) formatList
 
 {-# INLINE sendUnpreparedParametricStatement #-}
 sendUnpreparedParametricStatement ::
@@ -133,11 +134,14 @@ sendUnpreparedParametricStatement ::
   ParamsEncoders.Params a ->
   a ->
   IO (Either CommandError ())
-sendUnpreparedParametricStatement connection integerDatetimes template (ParamsEncoders.Params (Op encoderOp)) input =
+sendUnpreparedParametricStatement connection integerDatetimes template (ParamsEncoders.Params _ columnsMetadata serializer printer) input =
   let params =
-        let step (oid, format, encoder, _) acc =
-              ((,,) <$> pure oid <*> encoder integerDatetimes <*> pure format) : acc
-         in foldr step [] (encoderOp input)
+        zipWith
+          ( \(oid, format) encoding ->
+              (,,) <$> pure oid <*> encoding <*> pure format
+          )
+          (toList columnsMetadata)
+          (toList (serializer integerDatetimes input))
    in checkedSend connection $ LibPQ.sendQueryParams connection template params LibPQ.Binary
 
 {-# INLINE sendParametricStatement #-}

tasty/Main.hs

@@ -372,32 +372,6 @@ tree =
                               Encoders.param (Encoders.nonNullable (Encoders.unknown))
                      in Session.statement "ok" statement
              in actualIO >>= assertEqual "" (Right True),
-        testCase "Textual Unknown"
-          $ let actualIO =
-                  Session.runSessionOnLocalDb $ do
-                    let statement =
-                          Statement.Statement sql mempty Decoders.noResult True
-                          where
-                            sql =
-                              "create or replace function overloaded(a int, b int) returns int as $$ select a + b $$ language sql;"
-                     in Session.statement () statement
-                    let statement =
-                          Statement.Statement sql mempty Decoders.noResult True
-                          where
-                            sql =
-                              "create or replace function overloaded(a text, b text, c text) returns text as $$ select a || b || c $$ language sql;"
-                     in Session.statement () statement
-                    let statement =
-                          Statement.Statement sql encoder decoder True
-                          where
-                            sql =
-                              "select overloaded($1, $2) || overloaded($3, $4, $5)"
-                            decoder =
-                              (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.text)))
-                            encoder =
-                              contramany (Encoders.param (Encoders.nonNullable (Encoders.unknown)))
-                     in Session.statement ["1", "2", "4", "5", "6"] statement
-             in actualIO >>= assertEqual "" (Right "3456"),
         testCase "Enum"
           $ let actualIO =
                   Session.runSessionOnLocalDb $ do