1- {-# language DeriveFunctor #-}
2- {-# language DerivingVia #-}
3- {-# language FlexibleContexts #-}
4- {-# language GADTs #-}
5- {-# language LambdaCase #-}
6- {-# language NamedFieldPuns #-}
7- {-# language RankNTypes #-}
8- {-# language RecordWildCards #-}
9- {-# language ScopedTypeVariables #-}
10- {-# language StandaloneKindSignatures #-}
11- {-# language TypeApplications #-}
12-
13- module Rel8.Statement
14- ( Statement
15- , statementReturning
16- , statementNoReturning
17- , ppDecodeStatement
18- )
1+ {-# LANGUAGE DeriveFunctor #-}
2+ {-# LANGUAGE DerivingVia #-}
3+ {-# LANGUAGE FlexibleContexts #-}
4+ {-# LANGUAGE GADTs #-}
5+ {-# LANGUAGE LambdaCase #-}
6+ {-# LANGUAGE NamedFieldPuns #-}
7+ {-# LANGUAGE RankNTypes #-}
8+ {-# LANGUAGE RecordWildCards #-}
9+ {-# LANGUAGE ScopedTypeVariables #-}
10+ {-# LANGUAGE StandaloneKindSignatures #-}
11+ {-# LANGUAGE TypeApplications #-}
12+
13+ module Rel8.Statement (
14+ Statement ,
15+ statementReturning ,
16+ statementNoReturning ,
17+ ppDecodeStatement ,
18+ )
1919where
2020
2121-- base
@@ -35,18 +35,18 @@ import qualified Hasql.Decoders as Hasql
3535import qualified Opaleye.Internal.Tag as Opaleye
3636
3737-- pretty
38- import Text.PrettyPrint
39- ( Doc
40- , (<+>)
41- , ($$)
42- , comma
43- , doubleQuotes
44- , hcat
45- , parens
46- , punctuate
47- , text
48- , vcat
49- )
38+ import Text.PrettyPrint (
39+ Doc ,
40+ comma ,
41+ doubleQuotes ,
42+ hcat ,
43+ parens ,
44+ punctuate ,
45+ text ,
46+ vcat ,
47+ ($$) ,
48+ (<+>) ,
49+ )
5050
5151-- rel8
5252import Rel8.Expr (Expr )
@@ -99,54 +99,55 @@ getResult = \case
9999type Returning :: Type
100100data Returning where
101101 NoReturning :: Returning
102- Returning :: Query (Expr Int64 ) -> Returning
103-
104-
105- -- | 'Statement' represents a single PostgreSQL statement. Most commonly,
106- -- this is constructed using 'Rel8.select', 'Rel8.insert', 'Rel8.update'
107- -- or 'Rel8.delete'.
108- --
109- -- However, in addition to @SELECT@, @INSERT@, @UPDATE@ and @DELETE@,
110- -- PostgreSQL also supports compositions thereof via its statement-level
111- -- @WITH@ syntax (with some caveats). Each such \"sub-statement\" can
112- -- reference the results of previous sub-statements. 'Statement' provides a
113- -- 'Monad' instance that captures this \"binding\" pattern.
114- --
115- -- The caveat with this is that the [side-effects of these sub-statements
116- -- are not visible to other sub-statements](https://www.postgresql.org/docs/current/queries-with.html#QUERIES-WITH-MODIFYING);
117- -- only the explicit results of previous sub-statements (from @SELECT@s or
118- -- @RETURNING@ clauses) are visible. So, for example, an @INSERT@ into a table
119- -- followed immediately by a @SELECT@ therefrom will not return the inserted
120- -- rows. However, it is possible to return the inserted rows using
121- -- @RETURNING@, 'Rel8.unionAll'ing this with the result of a @SELECT@
122- -- from the same table will produce the desired result.
123- --
124- -- An example of where this can be useful is if you want to delete rows from
125- -- a table and simultaneously log their deletion in a log table.
126- --
127- -- @
128- -- deleteFoo :: (Foo Expr -> Expr Bool) -> Statement ()
129- -- deleteFoo predicate = do
130- -- foos <-
131- -- delete Delete
132- -- { from = fooSchema
133- -- , using = pure ()
134- -- , deleteWhere = \_ -> predicate
135- -- , returning = Returning id
136- -- }
137- -- insert Insert
138- -- { into = deletedFooSchema
139- -- , rows = do
140- -- Foo {..} <- foos
141- -- let
142- -- deletedAt = 'Rel8.Expr.Time.now'
143- -- pure DeletedFoo {..}
144- -- , onConflict = Abort
145- -- , returning = NoReturning
146- -- }
147- -- @
148- newtype Statement a =
149- Statement (WriterT (Endo [Binding ]) (State Opaleye. TagResult a ))
102+ Returning :: Query (Expr Int64 ) -> Returning
103+
104+
105+ {- | 'Statement' represents a single PostgreSQL statement. Most commonly,
106+ this is constructed using 'Rel8.select', 'Rel8.insert', 'Rel8.update'
107+ or 'Rel8.delete'.
108+
109+ However, in addition to @SELECT@, @INSERT@, @UPDATE@ and @DELETE@,
110+ PostgreSQL also supports compositions thereof via its statement-level
111+ @WITH@ syntax (with some caveats). Each such \"sub-statement\" can
112+ reference the results of previous sub-statements. 'Statement' provides a
113+ 'Monad' instance that captures this \"binding\" pattern.
114+
115+ The caveat with this is that the [side-effects of these sub-statements
116+ are not visible to other sub-statements](https://www.postgresql.org/docs/current/queries-with.html#QUERIES-WITH-MODIFYING);
117+ only the explicit results of previous sub-statements (from @SELECT@s or
118+ @RETURNING@ clauses) are visible. So, for example, an @INSERT@ into a table
119+ followed immediately by a @SELECT@ therefrom will not return the inserted
120+ rows. However, it is possible to return the inserted rows using
121+ @RETURNING@, 'Rel8.unionAll'ing this with the result of a @SELECT@
122+ from the same table will produce the desired result.
123+
124+ An example of where this can be useful is if you want to delete rows from
125+ a table and simultaneously log their deletion in a log table.
126+
127+ @
128+ deleteFoo :: (Foo Expr -> Expr Bool) -> Statement ()
129+ deleteFoo predicate = do
130+ foos <-
131+ delete Delete
132+ { from = fooSchema
133+ , using = pure ()
134+ , deleteWhere = \_ -> predicate
135+ , returning = Returning id
136+ }
137+ insert Insert
138+ { into = deletedFooSchema
139+ , rows = do
140+ Foo {..} <- foos
141+ let
142+ deletedAt = 'Rel8.Expr.Time.now'
143+ pure DeletedFoo {..}
144+ , onConflict = Abort
145+ , returning = NoReturning
146+ }
147+ @
148+ -}
149+ newtype Statement a
150+ = Statement (WriterT (Endo [Binding ]) (State Opaleye. TagResult a ))
150151 deriving stock (Functor )
151152 deriving (Apply ) via WrappedApplicative Statement
152153
@@ -177,14 +178,16 @@ statementNoReturning pp = Statement $ do
177178 relation = Opaleye. tagWith tag " statement"
178179 columns = Nothing
179180 returning = NoReturning
180- binding = Binding {.. }
181+ binding = Binding {.. }
181182 pure binding
182183 tell (Endo (binding : ))
183184 pure $ Unmodified ()
184185
185186
186- statementReturning :: Table Expr a
187- => State Opaleye. TagDoc -> Statement (Query a )
187+ statementReturning ::
188+ Table Expr a =>
189+ State Opaleye. TagDoc ->
190+ Statement (Query a )
188191statementReturning pp = Statement $ do
189192 (binding, query) <- lift $ do
190193 doc <- pp
@@ -201,22 +204,26 @@ statementReturning pp = Statement $ do
201204 names = namesFromLabelsWithA symbol `evalState` Opaleye. start
202205 columns = Just $ showNames names
203206 query =
204- fromCols <$> each
205- TableSchema
206- { name = relation
207- , schema = Nothing
208- , columns = names
209- }
207+ fromCols
208+ <$> each
209+ TableSchema
210+ { name = relation
211+ , schema = Nothing
212+ , columns = names
213+ }
210214 returning = Returning (countRows query)
211- binding = Binding {.. }
215+ binding = Binding {.. }
212216 pure (binding, query)
213217 tell (Endo (binding : ))
214218 pure $ Unmodified query
215219
216220
217- ppDecodeStatement :: ()
218- => (forall x . Table Expr x => Query x -> State Opaleye. TagDoc )
219- -> Rows exprs a -> Statement exprs -> (Doc , Hasql. Resulta )
221+ ppDecodeStatement ::
222+ () =>
223+ (forall x . Table Expr x => Query x -> State Opaleye. TagDoc ) ->
224+ Rows exprs a ->
225+ Statement exprs ->
226+ (Doc , Hasql. Resulta )
220227ppDecodeStatement ppSelect rows (Statement m) = evalState go Opaleye. start
221228 where
222229 go = do
@@ -243,7 +250,7 @@ ppDecodeStatement ppSelect rows (Statement m) = evalState go Opaleye.start
243250 Vector @ exprs @ a -> do
244251 doc <- ppSelect (getResult result)
245252 pure (doc, Hasql. rowVector (parse @ exprs @ a ))
246- Just (bindings, binding@ Binding {doc = after}) -> case rows of
253+ Just (bindings, binding@ Binding {doc = after}) -> case rows of
247254 Void -> pure (doc, Hasql. noResult)
248255 where
249256 doc = ppWith bindings after
@@ -255,7 +262,7 @@ ppDecodeStatement ppSelect rows (Statement m) = evalState go Opaleye.start
255262 Modified _ -> case returning binding of
256263 NoReturning -> pure (doc, Hasql. rowsAffected)
257264 where
258- doc = ppWith bindings after
265+ doc = ppWith bindings after
259266 Returning query -> do
260267 doc <- ppWith bindings' <$> ppSelect query
261268 pure (doc, Hasql. singleRow parse)
@@ -299,20 +306,20 @@ ppWith bindings after = pre $$ after
299306 pre = case bindings of
300307 [] -> mempty
301308 _ ->
302- text " WITH" <+>
303- vcat (punctuate comma (map go bindings))
304- go binding@ Binding {doc = before} =
305- ppAlias binding $$
306- text " AS" <+>
307- parens before
309+ text " WITH"
310+ <+> vcat (punctuate comma (map go bindings))
311+ go binding@ Binding {doc = before} =
312+ ppAlias binding
313+ $$ text " AS"
314+ <+> parens before
308315
309316
310317ppAlias :: Binding -> Doc
311- ppAlias Binding {relation, columns = mcolumns} = case mcolumns of
318+ ppAlias Binding {relation, columns = mcolumns} = case mcolumns of
312319 Nothing -> escape relation
313- Just columns ->
314- escape relation <+>
315- parens (hcat (punctuate comma (escape <$> toList columns)))
320+ Just columns ->
321+ escape relation
322+ <+> parens (hcat (punctuate comma (escape <$> toList columns)))
316323
317324
318325escape :: String -> Doc
0 commit comments