From 3c0b67f99e601157e5d2b3b7803d9d919fbda756 Mon Sep 17 00:00:00 2001 From: Shane Date: Fri, 7 Jul 2023 11:29:15 +0100 Subject: [PATCH] Statements overhaul (support for statement-level `WITH`) (#250) 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. --- docs/concepts/insert.rst | 29 ++- rel8.cabal | 6 + src/Rel8.hs | 26 ++- src/Rel8/Query/SQL.hs | 8 +- src/Rel8/Statement.hs | 327 ++++++++++++++++++++++++++++ src/Rel8/Statement/Delete.hs | 51 ++--- src/Rel8/Statement/Insert.hs | 47 ++-- src/Rel8/Statement/Returning.hs | 108 +++------ src/Rel8/Statement/Rows.hs | 30 +++ src/Rel8/Statement/Run.hs | 84 +++++++ src/Rel8/Statement/SQL.hs | 21 +- src/Rel8/Statement/Select.hs | 55 ++--- src/Rel8/Statement/Update.hs | 54 +++-- src/Rel8/Statement/Using.hs | 25 ++- src/Rel8/Statement/View.hs | 14 +- src/Rel8/Table/Name.hs | 16 +- tests/Main.hs | 213 ++++++++++++------ tests/Rel8/Generic/Rel8able/Test.hs | 1 + 18 files changed, 816 insertions(+), 299 deletions(-) create mode 100644 src/Rel8/Statement.hs create mode 100644 src/Rel8/Statement/Rows.hs create mode 100644 src/Rel8/Statement/Run.hs diff --git a/docs/concepts/insert.rst b/docs/concepts/insert.rst index 4434a58b..640fdef9 100644 --- a/docs/concepts/insert.rst +++ b/docs/concepts/insert.rst @@ -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 } diff --git a/rel8.cabal b/rel8.cabal index 2e92c086..89be6098 100644 --- a/rel8.cabal +++ b/rel8.cabal @@ -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 diff --git a/src/Rel8.hs b/src/Rel8.hs index 64b3c79c..fc91587a 100644 --- a/src/Rel8.hs +++ b/src/Rel8.hs @@ -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. diff --git a/src/Rel8/Query/SQL.hs b/src/Rel8/Query/SQL.hs index 73158bb2..3ab27185 100644 --- a/src/Rel8/Query/SQL.hs +++ b/src/Rel8/Query/SQL.hs @@ -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 diff --git a/src/Rel8/Statement.hs b/src/Rel8/Statement.hs new file mode 100644 index 00000000..79ac9763 --- /dev/null +++ b/src/Rel8/Statement.hs @@ -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 diff --git a/src/Rel8/Statement/Delete.hs b/src/Rel8/Statement/Delete.hs index 7e8c9bcb..45fbc237 100644 --- a/src/Rel8/Statement/Delete.hs +++ b/src/Rel8/Statement/Delete.hs @@ -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 diff --git a/src/Rel8/Statement/Insert.hs b/src/Rel8/Statement/Insert.hs index 096ed2f4..120fe721 100644 --- a/src/Rel8/Statement/Insert.hs +++ b/src/Rel8/Statement/Insert.hs @@ -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 diff --git a/src/Rel8/Statement/Returning.hs b/src/Rel8/Statement/Returning.hs index ecdb3dcf..30418e5a 100644 --- a/src/Rel8/Statement/Returning.hs +++ b/src/Rel8/Statement/Returning.hs @@ -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 - - -- | Return the number of rows affected. - NumberOfRowsAffected :: Returning names Int64 + -- | No @RETURNING@ clause + NoReturning :: Returning names () - -- | '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)))) - - -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) +projections TableSchema {columns} = \case + NoReturning -> Nothing + Returning f -> Just (exprs (castTable (f (view columns)))) + + +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 diff --git a/src/Rel8/Statement/Rows.hs b/src/Rel8/Statement/Rows.hs new file mode 100644 index 00000000..f8f488d8 --- /dev/null +++ b/src/Rel8/Statement/Rows.hs @@ -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) diff --git a/src/Rel8/Statement/Run.hs b/src/Rel8/Statement/Run.hs new file mode 100644 index 00000000..188cb366 --- /dev/null +++ b/src/Rel8/Statement/Run.hs @@ -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 diff --git a/src/Rel8/Statement/SQL.hs b/src/Rel8/Statement/SQL.hs index 1ee41ff8..aa9dfef2 100644 --- a/src/Rel8/Statement/SQL.hs +++ b/src/Rel8/Statement/SQL.hs @@ -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 diff --git a/src/Rel8/Statement/Select.hs b/src/Rel8/Statement/Select.hs index 43e66eeb..d277365f 100644 --- a/src/Rel8/Statement/Select.hs +++ b/src/Rel8/Statement/Select.hs @@ -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 diff --git a/src/Rel8/Statement/Update.hs b/src/Rel8/Statement/Update.hs index 7c615210..ba95e2c1 100644 --- a/src/Rel8/Statement/Update.hs +++ b/src/Rel8/Statement/Update.hs @@ -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 diff --git a/src/Rel8/Statement/Using.hs b/src/Rel8/Statement/Using.hs index c8dc00cd..b0d0557f 100644 --- a/src/Rel8/Statement/Using.hs +++ b/src/Rel8/Statement/Using.hs @@ -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 diff --git a/src/Rel8/Statement/View.hs b/src/Rel8/Statement/View.hs index a4fa09b4..02093330 100644 --- a/src/Rel8/Statement/View.hs +++ b/src/Rel8/Statement/View.hs @@ -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" diff --git a/src/Rel8/Table/Name.hs b/src/Rel8/Table/Name.hs index 51c35382..4cb4c63d 100644 --- a/src/Rel8/Table/Name.hs +++ b/src/Rel8/Table/Name.hs @@ -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] diff --git a/tests/Main.hs b/tests/Main.hs index b0973670..4879cb94 100644 --- a/tests/Main.hs +++ b/tests/Main.hs @@ -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") diff --git a/tests/Rel8/Generic/Rel8able/Test.hs b/tests/Rel8/Generic/Rel8able/Test.hs index 88eda93c..7a8fc87c 100644 --- a/tests/Rel8/Generic/Rel8able/Test.hs +++ b/tests/Rel8/Generic/Rel8able/Test.hs @@ -7,6 +7,7 @@ {-# language MultiParamTypeClasses #-} {-# language StandaloneKindSignatures #-} {-# language TypeFamilies #-} +{-# language TypeOperators #-} {-# language UndecidableInstances #-} {-# options_ghc -O0 #-}