Bump bounds and support hasql-1.10

rel8-internal/rel8-internal.cabal

@@ -21,16 +21,16 @@ library
     , attoparsec
     , base >= 4.16 && < 4.23
     , base16 >= 1.0
-    , base-compat >= 0.11 && < 0.15
+    , base-compat >= 0.11 && < 0.16
     , bytestring
     , case-insensitive
     , comonad
     , containers
     , contravariant
-    , hasql >= 1.8 && < 1.10
+    , hasql >= 1.8 && < 1.10.4
     , iproute ^>= 1.7
     , opaleye ^>= 0.10.2.1
-    , postgresql-binary ^>= 0.14.2
+    , postgresql-binary ^>= 0.15.0
     , pretty
     , profunctors
     , product-profunctors

rel8-internal/src/Rel8/Internal/Statement.hs

@@ -10,12 +10,14 @@
 {-# language StandaloneKindSignatures #-}
 {-# language TypeAbstractions #-}
 {-# language TypeApplications #-}
+{-# language CPP #-}
 
 module Rel8.Internal.Statement
   ( Statement
   , statementReturning
   , statementNoReturning
   , ppDecodeStatement
+  , encodeDoc
   )
 where
 
@@ -30,6 +32,9 @@ import Data.Monoid (Endo (Endo))
 import Data.String (fromString)
 import Prelude
 
+-- bytestring
+import Data.ByteString (ByteString)
+
 -- hasql
 import qualified Hasql.Decoders as Hasql
 
@@ -67,12 +72,17 @@ import Rel8.Internal.Table.Serialize (parse)
 import Data.Functor.Apply (Apply, WrappedApplicative (..))
 import Data.Functor.Bind (Bind, (>>-))
 
+-- text
+import qualified Data.Text as Text
+import Data.Text.Encoding (encodeUtf8)
+
 -- transformers
 import Control.Monad.Trans.Class (lift)
 import Control.Monad.Trans.State.Strict (State, evalState)
 import Control.Monad.Trans.Writer.CPS (WriterT, runWriterT, tell)
 
 
+
 type Binding :: Type
 data Binding = Binding
   { relation :: !String
@@ -286,6 +296,20 @@ ppDecodeStatement ppSelect rows (Statement m) = evalState go Opaleye.start
                 doc <- ppWith bindings' <$> ppSelect query
                 pure (doc, Hasql.rowVector (parse @exprs @a))
 
+-- | Encode a document into the text type that Hasql expects
+#if MIN_VERSION_hasql(1,10,0)
+encodeDoc :: Doc -> Text.Text
+#else
+encodeDoc :: Doc -> ByteString
+#endif
+encodeDoc doc = bytes
+  where
+    bytes =
+#if !MIN_VERSION_hasql(1,10,0)
+      encodeUtf8  $
+#endif
+      Text.pack sql
+    sql = show doc
 
 ppWith :: [Binding] -> Doc -> Doc
 ppWith bindings after = pre $$ after
@@ -311,3 +335,4 @@ ppAlias Binding {relation, columns = mcolumns} = case mcolumns of
 
 unsnoc :: [a] -> Maybe ([a], a)
 unsnoc = foldr (\x -> Just . maybe ([], x) (\(~(a, b)) -> (x : a, b))) Nothing
+

rel8-internal/src/Rel8/Internal/Statement/Prepared.hs

@@ -5,17 +5,26 @@
 {-# language NamedFieldPuns #-}
 {-# language ScopedTypeVariables #-}
 {-# language TypeApplications #-}
+{-# language CPP #-}
+{-# language ScopedTypeVariables #-}
+{-# language DataKinds #-}
 
-module Rel8.Internal.Statement.Prepared (
-  input,
-  prepared,
+module Rel8.Internal.Statement.Prepared
+  ( input
+  , preparedRun_
+  , preparedRunN
+  , preparedRun1
+  , preparedRunMaybe
+  , preparedRun
+  , preparedRunVector
 ) where
 
 -- base
 import Data.Functor.Const (Const (Const), getConst)
 import Data.Functor.Contravariant (contramap, (>$<))
 import Data.Functor.Identity (runIdentity)
 import Prelude
+import Data.Int (Int64)
 
 -- hasql
 import qualified Hasql.Encoders as Hasql
@@ -25,6 +34,7 @@ import qualified Hasql.Statement as Hasql
 import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
 
 -- rel8
+import Rel8.Internal.Query (Query)
 import Rel8.Internal.Expr (Expr)
 import Rel8.Internal.Expr.Opaleye (fromPrimExpr, scastExpr)
 import Rel8.Internal.Schema.HTable (hfield, hspecs, htabulateA)
@@ -35,29 +45,24 @@ import Rel8.Internal.Table (Table, fromColumns, toResult)
 import Rel8.Internal.Table.Serialize (Serializable)
 import Rel8.Internal.Type.Encoder (binary)
 import Rel8.Internal.Type.Information (encode)
+import Rel8.Internal.Statement.Rows (Rows (..))
+import Rel8.Internal.Statement (Statement, ppDecodeStatement, encodeDoc)
+import Rel8.Internal.Statement.Select (ppSelect)
+
+-- text
+import qualified Data.Text as Text
 
 -- transformers
 import Control.Monad.Trans.State.Strict (evalState, state)
 
+-- vector
+import Data.Vector (Vector)
 
-{-| Given a 'Rel8.run' function that converts a 'Statement' to a
-'Hasql.Statement', return a 'Rel8.run'-like function which instead takes a
-/parameterized/ 'Statement' and converts it to a /preparable/
-'Hasql.Statement'.
-
-The parameters @i@ are sent to the database directly via PostgreSQL's binary
-format. For large amounts of data this can be significantly more efficient
-than embedding the values in the statement with 'Rel8.Internal.lit'.
--}
-prepared :: forall a b i o.
-  Serializable a i =>
-  (Statement b -> Hasql.Statement () o) ->
-  (a -> Statement b) ->
-  Hasql.Statement i o
-prepared run mkStatement = Hasql.Statement sql (encoder @a) decode True
+makePreparedRun :: forall a exprs params i. (Serializable params i) => Rows exprs a -> (params -> Statement exprs) -> Hasql.Statement i a
+makePreparedRun rows statement = Hasql.preparable bytes (encoder @params) decode 
   where
-    Hasql.Statement sql _ decode _ = run $ mkStatement input
-
+    bytes = encodeDoc doc
+    (doc, decode) = ppDecodeStatement ppSelect rows (statement input)
 
 encoder :: forall a i. Serializable a i => Hasql.Params i
 encoder =
@@ -85,3 +90,68 @@ input =
             Spec {info} ->
               scastExpr info $ fromPrimExpr $
                 Opaleye.ConstExpr $ Opaleye.OtherLit $ '$' : show n
+
+-- | Convert a 'Statement' to a prepared runnable 'Hasql.Statement', disregarding the
+-- results of that statement (if any).
+--
+-- @
+-- preparedRun_ :: (Serializable params i) => (params -> Rel8.'Statement' exprs) -> Hasql.'Hasql.Statement' i ()
+-- @
+preparedRun_ :: (Serializable params i) => (params -> Statement exprs) -> Hasql.Statement i ()
+preparedRun_ = makePreparedRun Void
+
+
+-- | Convert a 'Statement' to a prepared runnable 'Hasql.Statement', returning the
+-- number of rows affected by that statement (for 'Rel8.insert's,
+-- 'Rel8.update's or Rel8.delete's with 'Rel8.NoReturning').
+--
+-- @
+-- preparedRunN :: (Serializable params i) => (params -> Rel8.'Statement' ()) -> Hasql.'Hasql.Statement' i Int64
+-- @
+preparedRunN :: (Serializable params i) => (params -> Statement ()) -> Hasql.Statement i Int64
+preparedRunN = makePreparedRun RowsAffected
+
+
+-- | Convert a 'Statement' to a prepared runnable 'Hasql.Statement', processing the
+-- result of the statement as a single row. If the statement returns a number
+-- of rows other than 1, a preparedRuntime exception is thrown.
+--
+-- @
+-- preparedRun1 ::(Serializable params i, Serializable exprs a) => (params -> Rel8.'Statement' (Query exprs)) -> Hasql.'Hasql.Statement' i a
+-- @
+preparedRun1 ::(Serializable params i, Serializable exprs a) => (params -> Statement (Query exprs)) -> Hasql.Statement i a
+preparedRun1 = makePreparedRun Single
+
+
+-- | Convert a 'Statement' to a prepared runnable 'Hasql.Statement', processing the
+-- result of the statement as 'Maybe' a single row. If the statement returns
+-- a number of rows other than 0 or 1, a preparedRuntime exception is thrown.
+--
+-- @
+-- preparedRunMaybe :: (Serializable params i, Serializable exprs a) => (params -> Rel8.'Statement' (Query exprs)) -> Hasql.'Hasql.Statement' i (Maybe a)
+-- @
+preparedRunMaybe :: (Serializable params i, Serializable exprs a)
+  => (params -> Statement (Query exprs)) -> Hasql.Statement i (Maybe a)
+preparedRunMaybe = makePreparedRun Maybe
+
+
+-- | Convert a 'Statement' to a prepared runnable 'Hasql.Statement', processing the
+-- result of the statement as a list of rows.
+--
+-- @
+-- preparedRun :: (Serializable params i, Serializable exprs a) => (params -> Rel8.'Statement' (Query exprs)) -> Hasql.'Hasql.Statement' i [a]
+-- @
+preparedRun :: (Serializable params i, Serializable exprs a)
+  => (params -> Statement (Query exprs)) -> Hasql.Statement i [a]
+preparedRun = makePreparedRun List
+
+
+-- | Convert a 'Statement' to a prepared runnable 'Hasql.Statement', processing the
+-- result of the statement as a 'Vector' of rows.
+--
+-- @
+-- preparedRunVector :: (Serializable params i, Serializable exprs a) => (params -> Rel8.'Statement' (Query exprs)) -> Hasql.'Hasql.Statement' i (Vector a)
+-- @
+preparedRunVector :: (Serializable params i, Serializable exprs a)
+  => (params -> Statement (Query exprs)) -> Hasql.Statement i (Vector a)
+preparedRunVector = makePreparedRun Vector

rel8-internal/src/Rel8/Internal/Statement/Run.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 module Rel8.Internal.Statement.Run
   ( run_
   , runN
@@ -18,7 +19,7 @@ import qualified Hasql.Statement as Hasql
 
 -- rel8
 import Rel8.Internal.Query (Query)
-import Rel8.Internal.Statement (Statement, ppDecodeStatement)
+import Rel8.Internal.Statement (Statement, ppDecodeStatement, encodeDoc)
 import Rel8.Internal.Statement.Rows (Rows (..))
 import Rel8.Internal.Statement.Select (ppSelect)
 import Rel8.Internal.Table.Serialize (Serializable)
@@ -32,12 +33,10 @@ import Data.Vector (Vector)
 
 
 makeRun :: Rows exprs a -> Statement exprs -> Hasql.Statement () a
-makeRun rows statement = Hasql.Statement bytes params decode prepare
+makeRun rows statement = Hasql.unpreparable bytes params decode 
   where
-    bytes = encodeUtf8 $ Text.pack sql
+    bytes = encodeDoc doc
     params = Hasql.noParams
-    prepare = False
-    sql = show doc
     (doc, decode) = ppDecodeStatement ppSelect rows statement
 
 

rel8-internal/src/Rel8/Internal/Statement/View.hs

@@ -1,5 +1,6 @@
 {-# language FlexibleContexts #-}
 {-# language MonoLocalBinds #-}
+{-# language CPP #-}
 
 module Rel8.Internal.Statement.View
   ( createView
@@ -62,12 +63,15 @@ createOrReplaceView =
 createViewGeneric :: Selects names exprs
   => CreateView -> TableSchema names -> Query exprs -> Hasql.Statement () ()
 createViewGeneric replace schema query =
-  Hasql.Statement bytes params decode prepare
+  Hasql.unpreparable bytes params decode
   where
-    bytes = encodeUtf8 (Text.pack sql)
+    bytes =
+#if !MIN_VERSION_hasql(1,10,0)
+      encodeUtf8 $
+#endif
+      Text.pack sql
     params = Hasql.noParams
     decode = Hasql.noResult
-    prepare = False
     sql = show doc
     doc = ppCreateView schema query replace
 

rel8-internal/src/Rel8/Internal/Type/Composite.hs

@@ -13,6 +13,8 @@
 {-# language UndecidableInstances #-}
 {-# language UndecidableSuperClasses #-}
 {-# language ViewPatterns #-}
+{-# language CPP #-}
+{-# language OverloadedRecordDot #-}
 
 module Rel8.Internal.Type.Composite
   ( Composite( Composite )
@@ -56,6 +58,7 @@ import Rel8.Internal.Schema.HTable ( HTable, hfield, hspecs, htabulate, htabulat
 import Rel8.Internal.Schema.Name ( Name( Name ) )
 import Rel8.Internal.Schema.Null ( Nullity( Null, NotNull ) )
 import Rel8.Internal.Schema.QualifiedName (QualifiedName)
+import qualified Rel8.Internal.Schema.QualifiedName 
 import Rel8.Internal.Schema.Result ( Result )
 import Rel8.Internal.Schema.Spec ( Spec( Spec, nullity, info ) )
 import Rel8.Internal.Table ( fromColumns, toColumns, fromResult, toResult )
@@ -79,6 +82,9 @@ import Rel8.Internal.Type.Parser (parse)
 -- semigroupoids
 import Data.Functor.Apply ( WrappedApplicative(..) )
 
+-- text
+import qualified Data.Text as Text
+
 -- transformers
 import Control.Monad.Trans.Class (lift)
 import Control.Monad.Trans.State.Strict (StateT (StateT), runStateT)
@@ -101,12 +107,22 @@ instance DBComposite a => DBType (Composite a) where
   typeInformation = TypeInformation
     { decode =
         Decoder
-          { binary = Decoders.composite (Composite . fromResult @_ @(HKD a Expr) <$> decoder)
+          { binary = Decoders.composite
+#if MIN_VERSION_hasql(1,10,0)
+              (Text.pack <$> (compositeTypeName @a).schema)
+              (Text.pack (compositeTypeName @a).name)
+#endif
+              (Composite . fromResult @_ @(HKD a Expr) <$> decoder)
           , text = fmap (Composite . fromResult @_ @(HKD a Expr)) . parser
           }
     , encode =
         Encoder
-          { binary = Encoders.composite (toResult @_ @(HKD a Expr) . unComposite >$< encoder)
+          { binary = Encoders.composite
+#if MIN_VERSION_hasql(1,10,0)
+              (Text.pack <$> (compositeTypeName @a).schema)
+              (Text.pack (compositeTypeName @a).name)
+#endif
+              (toResult @_ @(HKD a Expr) . unComposite >$< encoder)
           , text = builder . toResult @_ @(HKD a Expr) . unComposite
           , quote = quoter . litHTable . toResult @_ @(HKD a Expr) . unComposite
           }