From cc0014da8c9ef81b1e0532d00b1badb1182cb08c Mon Sep 17 00:00:00 2001 From: Ollie Charles Date: Fri, 7 Jul 2023 11:34:08 +0100 Subject: [PATCH] Format --- rel8.cabal | 5 +- src/Rel8.hs | 57 ++--- src/Rel8/Statement.hs | 213 ++++++++--------- src/Rel8/Statement/Delete.hs | 44 ++-- src/Rel8/Statement/Insert.hs | 34 +-- src/Rel8/Statement/Returning.hs | 57 ++--- src/Rel8/Statement/Rows.hs | 12 +- src/Rel8/Statement/Run.hs | 80 ++++--- src/Rel8/Statement/SQL.hs | 18 +- src/Rel8/Statement/Select.hs | 54 ++--- src/Rel8/Statement/Update.hs | 52 +++-- src/Rel8/Statement/Using.hs | 2 +- src/Rel8/Statement/View.hs | 20 +- src/Rel8/Table/Name.hs | 75 +++--- tests/Main.hs | 343 +++++++++++++++------------- tests/Rel8/Generic/Rel8able/Test.hs | 22 +- 16 files changed, 581 insertions(+), 507 deletions(-) diff --git a/rel8.cabal b/rel8.cabal index e78668aa..8d0ef2bc 100644 --- a/rel8.cabal +++ b/rel8.cabal @@ -42,8 +42,8 @@ library , transformers , uuid , vector - default-language: - Haskell2010 + + default-language: Haskell2010 ghc-options: -Werror=missing-methods -Werror=incomplete-patterns -Werror=missing-fields -Weverything -Wno-unsafe -Wno-safe @@ -144,7 +144,6 @@ library Rel8.Schema.Result Rel8.Schema.Spec Rel8.Schema.Table - Rel8.Statement Rel8.Statement.Delete Rel8.Statement.Insert diff --git a/src/Rel8.hs b/src/Rel8.hs index e64dcc18..a86bb59b 100644 --- a/src/Rel8.hs +++ b/src/Rel8.hs @@ -414,17 +414,19 @@ module Rel8 ( -- ** Bindings rebind, - -- * Running statements - -- $running - , run - , run_ - , runN - , run1 - , runMaybe - , runVector + -- * IO + Serializable, + ToExprs, + Result, -- * Running statements -- $running + run, + run_, + runN, + run1, + runMaybe, + runVector, -- ** @SELECT@ select, @@ -447,13 +449,12 @@ module Rel8 ( update, showUpdate, - -- ** @WITH@ - , Statement - , showStatement + -- ** @.. RETURNING@ + Returning (..), - -- ** @CREATE VIEW@ - , createView - , createOrReplaceView + -- ** @WITH@ + Statement, + showStatement, -- ** @CREATE VIEW@ createView, @@ -531,7 +532,6 @@ 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.Select import Rel8.Statement.Update @@ -575,19 +575,20 @@ import Rel8.Type.Sum import Rel8.Window --- $running --- To run queries and otherwise interact with a PostgreSQL database, Rel8 --- 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. +{- $running +To run queries and otherwise interact with a PostgreSQL database, Rel8 +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 diff --git a/src/Rel8/Statement.hs b/src/Rel8/Statement.hs index 79ac9763..92500271 100644 --- a/src/Rel8/Statement.hs +++ b/src/Rel8/Statement.hs @@ -1,21 +1,21 @@ -{-# 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 - ) +{-# 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 @@ -35,18 +35,18 @@ import qualified Hasql.Decoders as Hasql import qualified Opaleye.Internal.Tag as Opaleye -- pretty -import Text.PrettyPrint - ( Doc - , (<+>) - , ($$) - , comma - , doubleQuotes - , hcat - , parens - , punctuate - , text - , vcat - ) +import Text.PrettyPrint ( + Doc, + comma, + doubleQuotes, + hcat, + parens, + punctuate, + text, + vcat, + ($$), + (<+>), + ) -- rel8 import Rel8.Expr (Expr) @@ -99,54 +99,55 @@ getResult = \case 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)) + 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 @@ -177,14 +178,16 @@ statementNoReturning pp = Statement $ do relation = Opaleye.tagWith tag "statement" columns = Nothing returning = NoReturning - binding = Binding {..} + binding = Binding{..} pure binding tell (Endo (binding :)) pure $ Unmodified () -statementReturning :: Table Expr a - => State Opaleye.Tag Doc -> Statement (Query a) +statementReturning :: + Table Expr a => + State Opaleye.Tag Doc -> + Statement (Query a) statementReturning pp = Statement $ do (binding, query) <- lift $ do doc <- pp @@ -201,22 +204,26 @@ statementReturning pp = Statement $ do names = namesFromLabelsWithA symbol `evalState` Opaleye.start columns = Just $ showNames names query = - fromCols <$> each - TableSchema - { name = relation - , schema = Nothing - , columns = names - } + fromCols + <$> each + TableSchema + { name = relation + , schema = Nothing + , columns = names + } returning = Returning (countRows query) - binding = Binding {..} + 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 :: + () => + (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 @@ -243,7 +250,7 @@ ppDecodeStatement ppSelect rows (Statement m) = evalState go Opaleye.start Vector @exprs @a -> do doc <- ppSelect (getResult result) pure (doc, Hasql.rowVector (parse @exprs @a)) - Just (bindings, binding@Binding {doc = after}) -> case rows of + Just (bindings, binding@Binding{doc = after}) -> case rows of Void -> pure (doc, Hasql.noResult) where doc = ppWith bindings after @@ -255,7 +262,7 @@ ppDecodeStatement ppSelect rows (Statement m) = evalState go Opaleye.start Modified _ -> case returning binding of NoReturning -> pure (doc, Hasql.rowsAffected) where - doc = ppWith bindings after + doc = ppWith bindings after Returning query -> do doc <- ppWith bindings' <$> ppSelect query pure (doc, Hasql.singleRow parse) @@ -299,20 +306,20 @@ ppWith bindings after = pre $$ after pre = case bindings of [] -> mempty _ -> - text "WITH" <+> - vcat (punctuate comma (map go bindings)) - go binding@Binding {doc = before} = - ppAlias binding $$ - text "AS" <+> - parens before + 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 +ppAlias Binding{relation, columns = mcolumns} = case mcolumns of Nothing -> escape relation - Just columns -> - escape relation <+> - parens (hcat (punctuate comma (escape <$> toList columns))) + Just columns -> + escape relation + <+> parens (hcat (punctuate comma (escape <$> toList columns))) escape :: String -> Doc diff --git a/src/Rel8/Statement/Delete.hs b/src/Rel8/Statement/Delete.hs index 9f757903..26e06e6c 100644 --- a/src/Rel8/Statement/Delete.hs +++ b/src/Rel8/Statement/Delete.hs @@ -1,10 +1,10 @@ -{-# language DuplicateRecordFields #-} -{-# language FlexibleContexts #-} -{-# language GADTs #-} -{-# language NamedFieldPuns #-} -{-# language RecordWildCards #-} -{-# language StandaloneKindSignatures #-} -{-# language StrictData #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE StrictData #-} module Rel8.Statement.Delete ( Delete (..), @@ -24,14 +24,14 @@ import qualified Opaleye.Internal.Tag as Opaleye import Text.PrettyPrint (Doc, text, ($$), (<+>)) -- rel8 -import Rel8.Expr ( Expr ) -import Rel8.Query ( Query ) -import Rel8.Schema.Name ( Selects ) -import Rel8.Schema.Table ( TableSchema, ppTable ) +import Rel8.Expr (Expr) +import Rel8.Query (Query) +import Rel8.Schema.Name (Selects) +import Rel8.Schema.Table (TableSchema, ppTable) import Rel8.Statement (Statement) import Rel8.Statement.Returning (Returning, ppReturning, runReturning) -import Rel8.Statement.Using ( ppUsing ) -import Rel8.Statement.Where ( ppWhere ) +import Rel8.Statement.Using (ppUsing) +import Rel8.Statement.Where (ppWhere) -- transformers import Control.Monad.Trans.State.Strict (State) @@ -57,19 +57,21 @@ data Delete a where -- | Build a @DELETE@ 'Statement'. delete :: Delete a -> Statement a -delete statement@Delete {returning} = +delete statement@Delete{returning} = runReturning (ppDelete statement) returning ppDelete :: Delete a -> State Opaleye.Tag Doc -ppDelete Delete {..} = do +ppDelete Delete{..} = do musing <- ppUsing using pure $ case musing of Nothing -> - text "DELETE FROM" <+> ppTable from $$ - text "WHERE false" + text "DELETE FROM" + <+> ppTable from + $$ text "WHERE false" Just (usingDoc, i) -> - text "DELETE FROM" <+> ppTable from $$ - usingDoc $$ - ppWhere from (deleteWhere i) $$ - ppReturning from returning + 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 7390e347..1920d745 100644 --- a/src/Rel8/Statement/Insert.hs +++ b/src/Rel8/Statement/Insert.hs @@ -27,15 +27,15 @@ import qualified Opaleye.Internal.Tag as Opaleye import Text.PrettyPrint (Doc, parens, text, ($$), (<+>)) -- rel8 -import Rel8.Query ( Query ) -import Rel8.Schema.Name ( Name, Selects, ppColumn ) -import Rel8.Schema.Table ( TableSchema(..), ppTable ) +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.OnConflict (OnConflict, ppOnConflict) import Rel8.Statement.Returning (Returning, ppReturning, runReturning) -import Rel8.Statement.Select ( ppRows ) -import Rel8.Table ( Table ) -import Rel8.Table.Name ( showNames ) +import Rel8.Statement.Select (ppRows) +import Rel8.Table (Table) +import Rel8.Table.Name (showNames) -- transformers import Control.Monad.Trans.State.Strict (State) @@ -62,22 +62,22 @@ data Insert a where -- | Build an @INSERT@ 'Statement'. insert :: Insert a -> Statement a -insert statement@Insert {returning} = +insert statement@Insert{returning} = runReturning (ppInsert statement) returning ppInsert :: Insert a -> State Opaleye.Tag Doc -ppInsert Insert {..} = do +ppInsert Insert{..} = do rows' <- ppRows rows pure $ - text "INSERT INTO" <+> - ppInto into $$ - rows' $$ - ppOnConflict into onConflict $$ - ppReturning into returning + 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))) +ppInto table@TableSchema{columns} = + ppTable table + <+> parens (Opaleye.commaV ppColumn (toList (showNames columns))) diff --git a/src/Rel8/Statement/Returning.hs b/src/Rel8/Statement/Returning.hs index 94784214..9c79bdc0 100644 --- a/src/Rel8/Statement/Returning.hs +++ b/src/Rel8/Statement/Returning.hs @@ -1,25 +1,25 @@ -{-# language DataKinds #-} -{-# language FlexibleContexts #-} -{-# language GADTs #-} -{-# language LambdaCase #-} -{-# language NamedFieldPuns #-} -{-# language RankNTypes #-} -{-# language ScopedTypeVariables #-} -{-# language StandaloneKindSignatures #-} -{-# language StrictData #-} -{-# language TypeApplications #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TypeApplications #-} -module Rel8.Statement.Returning - ( Returning( NoReturning, Returning ) - , runReturning - , ppReturning - ) +module Rel8.Statement.Returning ( + Returning (NoReturning, Returning), + runReturning, + ppReturning, +) where -- base -import Data.Foldable ( toList ) -import Data.Kind ( Type ) -import Data.List.NonEmpty ( NonEmpty ) +import Data.Foldable (toList) +import Data.Kind (Type) +import Data.List.NonEmpty (NonEmpty) import Prelude -- opaleye @@ -34,23 +34,23 @@ 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.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.Opaleye (castTable, exprs, view) -- transformers import Control.Monad.Trans.State.Strict (State) --- | 'Rel8.Insert', 'Rel8.Update' and 'Rel8.Delete' all support an optional --- @RETURNING@ clause. +{- | 'Rel8.Insert', 'Rel8.Update' and 'Rel8.Delete' all support an optional +@RETURNING@ clause. +-} type Returning :: Type -> Type -> Type data Returning names a where -- | No @RETURNING@ clause NoReturning :: Returning names () - -- | '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 @@ -58,9 +58,12 @@ data Returning names a where Returning :: (Selects names exprs, Table Expr a) => (exprs -> a) -> Returning names (Query a) -projections :: () - => TableSchema names -> Returning names a -> Maybe (NonEmpty Opaleye.PrimExpr) -projections TableSchema {columns} = \case +projections :: + () => + TableSchema names -> + Returning names a -> + Maybe (NonEmpty Opaleye.PrimExpr) +projections TableSchema{columns} = \case NoReturning -> Nothing Returning f -> Just (exprs (castTable (f (view columns)))) diff --git a/src/Rel8/Statement/Rows.hs b/src/Rel8/Statement/Rows.hs index f8f488d8..908e9ed9 100644 --- a/src/Rel8/Statement/Rows.hs +++ b/src/Rel8/Statement/Rows.hs @@ -1,10 +1,10 @@ -{-# language DataKinds #-} -{-# language GADTs #-} -{-# language StandaloneKindSignatures #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE StandaloneKindSignatures #-} -module Rel8.Statement.Rows - ( Rows (..) - ) +module Rel8.Statement.Rows ( + Rows (..), +) where -- base diff --git a/src/Rel8/Statement/Run.hs b/src/Rel8/Statement/Run.hs index 188cb366..82e2d3d2 100644 --- a/src/Rel8/Statement/Run.hs +++ b/src/Rel8/Statement/Run.hs @@ -1,11 +1,11 @@ -module Rel8.Statement.Run - ( run_ - , runN - , run1 - , runMaybe - , run - , runVector - ) +module Rel8.Statement.Run ( + run_, + runN, + run1, + runMaybe, + run, + runVector, +) where -- base @@ -41,44 +41,62 @@ makeRun rows statement = Hasql.Statement bytes params decode prepare (doc, decode) = ppDecodeStatement ppSelect rows statement --- | Convert a 'Statement' to a runnable 'Hasql.Statement', disregarding the --- results of that statement (if any). +{- | 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'). +{- | 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 +{- | 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) +{- | 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] +{- | 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) +{- | 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 aa9dfef2..a353a92a 100644 --- a/src/Rel8/Statement/SQL.hs +++ b/src/Rel8/Statement/SQL.hs @@ -1,9 +1,9 @@ -module Rel8.Statement.SQL - ( showDelete - , showInsert - , showUpdate - , showStatement - ) +module Rel8.Statement.SQL ( + showDelete, + showInsert, + showUpdate, + showStatement, +) where -- base @@ -14,11 +14,11 @@ 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.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 ) +import Rel8.Statement.Update (Update, ppUpdate) -- transformers import Control.Monad.Trans.State.Strict (evalState) diff --git a/src/Rel8/Statement/Select.hs b/src/Rel8/Statement/Select.hs index 53be7a89..bd11292e 100644 --- a/src/Rel8/Statement/Select.hs +++ b/src/Rel8/Statement/Select.hs @@ -1,19 +1,19 @@ -{-# language DataKinds #-} -{-# language DeriveTraversable #-} -{-# language DerivingStrategies #-} -{-# language FlexibleContexts #-} -{-# language MonoLocalBinds #-} -{-# language ScopedTypeVariables #-} -{-# language StandaloneKindSignatures #-} -{-# language TypeApplications #-} - -module Rel8.Statement.Select - ( select - , ppSelect - , Optimized(..) - , ppPrimSelect - , ppRows - ) +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeApplications #-} + +module Rel8.Statement.Select ( + select, + ppSelect, + Optimized (..), + ppPrimSelect, + ppRows, +) where -- base @@ -37,19 +37,19 @@ import qualified Opaleye.Internal.Tag as Opaleye import Text.PrettyPrint (Doc) -- rel8 -import Rel8.Expr ( Expr ) -import Rel8.Expr.Bool ( false ) -import Rel8.Expr.Opaleye ( toPrimExpr ) -import Rel8.Query ( Query ) -import Rel8.Query.Opaleye ( toOpaleye ) -import Rel8.Schema.Name ( Selects ) +import Rel8.Expr (Expr) +import Rel8.Expr.Bool (false) +import Rel8.Expr.Opaleye (toPrimExpr) +import Rel8.Query (Query) +import Rel8.Query.Opaleye (toOpaleye) +import Rel8.Schema.Name (Selects) 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 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.Undefined ( undefined ) +import Rel8.Table.Undefined (undefined) -- transformers import Control.Monad.Trans.State.Strict (State) diff --git a/src/Rel8/Statement/Update.hs b/src/Rel8/Statement/Update.hs index 52893b80..c27d1863 100644 --- a/src/Rel8/Statement/Update.hs +++ b/src/Rel8/Statement/Update.hs @@ -1,10 +1,10 @@ -{-# language DuplicateRecordFields #-} -{-# language FlexibleContexts #-} -{-# language GADTs #-} -{-# language NamedFieldPuns #-} -{-# language RecordWildCards #-} -{-# language StandaloneKindSignatures #-} -{-# language StrictData #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE StrictData #-} module Rel8.Statement.Update ( Update (..), @@ -24,15 +24,15 @@ import qualified Opaleye.Internal.Tag as Opaleye import Text.PrettyPrint (Doc, text, ($$), (<+>)) -- rel8 -import Rel8.Expr ( Expr ) -import Rel8.Query ( Query ) -import Rel8.Schema.Name ( Selects ) -import Rel8.Schema.Table ( TableSchema(..), ppTable ) +import Rel8.Expr (Expr) +import Rel8.Query (Query) +import Rel8.Schema.Name (Selects) +import Rel8.Schema.Table (TableSchema (..), ppTable) 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 ) +import Rel8.Statement.Set (ppSet) +import Rel8.Statement.Using (ppFrom) +import Rel8.Statement.Where (ppWhere) -- transformers import Control.Monad.Trans.State.Strict (State) @@ -60,21 +60,23 @@ data Update a where -- | Build an @UPDATE@ 'Statement'. update :: Update a -> Statement a -update statement@Update {returning} = +update statement@Update{returning} = runReturning (ppUpdate statement) returning ppUpdate :: Update a -> State Opaleye.Tag Doc -ppUpdate Update {..} = do +ppUpdate Update{..} = do mfrom <- ppFrom from pure $ case mfrom of - Nothing -> - text "UPDATE" <+> ppTable target $$ - ppSet target id $$ - text "WHERE false" + 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 + 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 45f818a2..a99c5ca7 100644 --- a/src/Rel8/Statement/Using.hs +++ b/src/Rel8/Statement/Using.hs @@ -40,4 +40,4 @@ ppJoin clause join = do Optimized doc -> Just $ text clause <+> parens doc <+> ppTable alias pure (doc, a) where - alias = TableSchema {name = "T1", schema = Nothing, columns = ()} + alias = TableSchema{name = "T1", schema = Nothing, columns = ()} diff --git a/src/Rel8/Statement/View.hs b/src/Rel8/Statement/View.hs index 028dd8d7..24e99829 100644 --- a/src/Rel8/Statement/View.hs +++ b/src/Rel8/Statement/View.hs @@ -19,14 +19,14 @@ import qualified Hasql.Statement as Hasql import qualified Opaleye.Internal.Tag as Opaleye -- pretty -import Text.PrettyPrint ( Doc, (<+>), ($$), text ) +import Text.PrettyPrint (Doc, text, ($$), (<+>)) -- rel8 -import Rel8.Query ( Query ) -import Rel8.Schema.Name ( Selects ) -import Rel8.Schema.Table ( TableSchema ) -import Rel8.Statement.Insert ( ppInto ) -import Rel8.Statement.Select ( ppSelect ) +import Rel8.Query (Query) +import Rel8.Schema.Name (Selects) +import Rel8.Schema.Table (TableSchema) +import Rel8.Statement.Insert (ppInto) +import Rel8.Statement.Select (ppSelect) -- text import qualified Data.Text as Text @@ -91,10 +91,10 @@ ppCreateView :: CreateView -> Doc ppCreateView schema query replace = - createOrReplace replace <+> - ppInto schema $$ - text "AS" <+> - evalState (ppSelect query) Opaleye.start + createOrReplace replace + <+> ppInto schema + $$ text "AS" + <+> 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 1317e58e..b840e30e 100644 --- a/src/Rel8/Table/Name.hs +++ b/src/Rel8/Table/Name.hs @@ -9,28 +9,28 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} -module Rel8.Table.Name - ( namesFromLabels - , namesFromLabelsWith - , namesFromLabelsWithA - , showLabels - , showNames - ) +module Rel8.Table.Name ( + namesFromLabels, + namesFromLabelsWith, + namesFromLabelsWithA, + showLabels, + showNames, +) where -- base -import Data.Foldable ( fold ) -import Data.Functor.Const ( Const( Const ), getConst ) +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 Data.List.NonEmpty (NonEmpty, intersperse, nonEmpty) +import Data.Maybe (fromMaybe) import Prelude -- rel8 -import Rel8.Schema.HTable (htabulateA, hfield, hspecs) -import Rel8.Schema.Name ( Name( Name ) ) -import Rel8.Schema.Spec ( Spec(..) ) -import Rel8.Table ( Table(..) ) +import Rel8.Schema.HTable (hfield, hspecs, htabulateA) +import Rel8.Schema.Name (Name (Name)) +import Rel8.Schema.Spec (Spec (..)) +import Rel8.Table (Table (..)) -- semigroupoids import Data.Functor.Apply (Apply) @@ -47,31 +47,36 @@ namesFromLabels = namesFromLabelsWith go go = fold . intersperse "/" --- | Construct a table in the 'Name' context containing the names of all --- columns. The supplied function can be used to transform column names. --- --- This function can be used to generically derive the columns for a --- 'TableSchema'. For example, --- --- @ --- myTableSchema :: TableSchema (MyTable Name) --- myTableSchema = TableSchema --- { columns = namesFromLabelsWith last --- } --- @ --- --- will construct a 'TableSchema' where each columns names exactly corresponds --- to the name of the Haskell field. -namesFromLabelsWith :: Table Name a - => (NonEmpty String -> String) -> a +{- | Construct a table in the 'Name' context containing the names of all +columns. The supplied function can be used to transform column names. + +This function can be used to generically derive the columns for a +'TableSchema'. For example, + +@ +myTableSchema :: TableSchema (MyTable Name) +myTableSchema = TableSchema + { columns = namesFromLabelsWith last + } +@ + +will construct a 'TableSchema' where each columns names exactly corresponds +to the name of the Haskell field. +-} +namesFromLabelsWith :: + Table Name a => + (NonEmpty String -> String) -> + a namesFromLabelsWith = runIdentity . namesFromLabelsWithA . (pure .) -namesFromLabelsWithA :: (Apply f, Table Name a) - => (NonEmpty String -> f String) -> f a +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 f814dcf3..80568d24 100644 --- a/tests/Main.hs +++ b/tests/Main.hs @@ -23,19 +23,19 @@ import Hasql.Transaction (Transaction, condemn, statement) import qualified Hasql.Transaction.Sessions as Hasql -- base -import Control.Applicative ( empty, liftA2, liftA3 ) -import Control.Exception ( bracket, throwIO ) +import Control.Applicative (empty, liftA2, liftA3) +import Control.Exception (bracket, throwIO) import Control.Monad ((>=>)) -import Data.Bifunctor ( bimap ) +import Data.Bifunctor (bimap) import Data.Fixed (Fixed (MkFixed)) -import Data.Foldable ( for_ ) +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.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 GHC.Generics (Generic) import Prelude hiding (truncate) -- bytestring @@ -104,41 +104,41 @@ main = defaultMain tests tests :: TestTree tests = withResource startTestDatabase stopTestDatabase \getTestDatabase -> - testGroup "rel8" - [ testSelectTestTable getTestDatabase - , testWithStatement getTestDatabase - , testWhere_ getTestDatabase - , testFilter getTestDatabase - , testLimit getTestDatabase - , testUnion getTestDatabase - , testDistinct getTestDatabase - , testExists getTestDatabase - , testOptional getTestDatabase - , testAnd getTestDatabase - , testOr getTestDatabase - , testNot getTestDatabase - , testBool getTestDatabase - , testAp getTestDatabase - , testDBType getTestDatabase - , testDBEq getTestDatabase - , testTableEquality getTestDatabase - , testFromString getTestDatabase - , testCatMaybeTable getTestDatabase - , testCatMaybe getTestDatabase - , testMaybeTable getTestDatabase - , testAggregateMaybeTable getTestDatabase - , testNestedTables getTestDatabase - , testMaybeTableApplicative getTestDatabase - , testLogicalFixities getTestDatabase - , testUpdate getTestDatabase - , testDelete getTestDatabase - , testUpsert getTestDatabase - , testSelectNestedPairs getTestDatabase - , testSelectArray getTestDatabase - , testNestedMaybeTable getTestDatabase - , testEvaluate getTestDatabase - ] - + testGroup + "rel8" + [ testSelectTestTable getTestDatabase + , testWithStatement getTestDatabase + , testWhere_ getTestDatabase + , testFilter getTestDatabase + , testLimit getTestDatabase + , testUnion getTestDatabase + , testDistinct getTestDatabase + , testExists getTestDatabase + , testOptional getTestDatabase + , testAnd getTestDatabase + , testOr getTestDatabase + , testNot getTestDatabase + , testBool getTestDatabase + , testAp getTestDatabase + , testDBType getTestDatabase + , testDBEq getTestDatabase + , testTableEquality getTestDatabase + , testFromString getTestDatabase + , testCatMaybeTable getTestDatabase + , testCatMaybe getTestDatabase + , testMaybeTable getTestDatabase + , testAggregateMaybeTable getTestDatabase + , testNestedTables getTestDatabase + , testMaybeTableApplicative getTestDatabase + , testLogicalFixities getTestDatabase + , testUpdate getTestDatabase + , testDelete getTestDatabase + , testUpsert getTestDatabase + , testSelectNestedPairs getTestDatabase + , testSelectArray getTestDatabase + , testNestedMaybeTable getTestDatabase + , testEvaluate getTestDatabase + ] where startTestDatabase = do db <- TmpPostgres.start >>= either throwIO return @@ -207,12 +207,15 @@ testSelectTestTable = databasePropertyTest "Can SELECT TestTable" \transaction - transaction do selected <- lift do - statement () $ Rel8.run_ $ Rel8.insert Rel8.Insert - { into = testTableSchema - , rows = Rel8.values $ map Rel8.lit rows - , onConflict = Rel8.DoNothing - , returning = Rel8.NoReturning - } + statement () $ + Rel8.run_ $ + Rel8.insert + Rel8.Insert + { into = testTableSchema + , rows = Rel8.values $ map Rel8.lit rows + , onConflict = Rel8.DoNothing + , returning = Rel8.NoReturning + } statement () $ Rel8.run $ Rel8.select do Rel8.each testTableSchema @@ -362,8 +365,11 @@ testOr = databasePropertyTest "OR (||.)" \transaction -> do transaction do result <- lift do - statement () $ Rel8.run1 $ Rel8.select $ pure $ - Rel8.lit x Rel8.||. Rel8.lit y + statement () $ + Rel8.run1 $ + Rel8.select $ + pure $ + Rel8.lit x Rel8.||. Rel8.lit y result === (x || y) @@ -497,14 +503,14 @@ testDBType getTestDatabase = 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.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 - diff res''' (==) [x, y] --} + {- + res''' <- lift 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 + diff res''' (==) [x, y] + -} genComposite :: Gen Composite genComposite = do @@ -600,14 +606,19 @@ testDBEq getTestDatabase = testTableEquality :: IO TmpPostgres.DB -> TestTree testTableEquality = databasePropertyTest "TestTable equality" \transaction -> do - (x, y) <- forAll $ liftA2 (,) genTestTable genTestTable - - transaction do - eq <- lift do - statement () $ Rel8.run1 $ Rel8.select do - pure $ Rel8.lit x Rel8.==: Rel8.lit y - - eq === (x == y) + (x, y) <- + forAll $ + liftA2 + (,) + genTestTable + genTestTable + transaction + do + eq <- lift do + statement () $ Rel8.run1 $ Rel8.select do + pure $ Rel8.lit x Rel8.==: Rel8.lit y + eq + === (x == y) testFromString :: IO TmpPostgres.DB -> TestTree @@ -745,33 +756,38 @@ testUpdate = databasePropertyTest "Can UPDATE TestTable" \transaction -> do transaction do selected <- lift do - statement () $ Rel8.run_ $ Rel8.insert Rel8.Insert - { into = testTableSchema - , rows = Rel8.values $ map Rel8.lit $ Map.keys rows - , onConflict = Rel8.DoNothing - , returning = Rel8.NoReturning - } - - statement () $ Rel8.run_ $ Rel8.update Rel8.Update - { target = testTableSchema - , from = pure () - , set = \_ r -> - let updates = map (bimap Rel8.lit Rel8.lit) $ Map.toList rows - in - foldl - ( \e (x, y) -> - Rel8.bool - e - y - ( testTableColumn1 r Rel8.==. testTableColumn1 x Rel8.&&. - testTableColumn2 r Rel8.==. testTableColumn2 x - ) - ) - r - updates - , updateWhere = \_ _ -> Rel8.lit True - , returning = Rel8.NoReturning - } + statement () $ + Rel8.run_ $ + Rel8.insert + Rel8.Insert + { into = testTableSchema + , rows = Rel8.values $ map Rel8.lit $ Map.keys rows + , onConflict = Rel8.DoNothing + , returning = Rel8.NoReturning + } + + statement () $ + Rel8.run_ $ + Rel8.update + Rel8.Update + { target = testTableSchema + , from = pure () + , set = \_ r -> + let updates = map (bimap Rel8.lit Rel8.lit) $ Map.toList rows + in foldl + ( \e (x, y) -> + Rel8.bool + e + y + ( testTableColumn1 r Rel8.==. testTableColumn1 x + Rel8.&&. testTableColumn2 r Rel8.==. testTableColumn2 x + ) + ) + r + updates + , updateWhere = \_ _ -> Rel8.lit True + , returning = Rel8.NoReturning + } statement () $ Rel8.run $ Rel8.select do Rel8.each testTableSchema @@ -789,19 +805,26 @@ testDelete = databasePropertyTest "Can DELETE TestTable" \transaction -> do transaction do (deleted, selected) <- lift do - statement () $ Rel8.run_ $ Rel8.insert Rel8.Insert - { into = testTableSchema - , rows = Rel8.values $ map Rel8.lit rows - , onConflict = Rel8.DoNothing - , returning = Rel8.NoReturning - } - - deleted <- statement () $ Rel8.run $ Rel8.delete Rel8.Delete - { from = testTableSchema - , using = pure () - , deleteWhere = const testTableColumn2 - , returning = Rel8.Returning id - } + statement () $ + Rel8.run_ $ + Rel8.insert + Rel8.Insert + { into = testTableSchema + , rows = Rel8.values $ map Rel8.lit rows + , onConflict = Rel8.DoNothing + , returning = Rel8.NoReturning + } + + deleted <- + statement () $ + Rel8.run $ + Rel8.delete + Rel8.Delete + { from = testTableSchema + , using = pure () + , deleteWhere = const testTableColumn2 + , returning = Rel8.Returning id + } selected <- statement () $ Rel8.run $ Rel8.select do Rel8.each testTableSchema @@ -813,14 +836,15 @@ testDelete = databasePropertyTest "Can DELETE TestTable" \transaction -> do testWithStatement :: IO TmpPostgres.DB -> TestTree testWithStatement genTestDatabase = - testGroup "WITH" + testGroup + "WITH" [ selectUnionInsert genTestDatabase , rowsAffectedNoReturning genTestDatabase , rowsAffectedReturing genTestDatabase , pureQuery genTestDatabase ] where - selectUnionInsert = + selectUnionInsert = databasePropertyTest "Can UNION results of SELECT with results of INSERT" \transaction -> do rows <- forAll $ Gen.list (Range.linear 0 50) genTestTable @@ -829,50 +853,54 @@ testWithStatement genTestDatabase = 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 - } + 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 = + 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 - } + Rel8.insert $ + Rel8.Insert + { into = testTableSchema + , rows = Rel8.values $ map Rel8.lit rows + , onConflict = Rel8.DoNothing + , returning = Rel8.NoReturning + } length rows === fromIntegral affected - rowsAffectedReturing = + 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 - } + 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 = + pureQuery = databasePropertyTest "Can read pure Query" \transaction -> do rows <- forAll $ Gen.list (Range.linear 0 50) genTestTable @@ -884,7 +912,6 @@ testWithStatement genTestDatabase = sort rows === sort rows' - data UniqueTable f = UniqueTable { uniqueTableKey :: Rel8.Column f Text , uniqueTableValue :: Rel8.Column f Text @@ -925,23 +952,31 @@ testUpsert = databasePropertyTest "Can UPSERT UniqueTable" \transaction -> do transaction do selected <- lift do - statement () $ Rel8.run_ $ Rel8.insert Rel8.Insert - { into = uniqueTableSchema - , rows = Rel8.values $ Rel8.lit <$> as - , onConflict = Rel8.DoNothing - , returning = Rel8.NoReturning - } - - statement () $ Rel8.run_ $ Rel8.insert Rel8.Insert - { into = uniqueTableSchema - , rows = Rel8.values $ Rel8.lit <$> bs - , onConflict = Rel8.DoUpdate Rel8.Upsert - { index = uniqueTableKey - , set = \UniqueTable {uniqueTableValue} old -> old {uniqueTableValue} - , updateWhere = \_ _ -> Rel8.true - } - , returning = Rel8.NoReturning - } + statement () $ + Rel8.run_ $ + Rel8.insert + Rel8.Insert + { into = uniqueTableSchema + , rows = Rel8.values $ Rel8.lit <$> as + , onConflict = Rel8.DoNothing + , returning = Rel8.NoReturning + } + + statement () $ + Rel8.run_ $ + Rel8.insert + Rel8.Insert + { into = uniqueTableSchema + , rows = Rel8.values $ Rel8.lit <$> bs + , onConflict = + Rel8.DoUpdate + Rel8.Upsert + { index = uniqueTableKey + , set = \UniqueTable{uniqueTableValue} old -> old{uniqueTableValue} + , updateWhere = \_ _ -> Rel8.true + } + , returning = Rel8.NoReturning + } statement () $ Rel8.run $ Rel8.select do Rel8.each uniqueTableSchema @@ -987,10 +1022,12 @@ testSelectArray = databasePropertyTest "Can SELECT Arrays (with aggregation)" \t selected' <- lift do statement () $ Rel8.run $ Rel8.select do - a <- Rel8.catListTable =<< do - Rel8.many $ Rel8.values (map Rel8.lit rows) - b <- Rel8.catListTable =<< do - Rel8.many $ Rel8.values (map Rel8.lit rows) + a <- + Rel8.catListTable =<< do + Rel8.many $ Rel8.values (map Rel8.lit rows) + b <- + Rel8.catListTable =<< do + Rel8.many $ Rel8.values (map Rel8.lit rows) pure (a, b) selected' === liftA2 (,) rows rows diff --git a/tests/Rel8/Generic/Rel8able/Test.hs b/tests/Rel8/Generic/Rel8able/Test.hs index 7ed279ac..58dc99f6 100644 --- a/tests/Rel8/Generic/Rel8able/Test.hs +++ b/tests/Rel8/Generic/Rel8able/Test.hs @@ -1,14 +1,14 @@ -{-# language DataKinds #-} -{-# language DeriveAnyClass #-} -{-# language DeriveGeneric #-} -{-# language DerivingStrategies #-} -{-# language DuplicateRecordFields #-} -{-# language FlexibleInstances #-} -{-# language MultiParamTypeClasses #-} -{-# language StandaloneKindSignatures #-} -{-# language TypeFamilies #-} -{-# language TypeOperators #-} -{-# language UndecidableInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} module Rel8.Generic.Rel8able.Test ( module Rel8.Generic.Rel8able.Test,