Export select, insert, update and delete as Hasql.Statements (

#94)

Fixes #82

Changelog.md

@@ -45,6 +45,8 @@
   * `Table` has a new associated type - `FromExprs`. This was previously an open type family.
   * `Table` has a new associated type - `Transpose` - and `Recontextualise` has been renamed to `Transposes`. This `Transposes` class now operates in terms of `Transpose`.
 
+* `select`, `insert`, `update` and `delete` now produce Hasql `Statement`s, rather than actually running the statement as IO. This allows Rel8 to be used with transaction/connection-managing monads like [`hasql-transaction`](https://hackage.haskell.org/package/hasql-transaction). ([#94](https://github.com/circuithub/rel8/pull/94))
+
 ## Bug fixes
 
 * Fixes a bug where cartesian products of queries using `catListTable`, `catNonEmptyTable`, `catList` and `catNonEmpty` would incorrectly be zipped instead. ([#61](https://github.com/circuithub/rel8/pull/61))

rel8.cabal

@@ -37,7 +37,6 @@ library
     , text
     , these
     , time
-    , transformers
     , uuid
   default-language:
     Haskell2010
@@ -201,16 +200,17 @@ test-suite tests
     , case-insensitive
     , containers
     , hasql
+    , hasql-transaction
     , hedgehog          ^>=1.0.2
-    , lifted-base       ^>=0.2.3.12
-    , monad-control     ^>=1.0.2.3
+    , mmorph
     , rel8
     , scientific
     , tasty
     , tasty-hedgehog
     , text
     , time
     , tmp-postgres      ^>=1.34.1.0
+    , transformers
     , uuid
 
   other-modules:

src/Rel8/Query/SQL.hs

@@ -18,4 +18,4 @@ import Rel8.Table ( Table )
 
 -- | Convert a 'Query' to a 'String' containing a @SELECT@ statement.
 showQuery :: Table Expr a => Query a -> String
-showQuery = foldMap show . ppSelect
+showQuery = show . ppSelect

src/Rel8/Statement/Delete.hs

@@ -14,14 +14,11 @@ module Rel8.Statement.Delete
 where
 
 -- base
-import Control.Exception ( throwIO )
 import Data.Kind ( Type )
 import Prelude
 
 -- hasql
-import Hasql.Connection ( Connection )
 import qualified Hasql.Encoders as Hasql
-import qualified Hasql.Session as Hasql
 import qualified Hasql.Statement as Hasql
 
 -- pretty
@@ -32,10 +29,7 @@ import Rel8.Expr ( Expr )
 import Rel8.Query ( Query )
 import Rel8.Schema.Name ( Selects )
 import Rel8.Schema.Table ( TableSchema, ppTable )
-import Rel8.Statement.Returning
-  ( Returning
-  , decodeReturning, emptyReturning, ppReturning
-  )
+import Rel8.Statement.Returning ( Returning, decodeReturning, ppReturning )
 import Rel8.Statement.Using ( ppUsing )
 import Rel8.Statement.Where ( ppWhere )
 
@@ -61,26 +55,25 @@ data Delete a where
     -> Delete a
 
 
-ppDelete :: Delete a -> Maybe Doc
-ppDelete Delete {..} = do
-  (usingDoc, i) <- ppUsing using
-  pure $ text "DELETE FROM" <+> ppTable from
-    $$ usingDoc
-    $$ ppWhere from (deleteWhere i)
-    $$ ppReturning from returning
+ppDelete :: Delete a -> Doc
+ppDelete Delete {..} = case ppUsing using of
+  Nothing ->
+    text "DELETE FROM" <+> ppTable from $$
+    text "WHERE false"
+  Just (usingDoc, i) ->
+    text "DELETE FROM" <+> ppTable from $$
+    usingDoc $$
+    ppWhere from (deleteWhere i) $$
+    ppReturning from returning
 
 
 -- | Run a 'Delete' statement.
-delete :: Connection -> Delete a -> IO a
-delete connection d@Delete {returning} =
-  case show <$> ppDelete d of
-    Nothing -> pure (emptyReturning returning)
-    Just sql ->
-      Hasql.run session connection >>= either throwIO pure
-      where
-        session = Hasql.statement () statement
-        statement = Hasql.Statement bytes params decode prepare
-        bytes = encodeUtf8 $ Text.pack sql
-        params = Hasql.noParams
-        decode = decodeReturning returning
-        prepare = False
+delete :: Delete a -> Hasql.Statement () a
+delete d@Delete {returning} = Hasql.Statement bytes params decode prepare
+  where
+    bytes = encodeUtf8 $ Text.pack sql
+    params = Hasql.noParams
+    decode = decodeReturning returning
+    prepare = False
+    sql = show doc
+    doc = ppDelete d

src/Rel8/Statement/Insert.hs

@@ -15,15 +15,12 @@ module Rel8.Statement.Insert
 where
 
 -- base
-import Control.Exception ( throwIO )
 import Data.Foldable ( toList )
 import Data.Kind ( Type )
 import Prelude
 
 -- hasql
-import Hasql.Connection ( Connection )
 import qualified Hasql.Encoders as Hasql
-import qualified Hasql.Session as Hasql
 import qualified Hasql.Statement as Hasql
 
 -- opaleye
@@ -37,10 +34,7 @@ import Rel8.Query ( Query )
 import Rel8.Schema.Name ( Name, Selects, ppColumn )
 import Rel8.Schema.Table ( TableSchema(..), ppTable )
 import Rel8.Statement.OnConflict ( OnConflict, ppOnConflict )
-import Rel8.Statement.Returning
-  ( Returning
-  , decodeReturning, emptyReturning, ppReturning
-  )
+import Rel8.Statement.Returning ( Returning, decodeReturning, ppReturning )
 import Rel8.Statement.Select ( ppSelect )
 import Rel8.Table ( Table )
 import Rel8.Table.Name ( showNames )
@@ -68,13 +62,13 @@ data Insert a where
     -> Insert a
 
 
-ppInsert :: Insert a -> Maybe Doc
-ppInsert Insert {..} = do
-  rows' <- ppSelect rows
-  pure $ text "INSERT INTO" <+> ppInto into
-    $$ rows'
-    $$ ppOnConflict into onConflict
-    $$ ppReturning into returning
+ppInsert :: Insert a -> Doc
+ppInsert Insert {..} =
+  text "INSERT INTO" <+>
+  ppInto into $$
+  ppSelect rows $$
+  ppOnConflict into onConflict $$
+  ppReturning into returning
 
 
 ppInto :: Table Name a => TableSchema a -> Doc
@@ -84,16 +78,12 @@ ppInto table@TableSchema {columns} =
 
 
 -- | Run an 'Insert' statement.
-insert :: Connection -> Insert a -> IO a
-insert connection i@Insert {returning} =
-  case show <$> ppInsert i of
-    Nothing -> pure (emptyReturning returning)
-    Just sql ->
-      Hasql.run session connection >>= either throwIO pure
-      where
-        session = Hasql.statement () statement
-        statement = Hasql.Statement bytes params decode prepare
-        bytes = encodeUtf8 $ Text.pack sql
-        params = Hasql.noParams
-        decode = decodeReturning returning
-        prepare = False
+insert :: Insert a -> Hasql.Statement () a
+insert i@Insert {returning} = Hasql.Statement bytes params decode prepare
+  where
+    bytes = encodeUtf8 $ Text.pack sql
+    params = Hasql.noParams
+    decode = decodeReturning returning
+    prepare = False
+    sql = show doc
+    doc = ppInsert i

src/Rel8/Statement/Returning.hs

@@ -9,9 +9,7 @@
 
 module Rel8.Statement.Returning
   ( Returning( NumberOfRowsAffected, Projection )
-
   , decodeReturning
-  , emptyReturning
   , ppReturning
   )
 where
@@ -126,11 +124,6 @@ decodeReturning = runReturning
   (\decoder withRows -> withRows <$> Hasql.rowList decoder)
 
 
-emptyReturning :: Returning names a -> a
-emptyReturning =
-  runReturning (\withCount -> withCount 0) (\_ withRows -> withRows [])
-
-
 ppReturning :: TableSchema names -> Returning names a -> Doc
 ppReturning schema returning = case projections schema returning of
   Nothing -> mempty

src/Rel8/Statement/SQL.hs

@@ -16,14 +16,14 @@ import Rel8.Statement.Update ( Update, ppUpdate )
 
 -- | Convert a 'Delete' to a 'String' containing a @DELETE@ statement.
 showDelete :: Delete a -> String
-showDelete = foldMap show . ppDelete
+showDelete = show . ppDelete
 
 
 -- | Convert an 'Insert' to a 'String' containing an @INSERT@ statement.
 showInsert :: Insert a -> String
-showInsert = foldMap show . ppInsert
+showInsert = show . ppInsert
 
 
 -- | Convert an 'Update' to a 'String' containing an @UPDATE@ statement.
 showUpdate :: Update a -> String
-showUpdate = foldMap show . ppUpdate
+showUpdate = show . ppUpdate

src/Rel8/Statement/Select.hs

@@ -15,15 +15,12 @@ module Rel8.Statement.Select
 where
 
 -- base
-import Control.Exception ( throwIO )
 import Data.Void ( Void )
-import Prelude
+import Prelude hiding ( undefined )
 
 -- hasql
-import Hasql.Connection ( Connection )
 import qualified Hasql.Decoders as Hasql
 import qualified Hasql.Encoders as Hasql
-import qualified Hasql.Session as Hasql
 import qualified Hasql.Statement as Hasql
 
 -- opaleye
@@ -39,6 +36,8 @@ import Text.PrettyPrint ( Doc )
 
 -- rel8
 import Rel8.Expr ( Expr )
+import Rel8.Expr.Bool ( false )
+import Rel8.Expr.Opaleye ( toPrimExpr )
 import Rel8.Query ( Query )
 import Rel8.Query.Opaleye ( toOpaleye )
 import Rel8.Schema.Name ( Selects )
@@ -47,6 +46,7 @@ import Rel8.Table.Cols ( toCols )
 import Rel8.Table.Name ( namesFromLabels )
 import Rel8.Table.Opaleye ( castTable, exprsWithNames )
 import Rel8.Table.Serialize ( Serializable, parse )
+import Rel8.Table.Undefined ( undefined )
 
 -- text
 import qualified Data.Text as Text
@@ -55,31 +55,29 @@ import Data.Text.Encoding ( encodeUtf8 )
 
 -- | Run a @SELECT@ statement, returning all rows.
 select :: forall exprs a. Serializable exprs a
-  => Connection -> Query exprs -> IO [a]
-select c query = case ppSelect query of
-  Nothing -> pure []
-  Just doc -> Hasql.run session c >>= either throwIO pure
-    where
-      session = Hasql.statement () statement
-      statement = Hasql.Statement bytes params decode prepare
-      bytes = encodeUtf8 (Text.pack sql)
-      params = Hasql.noParams
-      decode = Hasql.rowList (parse @exprs @a)
-      prepare = False
-      sql = show doc
-
-
-ppSelect :: Table Expr a => Query a -> Maybe Doc
-ppSelect query = do
-  primQuery' <- case optimize primQuery of
-    Empty -> Nothing
-    Unit -> Just Opaleye.Unit
-    Optimized primQuery' -> Just primQuery'
-  pure $ Opaleye.ppSql $ primSelectWith names (toCols exprs) primQuery'
+  => Query exprs -> Hasql.Statement () [a]
+select query = Hasql.Statement bytes params decode prepare
+  where
+    bytes = encodeUtf8 (Text.pack sql)
+    params = Hasql.noParams
+    decode = Hasql.rowList (parse @exprs @a)
+    prepare = False
+    sql = show doc
+    doc = ppSelect query
+
+
+ppSelect :: Table Expr a => Query a -> Doc
+ppSelect query =
+  Opaleye.ppSql $ primSelectWith names (toCols exprs') primQuery'
   where
     names = namesFromLabels
     (exprs, primQuery, _) =
       Opaleye.runSimpleQueryArrStart (toOpaleye query) ()
+    (exprs', primQuery') = case optimize primQuery of
+      Empty -> (undefined, Opaleye.Product (pure (pure Opaleye.Unit)) never)
+      Unit -> (exprs, Opaleye.Unit)
+      Optimized pq -> (exprs, pq)
+    never = pure (toPrimExpr false)
 
 
 ppPrimSelect :: Query a -> (Optimized Doc, a)

src/Rel8/Statement/Update.hs

@@ -13,14 +13,11 @@ module Rel8.Statement.Update
 where
 
 -- base
-import Control.Exception ( throwIO )
 import Data.Kind ( Type )
 import Prelude
 
 -- hasql
-import Hasql.Connection ( Connection )
 import qualified Hasql.Encoders as Hasql
-import qualified Hasql.Session as Hasql
 import qualified Hasql.Statement as Hasql
 
 -- pretty
@@ -31,10 +28,7 @@ import Rel8.Expr ( Expr )
 import Rel8.Query ( Query )
 import Rel8.Schema.Name ( Selects )
 import Rel8.Schema.Table ( TableSchema(..), ppTable )
-import Rel8.Statement.Returning
-  ( Returning
-  , decodeReturning, emptyReturning, ppReturning
-  )
+import Rel8.Statement.Returning ( Returning, decodeReturning, ppReturning )
 import Rel8.Statement.Set ( ppSet )
 import Rel8.Statement.Using ( ppFrom )
 import Rel8.Statement.Where ( ppWhere )
@@ -63,29 +57,27 @@ data Update a where
     -> Update a
 
 
-ppUpdate :: Update a -> Maybe Doc
-ppUpdate Update {..} = do
-  (fromDoc, i) <- ppFrom from
-  pure $
-    text "UPDATE" <+>
-    ppTable target $$
+ppUpdate :: Update a -> Doc
+ppUpdate Update {..} = case ppFrom from of
+  Nothing ->
+    text "UPDATE" <+> ppTable target $$
+    ppSet target id $$
+    text "WHERE false"
+  Just (fromDoc, i) ->
+    text "UPDATE" <+> ppTable target $$
     ppSet target (set i) $$
     fromDoc $$
     ppWhere target (updateWhere i) $$
     ppReturning target returning
 
 
 -- | Run an @UPDATE@ statement.
-update :: Connection -> Update a -> IO a
-update connection u@Update {returning} =
-  case show <$> ppUpdate u of
-    Nothing -> pure (emptyReturning returning)
-    Just sql ->
-      Hasql.run session connection >>= either throwIO pure
-      where
-        session = Hasql.statement () statement
-        statement = Hasql.Statement bytes params decode prepare
-        bytes = encodeUtf8 $ Text.pack sql
-        params = Hasql.noParams
-        decode = decodeReturning returning
-        prepare = False
+update :: Update a -> Hasql.Statement () a
+update u@Update {returning} = Hasql.Statement bytes params decode prepare
+  where
+    bytes = encodeUtf8 $ Text.pack sql
+    params = Hasql.noParams
+    decode = decodeReturning returning
+    prepare = False
+    sql = show doc
+    doc = ppUpdate u