circuithub/rel8
1
1
Fork 0
mirror of https://github.com/circuithub/rel8.git synced 2024-10-05 13:17:38 +03:00
Code Issues Projects Releases Wiki Activity

Statements overhaul (support for statement-level WITH) (#250)

Browse Source 
The motivation behind this PR is to add support for PostreSQL's `WITH` syntax at the statement level, which gives the ability to, e.g., delete some rows from a table and then re-insert those deleted rows into another table, without any round-trips between the application and the database.

To support this, this PR introduces a new type called `Statement`, which represents a single PostgreSQL statement. It has a `Monad` instance which allows sub-statements (such as `DELETE` and `INSERT` statements) to be composed together and their results bound to values that can be referenced in subsequent sub-statements. These "compound" statements are then rendered as a `WITH` statement.

`select`, `insert`, `update` and `delete` have all been altered to produce the `Statement` type described above instead of the `Hasql.Statement` type.

Some changes were necessary to the `Returning` type. `Returning` previously bundled two different concepts together: whether or not to generate a `RETURNING` clause in the SQL for a manipulation statement, and how to decode the returned rows (if any). It was necessary to break these concepts apart because with `WITH` we need the ability to generate manipulation statements with `RETURNING` clauses that are never actually decoded at all (the results just get passed to the next statement without touching the application).

Now, the `Returning` type is only concerned with whether or not to generate a `RETURNING` clause, and the question of how to decode the returned the result of the statement is handled by the `run` functions. `run` converts a `Statement` into a runnable `Hasql.Statement`, decoding the result of the statement as a list of rows. The other variations, `run_`, `runN`, `run1`, `runMaybe` and `runVector` can be used when you want to decode as something other than a list of rows.

This also gains us support for decoding the result of a query directly to a `Vector` for the first time, which brings a performance improvement over lists for those who need it.
This commit is contained in:
Shane 2023-07-07 11:29:15 +01:00 committed by GitHub
parent 0357176c7b
commit 3c0b67f99e
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
18 changed files with 814 additions and 297 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
docs/concepts/insert.rst
View File

@ -3,14 +3,16 @@
While the majority of Rel8 is about building and executing ``SELECT``
statement, Rel8 also has support for ``INSERT``, ``UPDATE`` and ``DELETE``.
These statements are all executed using the ``insert``, ``update`` and
``delete`` functions, all of which take a record of parameters.
These statements are built using the ``insert``, ``update`` and ``delete```
functions, take ``Insert``, ``Update`` and ``Delete`` values respectively,
all of which are records of parameters.
.. note::
This part of Rel8's API uses the ``DuplicateRecordFields`` language
extension. In code that needs to use this API, you should also enable this
language extension, or you may get errors about ambiguous field names.
extension. In code that needs to use this API, you should enable the
``DisambiguateRecordFields`` language extension, or you may get errors
about ambiguous field names.
``DELETE``
----------
@ -110,7 +112,7 @@ PostgreSQL has the ability to return extra information after a ``DELETE``,
``INSERT`` or ``UPDATE`` statement by attaching a ``RETURNING`` clause. A common
use of this clause is to return any automatically generated sequence values for
primary key columns. Rel8 supports ``RETURNING`` clauses by filling in the
``returning`` field and specifying a ``Projection``. A ``Projection`` is a row
``returning`` field and specifying a ``Returning``. A ``Returning`` is a row
to row transformation, allowing you to project out a subset of fields.
For example, if we are inserting orders, we might want the order ids returned::
@ -119,16 +121,16 @@ For example, if we are inserting orders, we might want the order ids returned::
{ into = orderSchema
, rows = values [ order ]
, onConflict = Abort
, returning = Projection orderId
, returning = Returning orderId
}
If we don't want to return anything, we can use ``pure ()``::
If we don't want to return anything, we can use ``NoReturning``::
insert Insert
{ into = orderSchema
, rows = values [ order ]
, onConflict = Abort
, returning = pure ()
, returning = NoReturning
}
Default values
@ -148,7 +150,7 @@ construct the ``DEFAULT`` expression::
{ into = orderSchema
, rows = values [ Order { orderId = unsafeDefault, ... } ]
, onConflict = Abort
, returning = Projection orderId
, returning = Returning orderId
}
.. warning::
@ -162,6 +164,13 @@ construct the ``DEFAULT`` expression::
will lead to a runtime crash.
.. warning::
Also note PostgreSQL's syntax rules mean that ``DEFAULT``` can only appear
in ``INSERT``` expressions whose rows are specified using ``VALUES``. This
means that the ``rows`` field of your ``Insert`` record doesn't look like
``values [..]``, then ``unsafeDefault`` won't work.
Reimplement default values in Rel8
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@ -177,5 +186,5 @@ them in Rel8, rather than in your database schema.
{ into = orderSchema
, rows = values [ Order { orderId = nextval "order_id_seq", ... } ]
, onConflict = Abort
, returning = Projection orderId
, returning = Returning orderId
}

6
rel8.cabal
View File

@ -38,7 +38,9 @@ library
, text
, these
, time
, transformers
, uuid
, vector
default-language:
Haskell2010
ghc-options:
@ -151,10 +153,13 @@ library
Rel8.Schema.Spec
Rel8.Schema.Table
Rel8.Statement
Rel8.Statement.Delete
Rel8.Statement.Insert
Rel8.Statement.OnConflict
Rel8.Statement.Returning
Rel8.Statement.Rows
Rel8.Statement.Run
Rel8.Statement.Select
Rel8.Statement.Set
Rel8.Statement.SQL
@ -243,3 +248,4 @@ test-suite tests
-Wno-missing-import-lists -Wno-prepositive-qualified-module
-Wno-deprecations -Wno-monomorphism-restriction
-Wno-missing-local-signatures -Wno-implicit-prelude
-Wno-missing-kind-signatures

26
src/Rel8.hs
View File

@ -326,6 +326,12 @@ module Rel8
-- * Running statements
-- $running
, run
, run_
, runN
, run1
, runMaybe
, runVector
-- ** @SELECT@
, select
@ -351,6 +357,10 @@ module Rel8
-- ** @.. RETURNING@
, Returning(..)
-- ** @WITH@
, Statement
, showStatement
-- ** @CREATE VIEW@
, createView
, createOrReplaceView
@ -421,10 +431,12 @@ import Rel8.Schema.Name
import Rel8.Schema.Null hiding ( nullable )
import Rel8.Schema.Result ( Result )
import Rel8.Schema.Table
import Rel8.Statement
import Rel8.Statement.Delete
import Rel8.Statement.Insert
import Rel8.Statement.OnConflict
import Rel8.Statement.Returning
import Rel8.Statement.Run
import Rel8.Statement.Select
import Rel8.Statement.SQL
import Rel8.Statement.Update
@ -470,9 +482,17 @@ import Rel8.Window
-- $running
-- To run queries and otherwise interact with a PostgreSQL database, Rel8
-- provides 'select', 'insert', 'update' and 'delete' functions. Note that
-- 'insert', 'update' and 'delete' will generally need the
-- `DuplicateRecordFields` language extension enabled.
-- provides the @run@ functions. These produce a 'Hasql.Statement.Statement's
-- which can be passed to 'Hasql.Session.statement' to execute the statement
-- against a PostgreSQL 'Hasql.Connection.Connection'.
--
-- 'run' takes a 'Statement', which can be constructed using either 'select',
-- 'insert', 'update' or 'delete'. It decodes the rows returned by the
-- statement as a list of Haskell of values. See 'run_', 'runN', 'run1',
-- 'runMaybe' and 'runVector' for other variations.
--
-- Note that constructing an 'Insert', 'Update' or 'Delete' will require the
-- @DisambiguateRecordFields@ language extension to be enabled.
-- $adts
-- Algebraic data types can be modelled between Haskell and SQL.

8
src/Rel8/Query/SQL.hs
View File

@ -9,13 +9,19 @@ where
-- base
import Prelude
-- opaleye
import qualified Opaleye.Internal.Tag as Opaleye
-- rel8
import Rel8.Expr ( Expr )
import Rel8.Query ( Query )
import Rel8.Statement.Select ( ppSelect )
import Rel8.Table ( Table )
-- transformers
import Control.Monad.Trans.State.Strict (evalState)
-- | Convert a 'Query' to a 'String' containing a @SELECT@ statement.
showQuery :: Table Expr a => Query a -> String
showQuery = show . ppSelect
showQuery = show . (`evalState` Opaleye.start) . ppSelect

327
src/Rel8/Statement.hs Normal file
View File

@ -0,0 +1,327 @@
{-# language DeriveFunctor #-}
{-# language DerivingVia #-}
{-# language FlexibleContexts #-}
{-# language GADTs #-}
{-# language LambdaCase #-}
{-# language NamedFieldPuns #-}
{-# language RankNTypes #-}
{-# language RecordWildCards #-}
{-# language ScopedTypeVariables #-}
{-# language StandaloneKindSignatures #-}
{-# language TypeApplications #-}
module Rel8.Statement
( Statement
, statementReturning
, statementNoReturning
, ppDecodeStatement
)
where
-- base
import Control.Applicative (liftA2)
import Control.Monad (ap, liftM2)
import Data.Foldable (fold, toList)
import Data.Int (Int64)
import Data.Kind (Type)
import Data.List.NonEmpty (NonEmpty, intersperse)
import Data.Monoid (Endo (Endo))
import Prelude
-- hasql
import qualified Hasql.Decoders as Hasql
-- opaleye
import qualified Opaleye.Internal.Tag as Opaleye
-- pretty
import Text.PrettyPrint
( Doc
, (<+>)
, ($$)
, comma
, doubleQuotes
, hcat
, parens
, punctuate
, text
, vcat
)
-- rel8
import Rel8.Expr (Expr)
import Rel8.Expr.Bool (false)
import Rel8.Query (Query)
import Rel8.Query.Aggregate (countRows)
import Rel8.Query.Each (each)
import Rel8.Schema.Table (TableSchema (..))
import Rel8.Statement.Rows (Rows (..))
import Rel8.Table (Table)
import Rel8.Table.Cols (fromCols)
import Rel8.Table.Name (namesFromLabelsWithA, showNames)
import Rel8.Table.Serialize (parse)
-- semigroupoids
import Data.Functor.Apply (Apply, WrappedApplicative (..))
import Data.Functor.Bind (Bind, (>>-))
-- 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
, columns :: !(Maybe (NonEmpty String))
, doc :: !Doc
, returning :: !Returning
}
type Result :: Type -> Type
data Result a = Unmodified !a | Modified !a
instance Functor Result where
fmap f = \case
Unmodified a -> Modified (f a)
Modified a -> Modified (f a)
getResult :: Result a -> a
getResult = \case
Unmodified a -> a
Modified a -> a
type Returning :: Type
data Returning where
NoReturning :: Returning
Returning :: Query (Expr Int64) -> Returning
-- | 'Statement' represents a single PostgreSQL statement. Most commonly,
-- this is constructed using 'Rel8.select', 'Rel8.insert', 'Rel8.update'
-- or 'Rel8.delete'.
--
-- However, in addition to @SELECT@, @INSERT@, @UPDATE@ and @DELETE@,
-- PostgreSQL also supports compositions thereof via its statement-level
-- @WITH@ syntax (with some caveats). Each such \"sub-statement\" can
-- reference the results of previous sub-statements. 'Statement' provides a
-- 'Monad' instance that captures this \"binding\" pattern.
--
-- The caveat with this is that the [side-effects of these sub-statements
-- are not visible to other sub-statements](https://www.postgresql.org/docs/current/queries-with.html#QUERIES-WITH-MODIFYING);
-- only the explicit results of previous sub-statements (from @SELECT@s or
-- @RETURNING@ clauses) are visible. So, for example, an @INSERT@ into a table
-- followed immediately by a @SELECT@ therefrom will not return the inserted
-- rows. However, it is possible to return the inserted rows using
-- @RETURNING@, 'Rel8.unionAll'ing this with the result of a @SELECT@
-- from the same table will produce the desired result.
--
-- An example of where this can be useful is if you want to delete rows from
-- a table and simultaneously log their deletion in a log table.
--
-- @
-- deleteFoo :: (Foo Expr -> Expr Bool) -> Statement ()
-- deleteFoo predicate = do
-- foos <-
-- delete Delete
-- { from = fooSchema
-- , using = pure ()
-- , deleteWhere = \_ -> predicate
-- , returning = Returning id
-- }
-- insert Insert
-- { into = deletedFooSchema
-- , rows = do
-- Foo {..} <- foos
-- let
-- deletedAt = 'Rel8.Expr.Time.now'
-- pure DeletedFoo {..}
-- , onConflict = Abort
-- , returning = NoReturning
-- }
-- @
newtype Statement a =
Statement (WriterT (Endo [Binding]) (State Opaleye.Tag) (Result a))
deriving stock (Functor)
deriving (Apply) via WrappedApplicative Statement
instance Applicative Statement where
pure = Statement . pure . Modified
(<*>) = ap
liftA2 = liftM2
instance Bind Statement where
Statement m >>- f = Statement $ do
result <- m
case f (getResult result) of
Statement m' -> m'
instance Monad Statement where
(>>=) = (>>-)
statementNoReturning :: State Opaleye.Tag Doc -> Statement ()
statementNoReturning pp = Statement $ do
binding <- lift $ do
doc <- pp
tag <- Opaleye.fresh
let
relation = Opaleye.tagWith tag "statement"
columns = Nothing
returning = NoReturning
binding = Binding {..}
pure binding
tell (Endo (binding :))
pure $ Unmodified ()
statementReturning :: Table Expr a
=> State Opaleye.Tag Doc -> Statement (Query a)
statementReturning pp = Statement $ do
(binding, query) <- lift $ do
doc <- pp
tag <- Opaleye.fresh
let
relation = Opaleye.tagWith tag "statement"
symbol labels = do
subtag <- Opaleye.fresh
let
suffix = Opaleye.tagWith tag (Opaleye.tagWith subtag "")
pure $ take (63 - length suffix) label ++ suffix
where
label = fold (intersperse "/" labels)
names = namesFromLabelsWithA symbol `evalState` Opaleye.start
columns = Just $ showNames names
query =
fromCols <$> each
TableSchema
{ name = relation
, schema = Nothing
, columns = names
}
returning = Returning (countRows query)
binding = Binding {..}
pure (binding, query)
tell (Endo (binding :))
pure $ Unmodified query
ppDecodeStatement :: ()
=> (forall x. Table Expr x => Query x -> State Opaleye.Tag Doc)
-> Rows exprs a -> Statement exprs -> (Doc, Hasql.Result a)
ppDecodeStatement ppSelect rows (Statement m) = evalState go Opaleye.start
where
go = do
(result, Endo dlist) <- runWriterT m
let
bindings' = dlist []
case unsnoc bindings' of
Nothing -> case rows of
Void -> do
doc <- ppSelect (pure false)
pure (doc, Hasql.noResult)
RowsAffected -> do
doc <- ppSelect (pure false)
pure (doc, 0 <$ Hasql.noResult)
Single @exprs @a -> do
doc <- ppSelect (getResult result)
pure (doc, Hasql.singleRow (parse @exprs @a))
Maybe @exprs @a -> do
doc <- ppSelect (getResult result)
pure (doc, Hasql.rowMaybe (parse @exprs @a))
List @exprs @a -> do
doc <- ppSelect (getResult result)
pure (doc, Hasql.rowList (parse @exprs @a))
Vector @exprs @a -> do
doc <- ppSelect (getResult result)
pure (doc, Hasql.rowVector (parse @exprs @a))
Just (bindings, binding@Binding {doc = after}) -> case rows of
Void -> pure (doc, Hasql.noResult)
where
doc = ppWith bindings after
RowsAffected -> do
case result of
Unmodified _ -> pure (doc, Hasql.rowsAffected)
where
doc = ppWith bindings after
Modified _ -> case returning binding of
NoReturning -> pure (doc, Hasql.rowsAffected)
where
doc = ppWith bindings after
Returning query -> do
doc <- ppWith bindings' <$> ppSelect query
pure (doc, Hasql.singleRow parse)
Single @exprs @a -> do
case result of
Unmodified _ -> pure (doc, Hasql.singleRow (parse @exprs @a))
where
doc = ppWith bindings after
Modified query -> do
doc <- ppWith bindings' <$> ppSelect query
pure (doc, Hasql.singleRow (parse @exprs @a))
Maybe @exprs @a -> do
case result of
Unmodified _ -> pure (doc, Hasql.rowMaybe (parse @exprs @a))
where
doc = ppWith bindings after
Modified query -> do
doc <- ppWith bindings' <$> ppSelect query
pure (doc, Hasql.rowMaybe (parse @exprs @a))
List @exprs @a -> do
case result of
Unmodified _ -> pure (doc, Hasql.rowList (parse @exprs @a))
where
doc = ppWith bindings after
Modified query -> do
doc <- ppWith bindings' <$> ppSelect query
pure (doc, Hasql.rowList (parse @exprs @a))
Vector @exprs @a -> do
case result of
Unmodified _ -> pure (doc, Hasql.rowVector (parse @exprs @a))
where
doc = ppWith bindings after
Modified query -> do
doc <- ppWith bindings' <$> ppSelect query
pure (doc, Hasql.rowVector (parse @exprs @a))
ppWith :: [Binding] -> Doc -> Doc
ppWith bindings after = pre $$ after
where
pre = case bindings of
[] -> mempty
_ ->
text "WITH" <+>
vcat (punctuate comma (map go bindings))
go binding@Binding {doc = before} =
ppAlias binding $$
text "AS" <+>
parens before
ppAlias :: Binding -> Doc
ppAlias Binding {relation, columns = mcolumns} = case mcolumns of
Nothing -> escape relation
Just columns ->
escape relation <+>
parens (hcat (punctuate comma (escape <$> toList columns)))
escape :: String -> Doc
escape = doubleQuotes . text . concatMap go
where
go = \case
'"' -> "\"\""
c -> [c]
unsnoc :: [a] -> Maybe ([a], a)
unsnoc = foldr (\x -> Just . maybe ([], x) (\(~(a, b)) -> (x : a, b))) Nothing

51
src/Rel8/Statement/Delete.hs
View File

@ -1,7 +1,7 @@
{-# language DuplicateRecordFields #-}
{-# language FlexibleContexts #-}
{-# language GADTs #-}
{-# language NamedFieldPuns #-}
{-# language RankNTypes #-}
{-# language RecordWildCards #-}
{-# language StandaloneKindSignatures #-}
{-# language StrictData #-}
@ -17,9 +17,8 @@ where
import Data.Kind ( Type )
import Prelude
-- hasql
import qualified Hasql.Encoders as Hasql
import qualified Hasql.Statement as Hasql
-- opaleye
import qualified Opaleye.Internal.Tag as Opaleye
-- pretty
import Text.PrettyPrint ( Doc, (<+>), ($$), text )
@ -29,13 +28,13 @@ 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, ppReturning )
import Rel8.Statement (Statement)
import Rel8.Statement.Returning (Returning, ppReturning, runReturning)
import Rel8.Statement.Using ( ppUsing )
import Rel8.Statement.Where ( ppWhere )
-- text
import qualified Data.Text as Text
import Data.Text.Encoding ( encodeUtf8 )
-- transformers
import Control.Monad.Trans.State.Strict (State)
-- | The constituent parts of a @DELETE@ statement.
@ -55,25 +54,21 @@ data Delete a where
-> Delete a
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
-- | Build a @DELETE@ 'Statement'.
delete :: Delete a -> Statement a
delete statement@Delete {returning} =
runReturning (ppDelete statement) returning
-- | Run a 'Delete' statement.
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
ppDelete :: Delete a -> State Opaleye.Tag Doc
ppDelete Delete {..} = do
musing <- ppUsing using
pure $ case musing 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

47
src/Rel8/Statement/Insert.hs
View File

@ -19,12 +19,9 @@ import Data.Foldable ( toList )
import Data.Kind ( Type )
import Prelude
-- hasql
import qualified Hasql.Encoders as Hasql
import qualified Hasql.Statement as Hasql
-- opaleye
import qualified Opaleye.Internal.HaskellDB.Sql.Print as Opaleye
import qualified Opaleye.Internal.Tag as Opaleye
-- pretty
import Text.PrettyPrint ( Doc, (<+>), ($$), parens, text )
@ -33,15 +30,15 @@ import Text.PrettyPrint ( Doc, (<+>), ($$), parens, text )
import Rel8.Query ( Query )
import Rel8.Schema.Name ( Name, Selects, ppColumn )
import Rel8.Schema.Table ( TableSchema(..), ppTable )
import Rel8.Statement (Statement)
import Rel8.Statement.OnConflict ( OnConflict, ppOnConflict )
import Rel8.Statement.Returning ( Returning, decodeReturning, ppReturning )
import Rel8.Statement.Returning (Returning, ppReturning, runReturning)
import Rel8.Statement.Select ( ppRows )
import Rel8.Table ( Table )
import Rel8.Table.Name ( showNames )
-- text
import qualified Data.Text as Text ( pack )
import Data.Text.Encoding ( encodeUtf8 )
-- transformers
import Control.Monad.Trans.State.Strict (State)
-- | The constituent parts of a SQL @INSERT@ statement.
@ -62,28 +59,24 @@ data Insert a where
-> Insert a
ppInsert :: Insert a -> Doc
ppInsert Insert {..} =
text "INSERT INTO" <+>
ppInto into $$
ppRows rows $$
ppOnConflict into onConflict $$
ppReturning into returning
-- | Build an @INSERT@ 'Statement'.
insert :: Insert a -> Statement a
insert statement@Insert {returning} =
runReturning (ppInsert statement) returning
ppInsert :: Insert a -> State Opaleye.Tag Doc
ppInsert Insert {..} = do
rows' <- ppRows rows
pure $
text "INSERT INTO" <+>
ppInto into $$
rows' $$
ppOnConflict into onConflict $$
ppReturning into returning
ppInto :: Table Name a => TableSchema a -> Doc
ppInto table@TableSchema {columns} =
ppTable table <+>
parens (Opaleye.commaV ppColumn (toList (showNames columns)))
-- | Run an 'Insert' statement.
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

104
src/Rel8/Statement/Returning.hs
View File

@ -1,3 +1,5 @@
{-# language DataKinds #-}
{-# language FlexibleContexts #-}
{-# language GADTs #-}
{-# language LambdaCase #-}
{-# language NamedFieldPuns #-}
@ -8,120 +10,68 @@
{-# language TypeApplications #-}
module Rel8.Statement.Returning
( Returning( NumberOfRowsAffected, Projection )
, decodeReturning
( Returning( NoReturning, Returning )
, runReturning
, ppReturning
)
where
-- base
import Control.Applicative ( liftA2 )
import Data.Foldable ( toList )
import Data.Int ( Int64 )
import Data.Kind ( Type )
import Data.List.NonEmpty ( NonEmpty )
import Prelude
-- hasql
import qualified Hasql.Decoders as Hasql
-- opaleye
import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
import qualified Opaleye.Internal.HaskellDB.Sql.Print as Opaleye
import qualified Opaleye.Internal.Sql as Opaleye
import qualified Opaleye.Internal.Tag as Opaleye
-- pretty
import Text.PrettyPrint ( Doc, (<+>), text )
-- rel8
import Rel8.Expr (Expr)
import Rel8.Query (Query)
import Rel8.Schema.Name ( Selects )
import Rel8.Schema.Table ( TableSchema(..) )
import Rel8.Statement (Statement, statementNoReturning, statementReturning)
import Rel8.Table (Table)
import Rel8.Table.Opaleye ( castTable, exprs, view )
import Rel8.Table.Serialize ( Serializable, parse )
-- semigropuoids
import Data.Functor.Apply ( Apply, (<.>) )
-- transformers
import Control.Monad.Trans.State.Strict (State)
-- | 'Rel8.Insert', 'Rel8.Update' and 'Rel8.Delete' all support returning either
-- the number of rows affected, or the actual rows modified.
-- | 'Rel8.Insert', 'Rel8.Update' and 'Rel8.Delete' all support an optional
-- @RETURNING@ clause.
type Returning :: Type -> Type -> Type
data Returning names a where
Pure :: a -> Returning names a
Ap :: Returning names (a -> b) -> Returning names a -> Returning names b
-- | No @RETURNING@ clause
NoReturning :: Returning names ()
-- | Return the number of rows affected.
NumberOfRowsAffected :: Returning names Int64
-- | 'Projection' allows you to project out of the affected rows, which can
-- | 'Returning' allows you to project out of the affected rows, which can
-- be useful if you want to log exactly which rows were deleted, or to view
-- a generated id (for example, if using a column with an autoincrementing
-- counter via 'Rel8.nextval').
Projection :: (Selects names exprs, Serializable returning a)
=> (exprs -> returning)
-> Returning names [a]
instance Functor (Returning names) where
fmap f = \case
Pure a -> Pure (f a)
Ap g a -> Ap (fmap (f .) g) a
m -> Ap (Pure f) m
instance Apply (Returning names) where
(<.>) = Ap
instance Applicative (Returning names) where
pure = Pure
(<*>) = Ap
Returning :: (Selects names exprs, Table Expr a) => (exprs -> a) -> Returning names (Query a)
projections :: ()
=> TableSchema names -> Returning names a -> Maybe (NonEmpty Opaleye.PrimExpr)
projections schema@TableSchema {columns} = \case
Pure _ -> Nothing
Ap f a -> projections schema f <> projections schema a
NumberOfRowsAffected -> Nothing
Projection f -> Just (exprs (castTable (f (view columns))))
projections TableSchema {columns} = \case
NoReturning -> Nothing
Returning f -> Just (exprs (castTable (f (view columns))))
runReturning :: ()
=> ((Int64 -> a) -> r)
-> (forall x. Hasql.Row x -> ([x] -> a) -> r)
-> Returning names a
-> r
runReturning rowCount rowList = \case
Pure a -> rowCount (const a)
Ap fs as ->
runReturning
(\withCount ->
runReturning
(\withCount' -> rowCount (withCount <*> withCount'))
(\decoder -> rowList decoder . liftA2 withCount length64)
as)
(\decoder withRows ->
runReturning
(\withCount -> rowList decoder $ withRows <*> withCount . length64)
(\decoder' withRows' ->
rowList (liftA2 (,) decoder decoder') $
withRows <$> fmap fst <*> withRows' . fmap snd)
as)
fs
NumberOfRowsAffected -> rowCount id
Projection (_ :: exprs -> returning) -> rowList decoder' id
where
decoder' = parse @returning
where
length64 :: Foldable f => f x -> Int64
length64 = fromIntegral . length
decodeReturning :: Returning names a -> Hasql.Result a
decodeReturning = runReturning
(<$> Hasql.rowsAffected)
(\decoder withRows -> withRows <$> Hasql.rowList decoder)
runReturning ::
State Opaleye.Tag Doc ->
Returning names a ->
Statement a
runReturning pp = \case
NoReturning -> statementNoReturning pp
Returning _ -> statementReturning pp
ppReturning :: TableSchema names -> Returning names a -> Doc

30
src/Rel8/Statement/Rows.hs Normal file
View File

@ -0,0 +1,30 @@
{-# language DataKinds #-}
{-# language GADTs #-}
{-# language StandaloneKindSignatures #-}
module Rel8.Statement.Rows
( Rows (..)
)
where
-- base
import Data.Int (Int64)
import Data.Kind (Type)
import Prelude
-- rel8
import Rel8.Query (Query)
import Rel8.Table.Serialize (Serializable)
-- vector
import Data.Vector (Vector)
type Rows :: Type -> Type -> Type
data Rows returning result where
Void :: Rows returning ()
RowsAffected :: Rows () Int64
Single :: Serializable exprs a => Rows (Query exprs) a
Maybe :: Serializable exprs a => Rows (Query exprs) (Maybe a)
List :: Serializable exprs a => Rows (Query exprs) [a]
Vector :: Serializable exprs a => Rows (Query exprs) (Vector a)

84
src/Rel8/Statement/Run.hs Normal file
View File

@ -0,0 +1,84 @@
module Rel8.Statement.Run
( run_
, runN
, run1
, runMaybe
, run
, runVector
)
where
-- base
import Data.Int (Int64)
import Prelude
-- hasql
import qualified Hasql.Encoders as Hasql
import qualified Hasql.Statement as Hasql
-- rel8
import Rel8.Query (Query)
import Rel8.Statement (Statement, ppDecodeStatement)
import Rel8.Statement.Rows (Rows (..))
import Rel8.Statement.Select (ppSelect)
import Rel8.Table.Serialize (Serializable)
-- text
import qualified Data.Text as Text
import Data.Text.Encoding (encodeUtf8)
-- vector
import Data.Vector (Vector)
makeRun :: Rows exprs a -> Statement exprs -> Hasql.Statement () a
makeRun rows statement = Hasql.Statement bytes params decode prepare
where
bytes = encodeUtf8 $ Text.pack sql
params = Hasql.noParams
prepare = False
sql = show doc
(doc, decode) = ppDecodeStatement ppSelect rows statement
-- | Convert a 'Statement' to a runnable 'Hasql.Statement', disregarding the
-- results of that statement (if any).
run_ :: Statement exprs -> Hasql.Statement () ()
run_ = makeRun Void
-- | Convert a 'Statement' to a 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').
runN :: Statement () -> Hasql.Statement () Int64
runN = makeRun RowsAffected
-- | Convert a 'Statement' to a 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 runtime exception is thrown.
run1 :: Serializable exprs
a=> Statement (Query exprs) -> Hasql.Statement () a
run1 = makeRun Single
-- | Convert a 'Statement' to a 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 runtime exception is thrown.
runMaybe :: Serializable exprs
a=> Statement (Query exprs) -> Hasql.Statement () (Maybe a)
runMaybe = makeRun Maybe
-- | Convert a 'Statement' to a runnable 'Hasql.Statement', processing the
-- result of the statement as a list of rows.
run :: Serializable exprs a
=> Statement (Query exprs) -> Hasql.Statement () [a]
run = makeRun List
-- | Convert a 'Statement' to a runnable 'Hasql.Statement', processing the
-- result of the statement as a 'Vector' of rows.
runVector :: Serializable exprs a
=> Statement (Query exprs) -> Hasql.Statement () (Vector a)
runVector = makeRun Vector

21
src/Rel8/Statement/SQL.hs
View File

@ -2,28 +2,43 @@ module Rel8.Statement.SQL
( showDelete
, showInsert
, showUpdate
, showStatement
)
where
-- base
import Prelude
-- opaleye
import qualified Opaleye.Internal.Tag as Opaleye
-- rel8
import Rel8.Statement (Statement, ppDecodeStatement)
import Rel8.Statement.Delete ( Delete, ppDelete )
import Rel8.Statement.Insert ( Insert, ppInsert )
import Rel8.Statement.Rows (Rows (Void))
import Rel8.Statement.Select (ppSelect)
import Rel8.Statement.Update ( Update, ppUpdate )
-- transformers
import Control.Monad.Trans.State.Strict (evalState)
-- | Convert a 'Delete' to a 'String' containing a @DELETE@ statement.
showDelete :: Delete a -> String
showDelete = show . ppDelete
showDelete = show . (`evalState` Opaleye.start) . ppDelete
-- | Convert an 'Insert' to a 'String' containing an @INSERT@ statement.
showInsert :: Insert a -> String
showInsert = show . ppInsert
showInsert = show . (`evalState` Opaleye.start) . ppInsert
-- | Convert an 'Update' to a 'String' containing an @UPDATE@ statement.
showUpdate :: Update a -> String
showUpdate = show . ppUpdate
showUpdate = show . (`evalState` Opaleye.start) . ppUpdate
-- | Convert a 'Statement' to a 'String' containing an SQL statement.
showStatement :: Statement a -> String
showStatement = show . fst . ppDecodeStatement ppSelect Void

55
src/Rel8/Statement/Select.hs
View File

@ -1,3 +1,4 @@
{-# language DataKinds #-}
{-# language DeriveTraversable #-}
{-# language DerivingStrategies #-}
{-# language FlexibleContexts #-}
@ -9,7 +10,6 @@
module Rel8.Statement.Select
( select
, ppSelect
, Optimized(..)
, ppPrimSelect
, ppRows
@ -22,11 +22,6 @@ import Data.Kind ( Type )
import Data.Void ( Void )
import Prelude hiding ( undefined )
-- hasql
import qualified Hasql.Decoders as Hasql
import qualified Hasql.Encoders as Hasql
import qualified Hasql.Statement as Hasql
-- opaleye
import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
import qualified Opaleye.Internal.HaskellDB.Sql as Opaleye
@ -48,52 +43,43 @@ import Rel8.Expr.Opaleye ( toPrimExpr )
import Rel8.Query ( Query )
import Rel8.Query.Opaleye ( toOpaleye )
import Rel8.Schema.Name ( Selects )
import Rel8.Statement (Statement, statementReturning)
import Rel8.Table ( Table )
import Rel8.Table.Cols ( toCols )
import Rel8.Table.Name ( namesFromLabels )
import Rel8.Table.Opaleye ( castTable, exprsWithNames )
import qualified Rel8.Table.Opaleye as T
import Rel8.Table.Serialize ( Serializable, parse )
import Rel8.Table.Undefined ( undefined )
-- text
import qualified Data.Text as Text
import Data.Text.Encoding ( encodeUtf8 )
-- transformers
import Control.Monad.Trans.State.Strict (State)
-- | Run a @SELECT@ statement, returning all rows.
select :: forall exprs a. Serializable exprs a
=> 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
-- | Build a @SELECT@ 'Statement'.
select :: Table Expr a => Query a -> Statement (Query a)
select query = statementReturning (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) ()
ppSelect :: Table Expr a => Query a -> State Opaleye.Tag Doc
ppSelect query = do
(exprs, primQuery) <- Opaleye.runSimpleSelect (toOpaleye query)
let
(exprs', primQuery') = case optimize primQuery of
Empty -> (undefined, Opaleye.Product (pure (pure Opaleye.Unit)) never)
Unit -> (exprs, Opaleye.Unit)
Optimized pq -> (exprs, pq)
pure $ Opaleye.ppSql $ primSelectWith names (toCols exprs') primQuery'
where
names = namesFromLabels
never = pure (toPrimExpr false)
ppRows :: Table Expr a => Query a -> Doc
ppRows :: Table Expr a => Query a -> State Opaleye.Tag Doc
ppRows query = case optimize primQuery of
-- Special case VALUES because we can't use DEFAULT inside a SELECT
Optimized (Opaleye.Values symbols rows)
| eqSymbols symbols (toList (T.exprs a)) ->
Opaleye.ppValues_ (map Opaleye.sqlExpr <$> toList rows)
pure $ Opaleye.ppValues_ (map Opaleye.sqlExpr <$> toList rows)
_ -> ppSelect query
where
(a, primQuery, _) = Opaleye.runSimpleQueryArrStart (toOpaleye query) ()
@ -110,11 +96,10 @@ ppRows query = case optimize primQuery of
= name == name' && tag == tag'
ppPrimSelect :: Query a -> (Optimized Doc, a)
ppPrimSelect query =
(Opaleye.ppSql . primSelect <$> optimize primQuery, a)
where
(a, primQuery, _) = Opaleye.runSimpleQueryArrStart (toOpaleye query) ()
ppPrimSelect :: Query a -> State Opaleye.Tag (Optimized Doc, a)
ppPrimSelect query = do
(a, primQuery) <- Opaleye.runSimpleSelect (toOpaleye query)
pure $ (Opaleye.ppSql . primSelect <$> optimize primQuery, a)
type Optimized :: Type -> Type

54
src/Rel8/Statement/Update.hs
View File

@ -1,4 +1,5 @@
{-# language DuplicateRecordFields #-}
{-# language FlexibleContexts #-}
{-# language GADTs #-}
{-# language NamedFieldPuns #-}
{-# language RecordWildCards #-}
@ -16,9 +17,8 @@ where
import Data.Kind ( Type )
import Prelude
-- hasql
import qualified Hasql.Encoders as Hasql
import qualified Hasql.Statement as Hasql
-- opaleye
import qualified Opaleye.Internal.Tag as Opaleye
-- pretty
import Text.PrettyPrint ( Doc, (<+>), ($$), text )
@ -28,14 +28,14 @@ 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, ppReturning )
import Rel8.Statement (Statement)
import Rel8.Statement.Returning (Returning, ppReturning, runReturning)
import Rel8.Statement.Set ( ppSet )
import Rel8.Statement.Using ( ppFrom )
import Rel8.Statement.Where ( ppWhere )
-- text
import qualified Data.Text as Text
import Data.Text.Encoding ( encodeUtf8 )
-- transformers
import Control.Monad.Trans.State.Strict (State)
-- | The constituent parts of an @UPDATE@ statement.
@ -57,27 +57,23 @@ data Update a where
-> Update a
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
-- | Build an @UPDATE@ 'Statement'.
update :: Update a -> Statement a
update statement@Update {returning} =
runReturning (ppUpdate statement) returning
-- | Run an @UPDATE@ statement.
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
ppUpdate :: Update a -> State Opaleye.Tag Doc
ppUpdate Update {..} = do
mfrom <- ppFrom from
pure $ case mfrom 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

25
src/Rel8/Statement/Using.hs
View File

@ -7,6 +7,9 @@ where
-- base
import Prelude
-- opaleye
import qualified Opaleye.Internal.Tag as Opaleye
-- pretty
import Text.PrettyPrint ( Doc, (<+>), parens, text )
@ -15,22 +18,26 @@ import Rel8.Query ( Query )
import Rel8.Schema.Table ( TableSchema(..), ppTable )
import Rel8.Statement.Select ( Optimized(..), ppPrimSelect )
-- transformers
import Control.Monad.Trans.State.Strict (State)
ppFrom :: Query a -> Maybe (Doc, a)
ppFrom :: Query a -> State Opaleye.Tag (Maybe (Doc, a))
ppFrom = ppJoin "FROM"
ppUsing :: Query a -> Maybe (Doc, a)
ppUsing :: Query a -> State Opaleye.Tag (Maybe (Doc, a))
ppUsing = ppJoin "USING"
ppJoin :: String -> Query a -> Maybe (Doc, a)
ppJoin :: String -> Query a -> State Opaleye.Tag (Maybe (Doc, a))
ppJoin clause join = do
doc <- case ofrom of
Empty -> Nothing
Unit -> Just mempty
Optimized doc -> Just $ text clause <+> parens doc <+> ppTable alias
pure (doc, a)
(ofrom, a) <- ppPrimSelect join
pure $ do
doc <- case ofrom of
Empty -> Nothing
Unit -> Just mempty
Optimized doc -> Just $ text clause <+> parens doc <+> ppTable alias
pure (doc, a)
where
alias = TableSchema {name = "T1", schema = Nothing, columns = ()}
(ofrom, a) = ppPrimSelect join

14
src/Rel8/Statement/View.hs
View File

@ -15,6 +15,12 @@ import qualified Hasql.Decoders as Hasql
import qualified Hasql.Encoders as Hasql
import qualified Hasql.Statement as Hasql
-- opaleye
import qualified Opaleye.Internal.Tag as Opaleye
-- pretty
import Text.PrettyPrint ( Doc, (<+>), ($$), text )
-- rel8
import Rel8.Query ( Query )
import Rel8.Schema.Name ( Selects )
@ -22,13 +28,13 @@ import Rel8.Schema.Table ( TableSchema )
import Rel8.Statement.Insert ( ppInto )
import Rel8.Statement.Select ( ppSelect )
-- pretty
import Text.PrettyPrint ( Doc, (<+>), ($$), text )
-- text
import qualified Data.Text as Text
import Data.Text.Encoding ( encodeUtf8 )
-- transformers
import Control.Monad.Trans.State.Strict (evalState)
data CreateView = Create | CreateOrReplace
@ -72,7 +78,7 @@ ppCreateView schema query replace =
createOrReplace replace <+>
ppInto schema $$
text "AS" <+>
ppSelect query
evalState (ppSelect query) Opaleye.start
where
createOrReplace Create = text "CREATE VIEW"
createOrReplace CreateOrReplace = text "CREATE OR REPLACE VIEW"

16
src/Rel8/Table/Name.hs
View File

@ -12,6 +12,7 @@
module Rel8.Table.Name
( namesFromLabels
, namesFromLabelsWith
, namesFromLabelsWithA
, showLabels
, showNames
)
@ -20,16 +21,20 @@ where
-- base
import Data.Foldable ( fold )
import Data.Functor.Const ( Const( Const ), getConst )
import Data.Functor.Identity (runIdentity)
import Data.List.NonEmpty ( NonEmpty, intersperse, nonEmpty )
import Data.Maybe ( fromMaybe )
import Prelude
-- rel8
import Rel8.Schema.HTable ( htabulate, htabulateA, hfield, hspecs )
import Rel8.Schema.HTable (htabulateA, hfield, hspecs)
import Rel8.Schema.Name ( Name( Name ) )
import Rel8.Schema.Spec ( Spec(..) )
import Rel8.Table ( Table(..) )
-- semigroupoids
import Data.Functor.Apply (Apply)
-- | Construct a table in the 'Name' context containing the names of all
-- columns. Nested column names will be combined with @/@.
@ -58,9 +63,14 @@ namesFromLabels = namesFromLabelsWith go
-- to the name of the Haskell field.
namesFromLabelsWith :: Table Name a
=> (NonEmpty String -> String) -> a
namesFromLabelsWith f = fromColumns $ htabulate $ \field ->
namesFromLabelsWith = runIdentity . namesFromLabelsWithA . (pure .)
namesFromLabelsWithA :: (Apply f, Table Name a)
=> (NonEmpty String -> f String) -> f a
namesFromLabelsWithA f = fmap fromColumns $ htabulateA $ \field ->
case hfield hspecs field of
Spec {labels} -> Name (f (renderLabels labels))
Spec {labels} -> Name <$> f (renderLabels labels)
showLabels :: forall a. Table (Context a) a => a -> [NonEmpty String]

213
tests/Main.hs
View File

@ -21,16 +21,18 @@ where
-- base
import Control.Applicative ( empty, liftA2, liftA3 )
import Control.Exception ( bracket, throwIO )
import Control.Monad ( (>=>), void )
import Control.Monad ((>=>))
import Data.Bifunctor ( bimap )
import Data.Fixed (Fixed (MkFixed))
import Data.Foldable ( for_ )
import Data.Functor (void)
import Data.Int ( Int32, Int64 )
import Data.List ( nub, sort )
import Data.Maybe ( catMaybes )
import Data.String ( fromString )
import Data.Word (Word32, Word8)
import GHC.Generics ( Generic )
import Prelude hiding (truncate)
-- bytestring
import qualified Data.ByteString.Lazy
@ -102,6 +104,7 @@ tests =
withResource startTestDatabase stopTestDatabase \getTestDatabase ->
testGroup "rel8"
[ testSelectTestTable getTestDatabase
, testWithStatement getTestDatabase
, testWhere_ getTestDatabase
, testFilter getTestDatabase
, testLimit getTestDatabase
@ -200,14 +203,14 @@ testSelectTestTable = databasePropertyTest "Can SELECT TestTable" \transaction -
transaction do
selected <- lift do
statement () $ Rel8.insert Rel8.Insert
statement () $ Rel8.run_ $ Rel8.insert Rel8.Insert
{ into = testTableSchema
, rows = Rel8.values $ map Rel8.lit rows
, onConflict = Rel8.DoNothing
, returning = pure ()
, returning = Rel8.NoReturning
}
statement () $ Rel8.select do
statement () $ Rel8.run $ Rel8.select do
Rel8.each testTableSchema
sort selected === sort rows
@ -227,7 +230,7 @@ testWhere_ = databasePropertyTest "WHERE (Rel8.where_)" \transaction -> do
transaction do
selected <- lift do
statement () $ Rel8.select do
statement () $ Rel8.run $ Rel8.select do
t <- Rel8.values $ Rel8.lit <$> rows
Rel8.where_ $ testTableColumn2 t Rel8.==. Rel8.lit magicBool
return t
@ -247,7 +250,7 @@ testFilter = databasePropertyTest "filter" \transaction -> do
let expected = filter testTableColumn2 rows
selected <- lift do
statement () $ Rel8.select do
statement () $ Rel8.run $ Rel8.select do
Rel8.filter testTableColumn2 =<< Rel8.values (Rel8.lit <$> rows)
sort selected === sort expected
@ -265,7 +268,7 @@ testLimit = databasePropertyTest "LIMIT (Rel8.limit)" \transaction -> do
transaction do
selected <- lift do
statement () $ Rel8.select do
statement () $ Rel8.run $ Rel8.select do
Rel8.limit n $ Rel8.values (Rel8.lit <$> rows)
diff (length selected) (<=) (fromIntegral n)
@ -286,7 +289,7 @@ testUnion = databasePropertyTest "UNION (Rel8.union)" \transaction -> evalM do
transaction do
selected <- lift do
statement () $ Rel8.select do
statement () $ Rel8.run $ Rel8.select do
Rel8.values (Rel8.lit <$> nub left) `Rel8.union` Rel8.values (Rel8.lit <$> nub right)
sort selected === sort (nub (left ++ right))
@ -298,7 +301,7 @@ testDistinct = databasePropertyTest "DISTINCT (Rel8.distinct)" \transaction -> d
transaction do
selected <- lift do
statement () $ Rel8.select do
statement () $ Rel8.run $ Rel8.select do
Rel8.distinct do
Rel8.values (Rel8.lit <$> rows)
@ -315,12 +318,12 @@ testExists = databasePropertyTest "EXISTS (Rel8.exists)" \transaction -> do
transaction do
exists <- lift do
statement () $ Rel8.select do
statement () $ Rel8.run1 $ Rel8.select do
Rel8.exists $ Rel8.values $ Rel8.lit <$> rows
case rows of
[] -> exists === [False]
_ -> exists === [True]
[] -> exists === False
_ -> exists === True
testOptional :: IO TmpPostgres.DB -> TestTree
@ -329,7 +332,7 @@ testOptional = databasePropertyTest "Rel8.optional" \transaction -> do
transaction do
selected <- lift do
statement () $ Rel8.select do
statement () $ Rel8.run $ Rel8.select do
Rel8.optional $ Rel8.values (Rel8.lit <$> rows)
case rows of
@ -342,8 +345,8 @@ testAnd = databasePropertyTest "AND (&&.)" \transaction -> do
(x, y) <- forAll $ liftA2 (,) Gen.bool Gen.bool
transaction do
[result] <- lift do
statement () $ Rel8.select do
result <- lift do
statement () $ Rel8.run1 $ Rel8.select do
pure $ Rel8.lit x Rel8.&&. Rel8.lit y
result === (x && y)
@ -354,8 +357,8 @@ testOr = databasePropertyTest "OR (||.)" \transaction -> do
(x, y) <- forAll $ liftA2 (,) Gen.bool Gen.bool
transaction do
[result] <- lift do
statement () $ Rel8.select $ pure $
result <- lift do
statement () $ Rel8.run1 $ Rel8.select $ pure $
Rel8.lit x Rel8.||. Rel8.lit y
result === (x || y)
@ -366,8 +369,8 @@ testLogicalFixities = databasePropertyTest "Logical operator fixities" \transact
(u, v, w, x) <- forAll $ (,,,) <$> Gen.bool <*> Gen.bool <*> Gen.bool <*> Gen.bool
transaction do
[result] <- lift do
statement () $ Rel8.select do
result <- lift do
statement () $ Rel8.run1 $ Rel8.select do
pure $ Rel8.lit u Rel8.||. Rel8.lit v Rel8.&&. Rel8.lit w Rel8.==. Rel8.lit x
result === (u || v && w == x)
@ -378,8 +381,8 @@ testNot = databasePropertyTest "NOT (not_)" \transaction -> do
x <- forAll Gen.bool
transaction do
[result] <- lift do
statement () $ Rel8.select do
result <- lift do
statement () $ Rel8.run1 $ Rel8.select do
pure $ Rel8.not_ $ Rel8.lit x
result === not x
@ -390,8 +393,8 @@ testBool = databasePropertyTest "ifThenElse_" \transaction -> do
(x, y, z) <- forAll $ liftA3 (,,) Gen.bool Gen.bool Gen.bool
transaction do
[result] <- lift do
statement () $ Rel8.select do
result <- lift do
statement () $ Rel8.run1 $ Rel8.select do
pure $ Rel8.bool (Rel8.lit z) (Rel8.lit y) (Rel8.lit x)
result === if x then y else z
@ -406,7 +409,7 @@ testAp = databasePropertyTest "Cartesian product (<*>)" \transaction -> do
transaction do
result <- lift do
statement () $ Rel8.select do
statement () $ Rel8.run $ Rel8.select do
liftA2 (,) (Rel8.values (Rel8.lit <$> rows1)) (Rel8.values (Rel8.lit <$> rows2))
sort result === sort (liftA2 (,) rows1 rows2)
@ -417,7 +420,7 @@ data Composite = Composite
, char :: !Char
, array :: ![Int32]
}
deriving (Eq, Show, Generic)
deriving stock (Eq, Show, Generic)
deriving (Rel8.DBType) via Rel8.Composite Composite
@ -466,26 +469,26 @@ testDBType getTestDatabase = testGroup "DBType instances"
y <- forAll generator
transaction do
[res] <- lift do
statement () $ Rel8.select do
res <- lift do
statement () $ Rel8.run1 $ Rel8.select do
pure (Rel8.litExpr x)
diff res (==) x
[res'] <- lift do
statement () $ Rel8.select $ Rel8.many $ Rel8.many do
res' <- lift do
statement () $ Rel8.run1 $ Rel8.select $ Rel8.many $ Rel8.many do
Rel8.values [Rel8.litExpr x, Rel8.litExpr y]
diff res' (==) [[x, y]]
[res3] <- lift do
statement () $ Rel8.select $ Rel8.many $ Rel8.many $ Rel8.many do
res3 <- lift do
statement () $ Rel8.run1 $ Rel8.select $ Rel8.many $ Rel8.many $ Rel8.many do
Rel8.values [Rel8.litExpr x, Rel8.litExpr y]
diff res3 (==) [[[x, y]]]
res'' <- lift do
statement () $ Rel8.select do
statement () $ Rel8.run $ Rel8.select do
xs <- Rel8.catListTable (Rel8.listTable [Rel8.listTable [Rel8.litExpr x, Rel8.litExpr y]])
Rel8.catListTable xs
diff res'' (==) [x, y]
{-
res''' <- lift do
statement () $ Rel8.select do
statement () $ Rel8.run $ Rel8.select do
xss <- Rel8.catListTable (Rel8.listTable [Rel8.listTable [Rel8.listTable [Rel8.litExpr x, Rel8.litExpr y]]])
xs <- Rel8.catListTable xss
Rel8.catListTable xs
@ -573,8 +576,8 @@ testDBEq getTestDatabase = testGroup "DBEq instances"
(x, y) <- forAll (liftA2 (,) generator generator)
transaction do
[res] <- lift do
statement () $ Rel8.select do
res <- lift do
statement () $ Rel8.run1 $ Rel8.select do
pure $ Rel8.litExpr x Rel8.==. Rel8.litExpr y
res === (x == y)
@ -584,8 +587,8 @@ testTableEquality = databasePropertyTest "TestTable equality" \transaction -> do
(x, y) <- forAll $ liftA2 (,) genTestTable genTestTable
transaction do
[eq] <- lift do
statement () $ Rel8.select do
eq <- lift do
statement () $ Rel8.run1 $ Rel8.select do
pure $ Rel8.lit x Rel8.==: Rel8.lit y
eq === (x == y)
@ -596,8 +599,8 @@ testFromString = databasePropertyTest "FromString" \transaction -> do
str <- forAll $ Gen.list (Range.linear 0 10) Gen.unicode
transaction do
[result] <- lift do
statement () $ Rel8.select do
result <- lift do
statement () $ Rel8.run1 $ Rel8.select do
pure $ fromString str
result === pack str
@ -608,7 +611,7 @@ testCatMaybeTable = databasePropertyTest "catMaybeTable" \transaction -> do
transaction do
selected <- lift do
statement () $ Rel8.select do
statement () $ Rel8.run $ Rel8.select do
testTable <- Rel8.values $ Rel8.lit <$> rows
Rel8.catMaybeTable $ Rel8.bool Rel8.nothingTable (pure testTable) (testTableColumn2 testTable)
@ -621,7 +624,7 @@ testCatMaybe = databasePropertyTest "catMaybe" \transaction -> evalM do
transaction do
selected <- lift do
statement () $ Rel8.select do
statement () $ Rel8.run $ Rel8.select do
Rel8.catNull =<< Rel8.values (map Rel8.lit rows)
sort selected === sort (catMaybes rows)
@ -633,7 +636,7 @@ testMaybeTable = databasePropertyTest "maybeTable" \transaction -> evalM do
transaction do
selected <- lift do
statement () $ Rel8.select do
statement () $ Rel8.run $ Rel8.select do
Rel8.maybeTable (Rel8.lit def) id <$> Rel8.optional (Rel8.values (Rel8.lit <$> rows))
case rows of
@ -657,7 +660,7 @@ testAggregateMaybeTable = databasePropertyTest "aggregateMaybeTable" \transactio
transaction do
selected <- lift do
statement () $ Rel8.select do
statement () $ Rel8.run $ Rel8.select do
Rel8.aggregate1 (Rel8.aggregateMaybeTable Rel8.sum) $ Rel8.values (Rel8.lit <$> rows)
sort selected === aggregate rows
@ -685,7 +688,7 @@ testNestedTables = databasePropertyTest "Nested TestTables" \transaction -> eval
transaction do
selected <- lift do
statement () $ Rel8.select do
statement () $ Rel8.run $ Rel8.select do
Rel8.values (Rel8.lit <$> rows)
sort selected === sort rows
@ -698,7 +701,7 @@ testMaybeTableApplicative = databasePropertyTest "MaybeTable (<*>)" \transaction
transaction do
selected <- lift do
statement () $ Rel8.select do
statement () $ Rel8.run $ Rel8.select do
as <- Rel8.optional (Rel8.values (Rel8.lit <$> rows1))
bs <- Rel8.optional (Rel8.values (Rel8.lit <$> rows2))
pure $ liftA2 (,) as bs
@ -727,14 +730,14 @@ testUpdate = databasePropertyTest "Can UPDATE TestTable" \transaction -> do
transaction do
selected <- lift do
statement () $ Rel8.insert Rel8.Insert
statement () $ Rel8.run_ $ Rel8.insert Rel8.Insert
{ into = testTableSchema
, rows = Rel8.values $ map Rel8.lit $ Map.keys rows
, onConflict = Rel8.DoNothing
, returning = pure ()
, returning = Rel8.NoReturning
}
statement () $ Rel8.update Rel8.Update
statement () $ Rel8.run_ $ Rel8.update Rel8.Update
{ target = testTableSchema
, from = pure ()
, set = \_ r ->
@ -752,10 +755,10 @@ testUpdate = databasePropertyTest "Can UPDATE TestTable" \transaction -> do
r
updates
, updateWhere = \_ _ -> Rel8.lit True
, returning = pure ()
, returning = Rel8.NoReturning
}
statement () $ Rel8.select do
statement () $ Rel8.run $ Rel8.select do
Rel8.each testTableSchema
sort selected === sort (Map.elems rows)
@ -771,21 +774,21 @@ testDelete = databasePropertyTest "Can DELETE TestTable" \transaction -> do
transaction do
(deleted, selected) <- lift do
statement () $ Rel8.insert Rel8.Insert
statement () $ Rel8.run_ $ Rel8.insert Rel8.Insert
{ into = testTableSchema
, rows = Rel8.values $ map Rel8.lit rows
, onConflict = Rel8.DoNothing
, returning = pure ()
, returning = Rel8.NoReturning
}
deleted <- statement () $ Rel8.delete Rel8.Delete
deleted <- statement () $ Rel8.run $ Rel8.delete Rel8.Delete
{ from = testTableSchema
, using = pure ()
, deleteWhere = const testTableColumn2
, returning = Rel8.Projection id
, returning = Rel8.Returning id
}
selected <- statement () $ Rel8.select do
selected <- statement () $ Rel8.run $ Rel8.select do
Rel8.each testTableSchema
pure (deleted, selected)
@ -793,6 +796,80 @@ testDelete = databasePropertyTest "Can DELETE TestTable" \transaction -> do
sort (deleted <> selected) === sort rows
testWithStatement :: IO TmpPostgres.DB -> TestTree
testWithStatement genTestDatabase =
testGroup "WITH"
[ selectUnionInsert genTestDatabase
, rowsAffectedNoReturning genTestDatabase
, rowsAffectedReturing genTestDatabase
, pureQuery genTestDatabase
]
where
selectUnionInsert =
databasePropertyTest "Can UNION results of SELECT with results of INSERT" \transaction -> do
rows <- forAll $ Gen.list (Range.linear 0 50) genTestTable
transaction do
rows' <- lift do
statement () $ Rel8.run $ do
values <- Rel8.select $ Rel8.values $ map Rel8.lit rows
inserted <- Rel8.insert $ Rel8.Insert
{ into = testTableSchema
, rows = values
, onConflict = Rel8.DoNothing
, returning = Rel8.Returning id
}
pure $ values <> inserted
sort rows' === sort (rows <> rows)
rowsAffectedNoReturning =
databasePropertyTest "Can read rows affected from INSERT without RETURNING" \transaction -> do
rows <- forAll $ Gen.list (Range.linear 0 50) genTestTable
transaction do
affected <- lift do
statement () $ Rel8.runN $ do
Rel8.insert $ Rel8.Insert
{ into = testTableSchema
, rows = Rel8.values $ map Rel8.lit rows
, onConflict = Rel8.DoNothing
, returning = Rel8.NoReturning
}
length rows === fromIntegral affected
rowsAffectedReturing =
databasePropertyTest "Can read rows affected from INSERT with RETURNING" \transaction -> do
rows <- forAll $ Gen.list (Range.linear 0 50) genTestTable
transaction do
affected <- lift do
statement () $ Rel8.runN $ void $ do
Rel8.insert $ Rel8.Insert
{ into = testTableSchema
, rows = Rel8.values $ map Rel8.lit rows
, onConflict = Rel8.DoNothing
, returning = Rel8.Returning id
}
length rows === fromIntegral affected
pureQuery =
databasePropertyTest "Can read pure Query" \transaction -> do
rows <- forAll $ Gen.list (Range.linear 0 50) genTestTable
transaction do
rows' <- lift do
statement () $ Rel8.run $ pure do
Rel8.values $ map Rel8.lit rows
sort rows === sort rows'
data UniqueTable f = UniqueTable
{ uniqueTableKey :: Rel8.Column f Text
, uniqueTableValue :: Rel8.Column f Text
@ -832,14 +909,14 @@ testUpsert = databasePropertyTest "Can UPSERT UniqueTable" \transaction -> do
transaction do
selected <- lift do
statement () $ Rel8.insert Rel8.Insert
statement () $ Rel8.run_ $ Rel8.insert Rel8.Insert
{ into = uniqueTableSchema
, rows = Rel8.values $ Rel8.lit <$> as
, onConflict = Rel8.DoNothing
, returning = pure ()
, returning = Rel8.NoReturning
}
statement () $ Rel8.insert Rel8.Insert
statement () $ Rel8.run_ $ Rel8.insert Rel8.Insert
{ into = uniqueTableSchema
, rows = Rel8.values $ Rel8.lit <$> bs
, onConflict = Rel8.DoUpdate Rel8.Upsert
@ -847,10 +924,10 @@ testUpsert = databasePropertyTest "Can UPSERT UniqueTable" \transaction -> do
, set = \UniqueTable {uniqueTableValue} old -> old {uniqueTableValue}
, updateWhere = \_ _ -> Rel8.true
}
, returning = pure ()
, returning = Rel8.NoReturning
}
statement () $ Rel8.select do
statement () $ Rel8.run $ Rel8.select do
Rel8.each uniqueTableSchema
fromUniqueTables selected === fromUniqueTables bs <> fromUniqueTables as
@ -874,7 +951,7 @@ testSelectNestedPairs = databasePropertyTest "Can SELECT nested pairs" \transact
transaction do
selected <- lift do
statement () $ Rel8.select do
statement () $ Rel8.run $ Rel8.select do
Rel8.values $ map Rel8.lit rows
sort selected === sort rows
@ -886,13 +963,13 @@ testSelectArray = databasePropertyTest "Can SELECT Arrays (with aggregation)" \t
transaction do
selected <- lift do
statement () $ Rel8.select do
statement () $ Rel8.run1 $ Rel8.select do
Rel8.many $ Rel8.values (map Rel8.lit rows)
selected === [foldMap pure rows]
selected === rows
selected' <- lift do
statement () $ Rel8.select do
statement () $ Rel8.run $ Rel8.select do
a <- Rel8.catListTable =<< do
Rel8.many $ Rel8.values (map Rel8.lit rows)
b <- Rel8.catListTable =<< do
@ -921,11 +998,11 @@ testNestedMaybeTable = databasePropertyTest "Can nest MaybeTable within other ta
transaction do
selected <- lift do
statement () $ Rel8.select do
statement () $ Rel8.run1 $ Rel8.select do
x <- Rel8.values [Rel8.lit example]
pure $ Rel8.maybeTable (Rel8.lit False) (\_ -> Rel8.lit True) (nmt2 x)
selected === [True]
selected === True
testEvaluate :: IO TmpPostgres.DB -> TestTree
@ -933,7 +1010,7 @@ testEvaluate = databasePropertyTest "evaluate has the evaluation order we expect
transaction do
selected <- lift do
statement () $ Rel8.select do
statement () $ Rel8.run $ Rel8.select do
x <- Rel8.values (Rel8.lit <$> ['a', 'b', 'c'])
y <- Rel8.evaluate (Rel8.nextval "test_seq")
pure (x, (y, y))
@ -945,7 +1022,7 @@ testEvaluate = databasePropertyTest "evaluate has the evaluation order we expect
]
selected' <- lift do
statement () $ Rel8.select do
statement () $ Rel8.run $ Rel8.select do
x <- Rel8.values (Rel8.lit <$> ['a', 'b', 'c'])
y <- Rel8.values (Rel8.lit <$> ['d', 'e', 'f'])
z <- Rel8.evaluate (Rel8.nextval "test_seq")

1
tests/Rel8/Generic/Rel8able/Test.hs
View File

@ -7,6 +7,7 @@
{-# language MultiParamTypeClasses #-}
{-# language StandaloneKindSignatures #-}
{-# language TypeFamilies #-}
{-# language TypeOperators #-}
{-# language UndecidableInstances #-}
{-# options_ghc -O0 #-}