Skip to content

Commit

Permalink
Format
Browse files Browse the repository at this point in the history
  • Loading branch information
@ocharles
ocharles committed Jul 7, 2023
1 parent cbb5e95 commit cc0014d
Show file tree
Hide file tree
Showing 16 changed files with 581 additions and 507 deletions.
5 changes: 2 additions & 3 deletions rel8.cabal
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -144,7 +144,6 @@ library
Rel8.Schema.Result
Rel8.Schema.Spec
Rel8.Schema.Table

Rel8.Statement
Rel8.Statement.Delete
Rel8.Statement.Insert
Expand Down
57 changes: 29 additions & 28 deletions src/Rel8.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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,
Expand All @@ -447,13 +449,12 @@ module Rel8 (
update,
showUpdate,

-- ** @WITH@
, Statement
, showStatement
-- ** @.. RETURNING@
Returning (..),

-- ** @CREATE VIEW@
, createView
, createOrReplaceView
-- ** @WITH@
Statement,
showStatement,

-- ** @CREATE VIEW@
createView,
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down
213 changes: 110 additions & 103 deletions src/Rel8/Statement.hs
View file
Original file line number Diff line number Diff line change
@@ -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
Expand All @@ -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)
Expand Down Expand Up @@ -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

Expand Down Expand Up @@ -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
Expand All @@ -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
Expand All @@ -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
Expand All @@ -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)
Expand Down Expand Up @@ -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
Expand Down
Loading

0 comments on commit cc0014d

Please sign in to comment.