5d2b9e4 · rel8 · git.iko.soy

docs/concepts/insert.rst+37−10

compare with master

unifiedsplit

@@ -21,9 +21,16 @@ using ``delete``. ``Delete`` takes:

21``from``

22 The ``TableSchema`` for the table to delete rows from.

23

24+``using``

25+ This is a simple ``Query`` that forms the ``USING`` clause of the ``DELETE``

26+ statement. This can be used to join against other tables, and the results

27+ can be referenced in the ``deleteWhere`` parameter. For simple ``DELETE``\s

28+ where you don't need to do this, you can set ``using = pure ()``.

29+

24``deleteWhere``

30``deleteWhere``

25 The ``WHERE`` clause of the ``DELETE`` statement. This is a function that

31 The ``WHERE`` clause of the ``DELETE`` statement. This is a function that

26− takes a single ``Expr`` table as input.

32+ takes two inputs: the result of the ``using`` query, and the current value

33+ of the row.

27

34

28``returning``

35``returning``

29 What to return - see :ref:`returning`.

36 What to return - see :ref:`returning`.

@@ -37,16 +44,23 @@ using ``update``. ``Update`` takes:

37``target``

44``target``

38 The ``TableSchema`` for the table to update rows in.

45 The ``TableSchema`` for the table to update rows in.

39

46

40−``updateWhere``

47+``from``

41− The ``WHERE`` clause of the ``UPDATE`` statement. This is a function that

48+ This is a simple ``Query`` that forms the ``FROM`` clause of the ``UPDATE``

42− takes a single ``Expr`` table as input.

49+ statement. This can be used to join against other tables, and the results

50+ can be referenced in the ``set`` and ``updateWhere`` parameters. For simple

51+ ``UPDATE``\s where you don't need to do this, you can set ``from = pure ()``.

43

52

44``set``

53``set``

45 A row to row transformation function, indicating how to update selected rows.

54 A row to row transformation function, indicating how to update selected rows.

46 This function takes rows of the same shape as ``target`` but in the ``Expr``

55 This function takes rows of the same shape as ``target`` but in the ``Expr``

47 context. One way to write this function is to use record update syntax::

56 context. One way to write this function is to use record update syntax::

48

57

49− set = \row -> row { rowName = "new name" }

58+ set = \from row -> row { rowName = "new name" }

59+

60+``updateWhere``

61+ The ``WHERE`` clause of the ``UPDATE`` statement. This is a function that

62+ takes two inputs: the result of the ``from`` query, and the current value of

63+ the row.

50

64

51``returning``

65``returning``

52 What to return - see :ref:`returning`.

66 What to return - see :ref:`returning`.

@@ -64,11 +78,11 @@ using ``insert``. ``Insert`` takes:

64 The rows to insert. These are the same as ``into``, but in the ``Expr``

78 The rows to insert. These are the same as ``into``, but in the ``Expr``

65 context. You can construct rows from their individual fields::

79 context. You can construct rows from their individual fields::

66

80

67− rows = [ MyTable { myTableA = lit "A", myTableB = lit 42 }

81+ rows = values [ MyTable { myTableA = lit "A", myTableB = lit 42 }

68

82

69 or you can use ``lit`` on a table value in the ``Result`` context::

83 or you can use ``lit`` on a table value in the ``Result`` context::

70

84

71− rows = [ lit MyTable { myTableA = "A", myTableB = 42 }

85+ rows = values [ lit MyTable { myTableA = "A", myTableB = 42 }

72

86

73``onConflict``

87``onConflict``

74 What should happen if an insert clashes with rows that already exist. This

88 What should happen if an insert clashes with rows that already exist. This

@@ -80,6 +94,10 @@ using ``insert``. ``Insert`` takes:

80 ``DoNothing``

94 ``DoNothing``

81 PostgreSQL should not insert the duplicate rows.

95 PostgreSQL should not insert the duplicate rows.

82

96

97+ ``DoUpdate``

98+ PostgreSQL should instead try to update any existing rows that conflict

99+ with rows proposed for insertion.

100+

83``returning``

101``returning``

84 What to return - see :ref:`returning`.

102 What to return - see :ref:`returning`.

85

103

@@ -99,11 +117,20 @@ For example, if we are inserting orders, we might want the order ids returned::

99

117

100 insert Insert

118 insert Insert

101 { into = orderSchema

119 { into = orderSchema

102− , rows = [ order ]

120+ , rows = values [ order ]

103 , onConflict = Abort

121 , onConflict = Abort

104 , returning = Projection orderId

122 , returning = Projection orderId

105 }

123 }

106

124

125+If we don't want to return anything, we can use ``pure ()``::

126+

127+ insert Insert

128+ { into = orderSchema

129+ , rows = values [ order ]

130+ , onConflict = Abort

131+ , returning = pure ()

132+ }

133+

107Default values

134Default values

108--------------

135--------------

109

136

@@ -119,7 +146,7 @@ construct the ``DEFAULT`` expression::

119

146

120 insert Insert

147 insert Insert

121 { into = orderSchema

148 { into = orderSchema

122− , rows = [ Order { orderId = unsafeDefault, ... } ]

149+ , rows = values [ Order { orderId = unsafeDefault, ... } ]

123 , onConflict = Abort

150 , onConflict = Abort

124 , returning = Projection orderId

151 , returning = Projection orderId

125 }

152 }

@@ -148,7 +175,7 @@ them in Rel8, rather than in your database schema.

148

175

149 insert Insert

176 insert Insert

150 { into = orderSchema

177 { into = orderSchema

151− , rows = [ Order { orderId = nextval "order_id_seq", ... } ]

178+ , rows = values [ Order { orderId = nextval "order_id_seq", ... } ]

152 , onConflict = Abort

179 , onConflict = Abort

153 , returning = Projection orderId

180 , returning = Projection orderId

154 }

181 }

rel8.cabal+6

@@ -27,6 +27,7 @@ library

27 , contravariant

28 , hasql ^>= 1.4.5.1

29 , opaleye ^>= 0.7.3.0

30+ , pretty

30 , profunctors

31 , profunctors

31 , scientific

32 , scientific

32 , semialign

33 , semialign

@@ -138,10 +139,15 @@ library

138

139

139 Rel8.Statement.Delete

140 Rel8.Statement.Delete

140 Rel8.Statement.Insert

141 Rel8.Statement.Insert

142+ Rel8.Statement.OnConflict

141 Rel8.Statement.Returning

143 Rel8.Statement.Returning

142 Rel8.Statement.Select

144 Rel8.Statement.Select

145+ Rel8.Statement.Set

146+ Rel8.Statement.SQL

143 Rel8.Statement.Update

147 Rel8.Statement.Update

148+ Rel8.Statement.Using

144 Rel8.Statement.View

149 Rel8.Statement.View

150+ Rel8.Statement.Where

145

151

146 Rel8.Table

152 Rel8.Table

147 Rel8.Table.ADT

153 Rel8.Table.ADT

src/Rel8.hs+9

@@ -244,6 +244,9 @@ module Rel8

244 , nullsFirst

245 , nullsLast

246

247+ -- ** Bindings

248+ , rebind

249+

247 -- * IO

250 -- * IO

248 , Serializable

251 , Serializable

249 , ToExprs

252 , ToExprs

@@ -258,16 +261,20 @@ module Rel8

258 -- ** @INSERT@

261 -- ** @INSERT@

259 , Insert(..)

262 , Insert(..)

260 , OnConflict(..)

263 , OnConflict(..)

264+ , Upsert(..)

261 , insert

265 , insert

262 , unsafeDefault

266 , unsafeDefault

267+ , showInsert

263

268

264 -- ** @DELETE@

269 -- ** @DELETE@

265 , Delete(..)

270 , Delete(..)

266 , delete

271 , delete

272+ , showDelete

267

273

268 -- ** @UPDATE@

274 -- ** @UPDATE@

269 , Update(..)

275 , Update(..)

270 , update

276 , update

277+ , showUpdate

271

278

272 -- ** @.. RETURNING@

279 -- ** @.. RETURNING@

273 , Returning(..)

280 , Returning(..)

@@ -332,8 +339,10 @@ import Rel8.Schema.Result ( Result )

332import Rel8.Schema.Table

339import Rel8.Schema.Table

333import Rel8.Statement.Delete

340import Rel8.Statement.Delete

334import Rel8.Statement.Insert

341import Rel8.Statement.Insert

342+import Rel8.Statement.OnConflict

335import Rel8.Statement.Returning

343import Rel8.Statement.Returning

336import Rel8.Statement.Select

344import Rel8.Statement.Select

345+import Rel8.Statement.SQL

337import Rel8.Statement.Update

346import Rel8.Statement.Update

338import Rel8.Statement.View

347import Rel8.Statement.View

339import Rel8.Table

348import Rel8.Table

src/Rel8/Query/SQL.hs+5−59

@@ -1,75 +1,21 @@

1{-# language FlexibleContexts #-}

2−{-# language TypeFamilies #-}

2+{-# language MonoLocalBinds #-}

3−{-# language ViewPatterns #-}

4

3

5module Rel8.Query.SQL

4module Rel8.Query.SQL

6 ( showQuery

5 ( showQuery

7− , sqlForQuery, sqlForQueryWithNames

8 )

6 )

9where

7where

10

8

11-- base

9-- base

12−import Data.Foldable ( fold )

13−import Data.Functor.Const ( Const( Const ), getConst )

14−import Data.Void ( Void )

15import Prelude

10import Prelude

16

11

17−-- opaleye

18−import qualified Opaleye.Internal.HaskellDB.Sql as Opaleye

19−import qualified Opaleye.Internal.PrimQuery as Opaleye

20−import qualified Opaleye.Internal.Print as Opaleye

21−import qualified Opaleye.Internal.Optimize as Opaleye

22−import qualified Opaleye.Internal.QueryArr as Opaleye hiding ( Select )

23−import qualified Opaleye.Internal.Sql as Opaleye

24−

25-- rel8

12-- rel8

26import Rel8.Expr ( Expr )

13import Rel8.Expr ( Expr )

27−import Rel8.Expr.Opaleye ( toPrimExpr )

28import Rel8.Query ( Query )

14import Rel8.Query ( Query )

29−import Rel8.Query.Opaleye ( toOpaleye )

15+import Rel8.Statement.Select ( ppSelect )

30−import Rel8.Schema.Name ( Name( Name ), Selects )

31−import Rel8.Schema.HTable ( htabulateA, hfield )

32−import Rel8.Table ( Table, toColumns )

16+import Rel8.Table ( Table )

33−import Rel8.Table.Cols ( toCols )

34−import Rel8.Table.Name ( namesFromLabels )

35−import Rel8.Table.Opaleye ( castTable )

36

17

37

18

38−-- | Convert a query to a 'String' containing the query as a @SELECT@

19+-- | Convert a 'Query' to a 'String' containing a @SELECT@ statement.

39−-- statement.

40showQuery :: Table Expr a => Query a -> String

20showQuery :: Table Expr a => Query a -> String

41−showQuery = fold . sqlForQuery

21+showQuery = foldMap show . ppSelect

42−

43−

44−sqlForQuery :: Table Expr a

45− => Query a -> Maybe String

46−sqlForQuery = sqlForQueryWithNames namesFromLabels . fmap toCols

47−

48−

49−sqlForQueryWithNames :: Selects names exprs

50− => names -> Query exprs -> Maybe String

51−sqlForQueryWithNames names query =

52− show . Opaleye.ppSql . selectFrom names exprs <$> optimize primQuery

53− where

54− (exprs, primQuery, _) =

55− Opaleye.runSimpleQueryArrStart (toOpaleye query) ()

56−

57−

58−optimize :: Opaleye.PrimQuery' a -> Maybe (Opaleye.PrimQuery' Void)

59−optimize = Opaleye.removeEmpty . Opaleye.optimize

60−

61−

62−selectFrom :: Selects names exprs

63− => names -> exprs -> Opaleye.PrimQuery' Void -> Opaleye.Select

64−selectFrom (toColumns -> names) (toColumns . castTable -> exprs) query =

65− Opaleye.SelectFrom $ Opaleye.newSelect

66− { Opaleye.attrs = Opaleye.SelectAttrs attributes

67− , Opaleye.tables = Opaleye.oneTable select

68− }

69− where

70− select = Opaleye.foldPrimQuery Opaleye.sqlQueryGenerator query

71− attributes = getConst $ htabulateA $ \field -> case hfield names field of

72− Name name -> case hfield exprs field of

73− expr -> Const (pure (makeAttr name (toPrimExpr expr)))

74− makeAttr label expr =

75− (Opaleye.sqlExpr expr, Just (Opaleye.SqlColumn label))

src/Rel8/Schema/Name.hs+12

@@ -13,6 +13,7 @@

13module Rel8.Schema.Name

14 ( Name(..)

15 , Selects

16+ , ppColumn

16 )

17 )

17where

18where

18

19

@@ -22,6 +23,13 @@ import Data.Kind ( Constraint, Type )

22import Data.String ( IsString )

23import Data.String ( IsString )

23import Prelude

24import Prelude

24

25

26+-- opaleye

27+import qualified Opaleye.Internal.HaskellDB.Sql as Opaleye

28+import qualified Opaleye.Internal.HaskellDB.Sql.Print as Opaleye

29+

30+-- pretty

31+import Text.PrettyPrint ( Doc )

32+

25-- rel8

33-- rel8

26import Rel8.Expr ( Expr )

34import Rel8.Expr ( Expr )

27import qualified Rel8.Schema.Kind as K

35import qualified Rel8.Schema.Kind as K

@@ -63,3 +71,7 @@ instance Sql DBType a => Table Name (Name a) where

63type Selects :: Type -> Type -> Constraint

71type Selects :: Type -> Type -> Constraint

64class Transposes Name Expr names exprs => Selects names exprs

72class Transposes Name Expr names exprs => Selects names exprs

65instance Transposes Name Expr names exprs => Selects names exprs

73instance Transposes Name Expr names exprs => Selects names exprs

74+

75+

76+ppColumn :: String -> Doc

77+ppColumn = Opaleye.ppSqlExpr . Opaleye.ColumnSqlExpr . Opaleye.SqlColumn

src/Rel8/Schema/Table.hs+17

@@ -1,14 +1,24 @@

1{-# language DeriveFunctor #-}

2{-# language DerivingStrategies #-}

3+{-# language DisambiguateRecordFields #-}

4+{-# language NamedFieldPuns #-}

3

5

4module Rel8.Schema.Table

6module Rel8.Schema.Table

5 ( TableSchema(..)

7 ( TableSchema(..)

8+ , ppTable

6 )

9 )

7where

10where

8

11

9-- base

12-- base

10import Prelude

13import Prelude

11

14

15+-- opaleye

16+import qualified Opaleye.Internal.HaskellDB.Sql as Opaleye

17+import qualified Opaleye.Internal.HaskellDB.Sql.Print as Opaleye

18+

19+-- pretty

20+import Text.PrettyPrint ( Doc )

21+

12

22

13-- | The schema for a table. This is used to specify the name and schema that a

23-- | The schema for a table. This is used to specify the name and schema that a

14-- table belongs to (the @FROM@ part of a SQL query), along with the schema of

24-- table belongs to (the @FROM@ part of a SQL query), along with the schema of

@@ -27,3 +37,10 @@ data TableSchema names = TableSchema

27 -- data type here, parameterized by the 'Rel8.ColumnSchema.ColumnSchema' functor.

37 -- data type here, parameterized by the 'Rel8.ColumnSchema.ColumnSchema' functor.

28 }

38 }

29 deriving stock Functor

39 deriving stock Functor

40+

41+

42+ppTable :: TableSchema a -> Doc

43+ppTable TableSchema {name, schema} = Opaleye.ppTable Opaleye.SqlTable

44+ { sqlTableSchemaName = schema

45+ , sqlTableName = name

46+ }

src/Rel8/Statement/Delete.hs+34−40

@@ -1,13 +1,15 @@

1{-# language DuplicateRecordFields #-}

2{-# language GADTs #-}

3{-# language NamedFieldPuns #-}

4−{-# language ScopedTypeVariables #-}

4+{-# language RankNTypes #-}

5+{-# language RecordWildCards #-}

5{-# language StandaloneKindSignatures #-}

6{-# language StandaloneKindSignatures #-}

6−{-# language TypeApplications #-}

7+{-# language StrictData #-}

7

8

8module Rel8.Statement.Delete

9module Rel8.Statement.Delete

9 ( Delete(..)

10 ( Delete(..)

10 , delete

11 , delete

12+ , ppDelete

11 )

13 )

12where

14where

13

15

@@ -18,23 +20,24 @@ import Prelude

18

20

19-- hasql

21-- hasql

20import Hasql.Connection ( Connection )

22import Hasql.Connection ( Connection )

21−import qualified Hasql.Decoders as Hasql

22import qualified Hasql.Encoders as Hasql

23import qualified Hasql.Encoders as Hasql

23import qualified Hasql.Session as Hasql

24import qualified Hasql.Session as Hasql

24import qualified Hasql.Statement as Hasql

25import qualified Hasql.Statement as Hasql

25

26

26−-- opaleye

27+-- pretty

27−import qualified Opaleye.Internal.Manipulation as Opaleye

28+import Text.PrettyPrint ( Doc, (<+>), ($$), text )

28

29

29-- rel8

30-- rel8

30import Rel8.Expr ( Expr )

31import Rel8.Expr ( Expr )

31−import Rel8.Expr.Opaleye ( toColumn, toPrimExpr )

32+import Rel8.Query ( Query )

32import Rel8.Schema.Name ( Selects )

33import Rel8.Schema.Name ( Selects )

33−import Rel8.Schema.Table ( TableSchema )

34+import Rel8.Schema.Table ( TableSchema, ppTable )

34−import Rel8.Statement.Returning ( Returning( NumberOfRowsAffected, Projection ) )

35+import Rel8.Statement.Returning

35−import Rel8.Table.Cols ( fromCols, toCols )

36+ ( Returning

36−import Rel8.Table.Opaleye ( castTable, table, unpackspec )

37+ , decodeReturning, emptyReturning, ppReturning

37−import Rel8.Table.Serialize ( Serializable, parse )

38+ )

39+import Rel8.Statement.Using ( ppUsing )

40+import Rel8.Statement.Where ( ppWhere )

38

41

39-- text

42-- text

40import qualified Data.Text as Text

43import qualified Data.Text as Text

@@ -47,7 +50,10 @@ data Delete a where

47 Delete :: Selects names exprs =>

50 Delete :: Selects names exprs =>

48 { from :: TableSchema names

51 { from :: TableSchema names

49 -- ^ Which table to delete from.

52 -- ^ Which table to delete from.

53+ , using :: Query using

54+ -- ^ @USING@ clause — this can be used to join against other tables,

55+ -- and its results can be referenced in the @WHERE@ clause

50− , deleteWhere :: exprs -> Expr Bool

56+ , deleteWhere :: using -> exprs -> Expr Bool

51 -- ^ Which rows should be selected for deletion.

57 -- ^ Which rows should be selected for deletion.

52 , returning :: Returning names a

58 , returning :: Returning names a

53 -- ^ What to return from the @DELETE@ statement.

59 -- ^ What to return from the @DELETE@ statement.

@@ -55,38 +61,26 @@ data Delete a where

55 -> Delete a

61 -> Delete a

56

62

57

63

58−-- | Run a @DELETE@ statement.

64+ppDelete :: Delete a -> Maybe Doc

59−delete :: Connection -> Delete a -> IO a

65+ppDelete Delete {..} = do

60−delete c Delete {from, deleteWhere, returning} =

66+ (usingDoc, i) <- ppUsing using

61− case returning of

67+ pure $ text "DELETE FROM" <+> ppTable from

62− NumberOfRowsAffected -> Hasql.run session c >>= either throwIO pure

68+ $$ usingDoc

63− where

69+ $$ ppWhere from (deleteWhere i)

64− session = Hasql.statement () statement

70+ $$ ppReturning from returning

65− statement = Hasql.Statement bytes params decode prepare

66− bytes = encodeUtf8 $ Text.pack sql

67− params = Hasql.noParams

68− decode = Hasql.rowsAffected

69− prepare = False

70− sql = Opaleye.arrangeDeleteSql from' where'

71− where

72− from' = table $ toCols <$> from

73− where' = toColumn . toPrimExpr . deleteWhere . fromCols

74

71

72+

73+-- | Run a 'Delete' statement.

74+delete :: Connection -> Delete a -> IO a

75+delete connection d@Delete {returning} =

76+ case show <$> ppDelete d of

77+ Nothing -> pure (emptyReturning returning)

78+ Just sql ->

75− Projection project -> Hasql.run session c >>= either throwIO pure

79+ Hasql.run session connection >>= either throwIO pure

76 where

80 where

77 session = Hasql.statement () statement

81 session = Hasql.statement () statement

78 statement = Hasql.Statement bytes params decode prepare

82 statement = Hasql.Statement bytes params decode prepare

79 bytes = encodeUtf8 $ Text.pack sql

83 bytes = encodeUtf8 $ Text.pack sql

80 params = Hasql.noParams

84 params = Hasql.noParams

81− decode = decoder project

85+ decode = decodeReturning returning

82 prepare = False

86 prepare = False

83− sql =

84− Opaleye.arrangeDeleteReturningSql unpackspec from' where' project'

85− where

86− from' = table $ toCols <$> from

87− where' = toColumn . toPrimExpr . deleteWhere . fromCols

88− project' = castTable . toCols . project . fromCols

89− where

90− decoder :: forall exprs projection a. Serializable projection a

91− => (exprs -> projection) -> Hasql.Result [a]

92− decoder _ = Hasql.rowList (parse @projection @a)

src/Rel8/Statement/Insert.hs+46−65

@@ -1,64 +1,65 @@

1{-# language DuplicateRecordFields #-}

2+{-# language FlexibleContexts #-}

2{-# language GADTs #-}

3{-# language GADTs #-}

3{-# language NamedFieldPuns #-}

4{-# language NamedFieldPuns #-}

4−{-# language ScopedTypeVariables #-}

5+{-# language RecordWildCards #-}

5{-# language StandaloneKindSignatures #-}

6{-# language StandaloneKindSignatures #-}

6−{-# language TypeApplications #-}

7+{-# language StrictData #-}

7

8

8module Rel8.Statement.Insert

9module Rel8.Statement.Insert

9 ( Insert(..)

10 ( Insert(..)

10− , OnConflict(..)

11 , insert

12+ , ppInsert

13+ , ppInto

12 )

14 )

13where

15where

14

16

15-- base

17-- base

16import Control.Exception ( throwIO )

18import Control.Exception ( throwIO )

17−import Data.List.NonEmpty ( NonEmpty( (:|) ) )

19+import Data.Foldable ( toList )

18import Data.Kind ( Type )

20import Data.Kind ( Type )

19import Prelude

21import Prelude

20

22

21-- hasql

23-- hasql

22import Hasql.Connection ( Connection )

24import Hasql.Connection ( Connection )

23−import qualified Hasql.Decoders as Hasql

24import qualified Hasql.Encoders as Hasql

25import qualified Hasql.Encoders as Hasql

25import qualified Hasql.Session as Hasql

26import qualified Hasql.Session as Hasql

26import qualified Hasql.Statement as Hasql

27import qualified Hasql.Statement as Hasql

27

28

28-- opaleye

29-- opaleye

29−import qualified Opaleye.Internal.Manipulation as Opaleye

30+import qualified Opaleye.Internal.HaskellDB.Sql.Print as Opaleye

30−import qualified Opaleye.Manipulation as Opaleye

31+

32+-- pretty

33+import Text.PrettyPrint ( Doc, (<+>), ($$), parens, text )

31

34

32-- rel8

35-- rel8

36+import Rel8.Query ( Query )

33−import Rel8.Schema.Name ( Selects )

37+import Rel8.Schema.Name ( Name, Selects, ppColumn )

34−import Rel8.Schema.Table ( TableSchema )

38+import Rel8.Schema.Table ( TableSchema(..), ppTable )

35−import Rel8.Statement.Returning ( Returning( Projection, NumberOfRowsAffected ) )

39+import Rel8.Statement.OnConflict ( OnConflict, ppOnConflict )

36−import Rel8.Table.Cols ( fromCols, toCols )

40+import Rel8.Statement.Returning

41+ ( Returning

42+ , decodeReturning, emptyReturning, ppReturning

43+ )

44+import Rel8.Statement.Select ( ppSelect )

37−import Rel8.Table.Opaleye ( castTable, table, unpackspec )

45+import Rel8.Table ( Table )

38−import Rel8.Table.Serialize ( Serializable, parse )

46+import Rel8.Table.Name ( showNames )

39

47

40-- text

48-- text

41import qualified Data.Text as Text ( pack )

49import qualified Data.Text as Text ( pack )

42import Data.Text.Encoding ( encodeUtf8 )

50import Data.Text.Encoding ( encodeUtf8 )

43

51

44

52

45−-- | @OnConflict@ allows you to add an @ON CONFLICT@ clause to an @INSERT@

46−-- statement.

47−type OnConflict :: Type

48−data OnConflict

49− = Abort -- ^ @ON CONFLICT ABORT@

50− | DoNothing -- ^ @ON CONFLICT DO NOTHING@

51−

52−

53-- | The constituent parts of a SQL @INSERT@ statement.

54type Insert :: Type -> Type

55data Insert a where

56 Insert :: Selects names exprs =>

57 { into :: TableSchema names

58 -- ^ Which table to insert into.

59− , rows :: [exprs]

59+ , rows :: Query exprs

60− -- ^ The rows to insert.

60+ -- ^ The rows to insert. This can be an arbitrary query — use

61+ -- 'Rel8.values' insert a static list of rows.

61− , onConflict :: OnConflict

62+ , onConflict :: OnConflict names

62 -- ^ What to do if the inserted rows conflict with data already in the

63 -- ^ What to do if the inserted rows conflict with data already in the

63 -- table.

64 -- table.

64 , returning :: Returning names a

65 , returning :: Returning names a

@@ -67,52 +68,32 @@ data Insert a where

67 -> Insert a

68 -> Insert a

68

69

70

70−-- | Run an @INSERT@ statement

71+ppInsert :: Insert a -> Maybe Doc

71−insert :: Connection -> Insert a -> IO a

72+ppInsert Insert {..} = do

72−insert c Insert {into, rows, onConflict, returning} =

73+ rows' <- ppSelect rows

73− case (rows, returning) of

74+ pure $ text "INSERT INTO" <+> ppInto into

74− ([], NumberOfRowsAffected) -> pure 0

75+ $$ rows'

75− ([], Projection _) -> pure []

76+ $$ ppOnConflict into onConflict

77+ $$ ppReturning into returning

76

78

77− (x:xs, NumberOfRowsAffected) -> Hasql.run session c >>= either throwIO pure

78− where

79− session = Hasql.statement () statement

80− statement = Hasql.Statement bytes params decode prepare

81− bytes = encodeUtf8 $ Text.pack sql

82− params = Hasql.noParams

83− decode = Hasql.rowsAffected

84− prepare = False

85− sql = Opaleye.arrangeInsertManySql into' rows' onConflict'

86− where

87− into' = table $ toCols <$> into

88− rows' = toCols <$> x :| xs

89

79

80+ppInto :: Table Name a => TableSchema a -> Doc

81+ppInto table@TableSchema {columns} =

82+ ppTable table <+>

83+ parens (Opaleye.commaV ppColumn (toList (showNames columns)))

84+

85+

86+-- | Run an 'Insert' statement.

87+insert :: Connection -> Insert a -> IO a

88+insert connection i@Insert {returning} =

89+ case show <$> ppInsert i of

90+ Nothing -> pure (emptyReturning returning)

91+ Just sql ->

90− (x:xs, Projection project) -> Hasql.run session c >>= either throwIO pure

92+ Hasql.run session connection >>= either throwIO pure

91 where

93 where

92 session = Hasql.statement () statement

94 session = Hasql.statement () statement

93 statement = Hasql.Statement bytes params decode prepare

95 statement = Hasql.Statement bytes params decode prepare

94 bytes = encodeUtf8 $ Text.pack sql

96 bytes = encodeUtf8 $ Text.pack sql

95 params = Hasql.noParams

97 params = Hasql.noParams

96− decode = decoder project

98+ decode = decodeReturning returning

97 prepare = False

99 prepare = False

98− sql =

99− Opaleye.arrangeInsertManyReturningSql

100− unpackspec

101− into'

102− rows'

103− project'

104− onConflict'

105− where

106− into' = table $ toCols <$> into

107− rows' = toCols <$> x :| xs

108− project' = castTable . toCols . project . fromCols

109−

110− where

111− onConflict' =

112− case onConflict of

113− DoNothing -> Just Opaleye.DoNothing

114− Abort -> Nothing

115−

116− decoder :: forall exprs projection a. Serializable projection a

117− => (exprs -> projection) -> Hasql.Result [a]

118− decoder _ = Hasql.rowList (parse @projection @a)

src/Rel8/Statement/OnConflict.hsnew file+106

@@ -0,0 +1,106 @@

1+{-# language DuplicateRecordFields #-}

2+{-# language FlexibleContexts #-}

3+{-# language GADTs #-}

4+{-# language LambdaCase #-}

5+{-# language NamedFieldPuns #-}

6+{-# language RecordWildCards #-}

7+{-# language StandaloneKindSignatures #-}

8+{-# language StrictData #-}

9+

10+module Rel8.Statement.OnConflict

11+ ( OnConflict(..)

12+ , Upsert(..)

13+ , ppOnConflict

14+ )

15+where

16+

17+-- base

18+import Data.Foldable ( toList )

19+import Data.Kind ( Type )

20+import Prelude

21+

22+-- opaleye

23+import qualified Opaleye.Internal.HaskellDB.Sql.Print as Opaleye

24+

25+-- pretty

26+import Text.PrettyPrint ( Doc, (<+>), ($$), parens, text )

27+

28+-- rel8

29+import Rel8.Expr ( Expr )

30+import Rel8.Schema.Name ( Name, Selects, ppColumn )

31+import Rel8.Schema.Table ( TableSchema(..) )

32+import Rel8.Statement.Set ( ppSet )

33+import Rel8.Statement.Where ( ppWhere )

34+import Rel8.Table ( Table, toColumns )

35+import Rel8.Table.Cols ( Cols( Cols ) )

36+import Rel8.Table.Name ( showNames )

37+import Rel8.Table.Opaleye ( attributes )

38+import Rel8.Table.Projection ( Projecting, Projection, apply )

39+

40+

41+-- | 'OnConflict' represents the @ON CONFLICT@ clause of an @INSERT@

42+-- statement. This specifies what ought to happen when one or more of the

43+-- rows proposed for insertion conflict with an existing row in the table.

44+type OnConflict :: Type -> Type

45+data OnConflict names

46+ = Abort

47+ -- ^ Abort the transaction if there are conflicting rows (Postgres' default)

48+ | DoNothing

49+ -- ^ @ON CONFLICT DO NOTHING@

50+ | DoUpdate (Upsert names)

51+ -- ^ @ON CONFLICT DO UPDATE@

52+

53+

54+-- | The @ON CONFLICT (...) DO UPDATE@ clause of an @INSERT@ statement, also

55+-- known as \"upsert\".

56+--

57+-- When an existing row conflicts with a row proposed for insertion,

58+-- @ON CONFLICT DO UPDATE@ allows you to instead update this existing row. The

59+-- conflicting row proposed for insertion is then \"excluded\", but its values

60+-- can still be referenced from the @SET@ and @WHERE@ clauses of the @UPDATE@

61+-- statement.

62+--

63+-- Upsert in Postgres requires an explicit set of \"conflict targets\" — the

64+-- set of columns comprising the @UNIQUE@ index from conflicts with which we

65+-- would like to recover.

66+type Upsert :: Type -> Type

67+data Upsert names where

68+ Upsert :: (Selects names exprs, Projecting names index, excluded ~ exprs) =>

69+ { index :: Projection names index

70+ -- ^ The set of conflict targets, projected from the set of columns for

71+ -- the whole table

72+ , set :: excluded -> exprs -> exprs

73+ -- ^ How to update each selected row.

74+ , updateWhere :: excluded -> exprs -> Expr Bool

75+ -- ^ Which rows to select for update.

76+ }

77+ -> Upsert names

78+

79+

80+ppOnConflict :: TableSchema names -> OnConflict names -> Doc

81+ppOnConflict schema = \case

82+ Abort -> mempty

83+ DoNothing -> text "ON CONFLICT DO NOTHING"

84+ DoUpdate upsert -> ppUpsert schema upsert

85+

86+

87+ppUpsert :: TableSchema names -> Upsert names -> Doc

88+ppUpsert schema@TableSchema {columns} Upsert {..} =

89+ text "ON CONFLICT" <+>

90+ ppIndex schema index <+>

91+ text "DO UPDATE" $$

92+ ppSet schema (set excluded) $$

93+ ppWhere schema (updateWhere excluded)

94+ where

95+ excluded = attributes TableSchema

96+ { schema = Nothing

97+ , name = "excluded"

98+ , columns

99+ }

100+

101+

102+ppIndex :: (Table Name names, Projecting names index)

103+ => TableSchema names -> Projection names index -> Doc

104+ppIndex TableSchema {columns} index =

105+ parens $ Opaleye.commaV ppColumn $ toList $

106+ showNames $ Cols $ apply index $ toColumns columns

src/Rel8/Statement/Returning.hs+121−10

@@ -1,29 +1,140 @@

1{-# language GADTs #-}

2+{-# language LambdaCase #-}

3+{-# language NamedFieldPuns #-}

4+{-# language RankNTypes #-}

5+{-# language ScopedTypeVariables #-}

2{-# language StandaloneKindSignatures #-}

6{-# language StandaloneKindSignatures #-}

7+{-# language StrictData #-}

8+{-# language TypeApplications #-}

3

9

4module Rel8.Statement.Returning

10module Rel8.Statement.Returning

5− ( Returning(..)

11+ ( Returning( NumberOfRowsAffected, Projection )

12+

13+ , decodeReturning

14+ , emptyReturning

15+ , ppReturning

6 )

16 )

7where

17where

8

18

9-- base

19-- base

20+import Control.Applicative ( liftA2 )

21+import Data.Foldable ( toList )

10import Data.Int ( Int64 )

22import Data.Int ( Int64 )

11import Data.Kind ( Type )

23import Data.Kind ( Type )

24+import Data.List.NonEmpty ( NonEmpty )

12−import Prelude ()

25+import Prelude

26+

27+-- hasql

28+import qualified Hasql.Decoders as Hasql

29+

30+-- opaleye

31+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye

32+import qualified Opaleye.Internal.HaskellDB.Sql.Print as Opaleye

33+import qualified Opaleye.Internal.Sql as Opaleye

34+

35+-- pretty

36+import Text.PrettyPrint ( Doc, (<+>), text )

13

37

14-- rel8

38-- rel8

15import Rel8.Schema.Name ( Selects )

39import Rel8.Schema.Name ( Selects )

40+import Rel8.Schema.Table ( TableSchema(..) )

41+import Rel8.Table.Opaleye ( castTable, exprs, view )

16−import Rel8.Table.Serialize ( Serializable )

42+import Rel8.Table.Serialize ( Serializable, parse )

43+

44+-- semigropuoids

45+import Data.Functor.Apply ( Apply, (<.>) )

17

46

18

47

19−-- | @INSERT@, @UPDATE@ and @DELETE@ all support returning either the number of

48+-- | 'Rel8.Insert', 'Rel8.Update' and 'Rel8.Delete' all support returning either

20−-- rows affected, or the actual rows modified. 'Projection' allows you to

49+-- the number of rows affected, or the actual rows modified.

21−-- project out of these returned rows, which can be useful if you want to log

22−-- exactly which rows were deleted, or to view a generated id (for example, if

23−-- using a column with an autoincrementing counter as a default value).

24type Returning :: Type -> Type -> Type

50type Returning :: Type -> Type -> Type

25data Returning names a where

51data Returning names a where

52+ Pure :: a -> Returning names a

53+ Ap :: Returning names (a -> b) -> Returning names a -> Returning names b

54+

55+ -- | Return the number of rows affected.

26 NumberOfRowsAffected :: Returning names Int64

56 NumberOfRowsAffected :: Returning names Int64

57+

58+ -- | 'Projection' allows you to project out of the affected rows, which can

59+ -- be useful if you want to log exactly which rows were deleted, or to view

60+ -- a generated id (for example, if using a column with an autoincrementing

61+ -- counter via 'Rel8.nextval').

27− Projection :: (Selects names exprs, Serializable projection a)

62+ Projection :: (Selects names exprs, Serializable returning a)

28− => (exprs -> projection)

63+ => (exprs -> returning)

29 -> Returning names [a]

64 -> Returning names [a]

65+

66+

67+instance Functor (Returning names) where

68+ fmap f = \case

69+ Pure a -> Pure (f a)

70+ Ap g a -> Ap (fmap (f .) g) a

71+ m -> Ap (Pure f) m

72+

73+

74+instance Apply (Returning names) where

75+ (<.>) = Ap

76+

77+

78+instance Applicative (Returning names) where

79+ pure = Pure

80+ (<*>) = Ap

81+

82+

83+projections :: ()

84+ => TableSchema names -> Returning names a -> Maybe (NonEmpty Opaleye.PrimExpr)

85+projections schema@TableSchema {columns} = \case

86+ Pure _ -> Nothing

87+ Ap f a -> projections schema f <> projections schema a

88+ NumberOfRowsAffected -> Nothing

89+ Projection f -> Just (exprs (castTable (f (view columns))))

90+

91+

92+runReturning :: ()

93+ => ((Int64 -> a) -> r)

94+ -> (forall x. Hasql.Row x -> ([x] -> a) -> r)

95+ -> Returning names a

96+ -> r

97+runReturning rowCount rowList = \case

98+ Pure a -> rowCount (const a)

99+ Ap fs as ->

100+ runReturning

101+ (\withCount ->

102+ runReturning

103+ (\withCount' -> rowCount (withCount <*> withCount'))

104+ (\decoder -> rowList decoder . liftA2 withCount length64)

105+ as)

106+ (\decoder withRows ->

107+ runReturning

108+ (\withCount -> rowList decoder $ withRows <*> withCount . length64)

109+ (\decoder' withRows' ->

110+ rowList (liftA2 (,) decoder decoder') $

111+ withRows <$> fmap fst <*> withRows' . fmap snd)

112+ as)

113+ fs

114+ NumberOfRowsAffected -> rowCount id

115+ Projection (_ :: exprs -> returning) -> rowList decoder' id

116+ where

117+ decoder' = parse @returning

118+ where

119+ length64 :: Foldable f => f x -> Int64

120+ length64 = fromIntegral . length

121+

122+

123+decodeReturning :: Returning names a -> Hasql.Result a

124+decodeReturning = runReturning

125+ (<$> Hasql.rowsAffected)

126+ (\decoder withRows -> withRows <$> Hasql.rowList decoder)

127+

128+

129+emptyReturning :: Returning names a -> a

130+emptyReturning =

131+ runReturning (\withCount -> withCount 0) (\_ withRows -> withRows [])

132+

133+

134+ppReturning :: TableSchema names -> Returning names a -> Doc

135+ppReturning schema returning = case projections schema returning of

136+ Nothing -> mempty

137+ Just columns ->

138+ text "RETURNING" <+> Opaleye.commaV Opaleye.ppSqlExpr (toList sqlExprs)

139+ where

140+ sqlExprs = Opaleye.sqlExpr <$> columns

src/Rel8/Statement/SQL.hsnew file+29

@@ -0,0 +1,29 @@

1+module Rel8.Statement.SQL

2+ ( showDelete

3+ , showInsert

4+ , showUpdate

5+ )

6+where

7+

8+-- base

9+import Prelude

10+

11+-- rel8

12+import Rel8.Statement.Delete ( Delete, ppDelete )

13+import Rel8.Statement.Insert ( Insert, ppInsert )

14+import Rel8.Statement.Update ( Update, ppUpdate )

15+

16+

17+-- | Convert a 'Delete' to a 'String' containing a @DELETE@ statement.

18+showDelete :: Delete a -> String

19+showDelete = foldMap show . ppDelete

20+

21+

22+-- | Convert an 'Insert' to a 'String' containing an @INSERT@ statement.

23+showInsert :: Insert a -> String

24+showInsert = foldMap show . ppInsert

25+

26+

27+-- | Convert an 'Update' to a 'String' containing an @UPDATE@ statement.

28+showUpdate :: Update a -> String

29+showUpdate = foldMap show . ppUpdate

src/Rel8/Statement/Select.hs+77−20

@@ -1,15 +1,22 @@

1+{-# language DeriveTraversable #-}

2+{-# language DerivingStrategies #-}

3+{-# language FlexibleContexts #-}

1{-# language MonoLocalBinds #-}

4{-# language MonoLocalBinds #-}

2{-# language ScopedTypeVariables #-}

5{-# language ScopedTypeVariables #-}

3{-# language TypeApplications #-}

6{-# language TypeApplications #-}

4

7

5module Rel8.Statement.Select

8module Rel8.Statement.Select

6 ( select

9 ( select

7− , selectWithNames

10+ , ppSelect

11+

12+ , Optimized(..)

13+ , ppPrimSelect

8 )

14 )

9where

15where

10

16

11-- base

17-- base

12import Control.Exception ( throwIO )

18import Control.Exception ( throwIO )

19+import Data.Void ( Void )

13import Prelude

20import Prelude

14

21

15-- hasql

22-- hasql

@@ -19,10 +26,26 @@ import qualified Hasql.Encoders as Hasql

19import qualified Hasql.Session as Hasql

26import qualified Hasql.Session as Hasql

20import qualified Hasql.Statement as Hasql

27import qualified Hasql.Statement as Hasql

21

28

29+-- opaleye

30+import qualified Opaleye.Internal.HaskellDB.Sql as Opaleye

31+import qualified Opaleye.Internal.PrimQuery as Opaleye

32+import qualified Opaleye.Internal.Print as Opaleye

33+import qualified Opaleye.Internal.Optimize as Opaleye

34+import qualified Opaleye.Internal.QueryArr as Opaleye hiding ( Select )

35+import qualified Opaleye.Internal.Sql as Opaleye

36+

37+-- pretty

38+import Text.PrettyPrint ( Doc )

39+

22-- rel8

40-- rel8

41+import Rel8.Expr ( Expr )

23import Rel8.Query ( Query )

42import Rel8.Query ( Query )

24−import Rel8.Query.SQL ( sqlForQuery, sqlForQueryWithNames )

43+import Rel8.Query.Opaleye ( toOpaleye )

25import Rel8.Schema.Name ( Selects )

44import Rel8.Schema.Name ( Selects )

45+import Rel8.Table ( Table )

46+import Rel8.Table.Cols ( toCols )

47+import Rel8.Table.Name ( namesFromLabels )

48+import Rel8.Table.Opaleye ( castTable, exprsWithNames )

26import Rel8.Table.Serialize ( Serializable, parse )

49import Rel8.Table.Serialize ( Serializable, parse )

27

50

28-- text

51-- text

@@ -30,12 +53,12 @@ import qualified Data.Text as Text

30import Data.Text.Encoding ( encodeUtf8 )

53import Data.Text.Encoding ( encodeUtf8 )

31

54

32

55

33−-- | Run a @SELECT@ query, returning all rows.

56+-- | Run a @SELECT@ statement, returning all rows.

34select :: forall exprs a. Serializable exprs a

57select :: forall exprs a. Serializable exprs a

35 => Connection -> Query exprs -> IO [a]

58 => Connection -> Query exprs -> IO [a]

36−select c query = case sqlForQuery query of

59+select c query = case ppSelect query of

37 Nothing -> pure []

60 Nothing -> pure []

38− Just sql -> Hasql.run session c >>= either throwIO pure

61+ Just doc -> Hasql.run session c >>= either throwIO pure

39 where

62 where

40 session = Hasql.statement () statement

63 session = Hasql.statement () statement

41 statement = Hasql.Statement bytes params decode prepare

64 statement = Hasql.Statement bytes params decode prepare

@@ -43,20 +66,54 @@ select c query = case sqlForQuery query of

43 params = Hasql.noParams

66 params = Hasql.noParams

44 decode = Hasql.rowList (parse @exprs @a)

67 decode = Hasql.rowList (parse @exprs @a)

45 prepare = False

68 prepare = False

69+ sql = show doc

46

70

47

71

48−selectWithNames :: forall exprs a names.

72+ppSelect :: Table Expr a => Query a -> Maybe Doc

73+ppSelect query = do

74+ primQuery' <- case optimize primQuery of

75+ Empty -> Nothing

76+ Unit -> Just Opaleye.Unit

77+ Optimized primQuery' -> Just primQuery'

78+ pure $ Opaleye.ppSql $ primSelectWith names (toCols exprs) primQuery'

79+ where

80+ names = namesFromLabels

81+ (exprs, primQuery, _) =

82+ Opaleye.runSimpleQueryArrStart (toOpaleye query) ()

83+

84+

85+ppPrimSelect :: Query a -> (Optimized Doc, a)

86+ppPrimSelect query =

87+ (Opaleye.ppSql . primSelect <$> optimize primQuery, a)

88+ where

89+ (a, primQuery, _) =

90+ Opaleye.runSimpleQueryArrStart (toOpaleye query) ()

91+

92+

93+data Optimized a = Empty | Unit | Optimized a

94+ deriving stock (Functor, Foldable, Traversable)

95+

96+

97+optimize :: Opaleye.PrimQuery' a -> Optimized (Opaleye.PrimQuery' Void)

98+optimize query = case Opaleye.removeEmpty (Opaleye.optimize query) of

99+ Nothing -> Empty

100+ Just Opaleye.Unit -> Unit

101+ Just query' -> Optimized query'

102+

103+

104+primSelect :: Opaleye.PrimQuery' Void -> Opaleye.Select

105+primSelect = Opaleye.foldPrimQuery Opaleye.sqlQueryGenerator

106+

107+

49− ( Selects names exprs

108+primSelectWith :: Selects names exprs

50− , Serializable exprs a

109+ => names -> exprs -> Opaleye.PrimQuery' Void -> Opaleye.Select

51− )

110+primSelectWith names exprs query =

52− => Connection -> names -> Query exprs -> IO [a]

111+ Opaleye.SelectFrom $ Opaleye.newSelect

53−selectWithNames c names query = case sqlForQueryWithNames names query of

112+ { Opaleye.attrs = Opaleye.SelectAttrs attrs

54− Nothing -> pure []

113+ , Opaleye.tables = Opaleye.oneTable (primSelect query)

55− Just sql -> Hasql.run session c >>= either throwIO pure

114+ }

56− where

115+ where

57− session = Hasql.statement () statement

116+ attrs = makeAttr <$> exprsWithNames names (castTable exprs)

58− statement = Hasql.Statement bytes params decode prepare

117+ where

59− bytes = encodeUtf8 (Text.pack sql)

118+ makeAttr (label, expr) =

60− params = Hasql.noParams

119+ (Opaleye.sqlExpr expr, Just (Opaleye.SqlColumn label))

61− decode = Hasql.rowList (parse @exprs @a)

62− prepare = False

src/Rel8/Statement/Set.hsnew file+33

@@ -0,0 +1,33 @@

1+{-# language MonoLocalBinds #-}

2+{-# language NamedFieldPuns #-}

3+

4+module Rel8.Statement.Set

5+ ( ppSet

6+ )

7+where

8+

9+-- base

10+import Data.Foldable ( toList )

11+import Prelude ()

12+

13+-- opaleye

14+import qualified Opaleye.Internal.HaskellDB.Sql.Print as Opaleye

15+import qualified Opaleye.Internal.Sql as Opaleye

16+

17+-- pretty

18+import Text.PrettyPrint ( Doc, (<+>), equals, text )

19+

20+-- rel8

21+import Rel8.Schema.Name ( Selects, ppColumn )

22+import Rel8.Schema.Table ( TableSchema(..) )

23+import Rel8.Table.Opaleye ( attributes, exprsWithNames )

24+

25+

26+ppSet :: Selects names exprs

27+ => TableSchema names -> (exprs -> exprs) -> Doc

28+ppSet schema@TableSchema {columns} f =

29+ text "SET" <+> Opaleye.commaV ppAssign (toList assigns)

30+ where

31+ assigns = exprsWithNames columns (f (attributes schema))

32+ ppAssign (column, expr) =

33+ ppColumn column <+> equals <+> Opaleye.ppSqlExpr (Opaleye.sqlExpr expr)

src/Rel8/Statement/Update.hs+38−48

@@ -1,12 +1,14 @@

1+{-# language DuplicateRecordFields #-}

1{-# language GADTs #-}

2{-# language GADTs #-}

2{-# language NamedFieldPuns #-}

3{-# language NamedFieldPuns #-}

3−{-# language ScopedTypeVariables #-}

4+{-# language RecordWildCards #-}

4{-# language StandaloneKindSignatures #-}

5{-# language StandaloneKindSignatures #-}

5−{-# language TypeApplications #-}

6+{-# language StrictData #-}

6

7

7module Rel8.Statement.Update

8module Rel8.Statement.Update

8 ( Update(..)

9 ( Update(..)

9 , update

10 , update

11+ , ppUpdate

10 )

12 )

11where

13where

12

14

@@ -17,23 +19,25 @@ import Prelude

17

19

18-- hasql

20-- hasql

19import Hasql.Connection ( Connection )

21import Hasql.Connection ( Connection )

20−import qualified Hasql.Decoders as Hasql

21import qualified Hasql.Encoders as Hasql

22import qualified Hasql.Encoders as Hasql

22import qualified Hasql.Session as Hasql

23import qualified Hasql.Session as Hasql

23import qualified Hasql.Statement as Hasql

24import qualified Hasql.Statement as Hasql

24

25

25−-- opaleye

26+-- pretty

26−import qualified Opaleye.Internal.Manipulation as Opaleye

27+import Text.PrettyPrint ( Doc, (<+>), ($$), text )

27

28

28-- rel8

29-- rel8

29import Rel8.Expr ( Expr )

30import Rel8.Expr ( Expr )

30−import Rel8.Expr.Opaleye ( toColumn, toPrimExpr )

31+import Rel8.Query ( Query )

31import Rel8.Schema.Name ( Selects )

32import Rel8.Schema.Name ( Selects )

32−import Rel8.Schema.Table ( TableSchema )

33+import Rel8.Schema.Table ( TableSchema(..), ppTable )

33−import Rel8.Statement.Returning ( Returning( Projection, NumberOfRowsAffected ) )

34+import Rel8.Statement.Returning

34−import Rel8.Table.Cols ( fromCols, toCols )

35+ ( Returning

35−import Rel8.Table.Opaleye ( castTable, table, unpackspec )

36+ , decodeReturning, emptyReturning, ppReturning

36−import Rel8.Table.Serialize ( Serializable, parse )

37+ )

38+import Rel8.Statement.Set ( ppSet )

39+import Rel8.Statement.Using ( ppFrom )

40+import Rel8.Statement.Where ( ppWhere )

37

41

38-- text

42-- text

39import qualified Data.Text as Text

43import qualified Data.Text as Text

@@ -46,9 +50,12 @@ data Update a where

46 Update :: Selects names exprs =>

50 Update :: Selects names exprs =>

47 { target :: TableSchema names

51 { target :: TableSchema names

48 -- ^ Which table to update.

52 -- ^ Which table to update.

53+ , from :: Query from

54+ -- ^ @FROM@ clause — this can be used to join against other tables,

55+ -- and its results can be referenced in the @SET@ and @WHERE@ clauses.

49− , set :: exprs -> exprs

56+ , set :: from -> exprs -> exprs

50 -- ^ How to update each selected row.

57 -- ^ How to update each selected row.

51− , updateWhere :: exprs -> Expr Bool

58+ , updateWhere :: from -> exprs -> Expr Bool

52 -- ^ Which rows to select for update.

59 -- ^ Which rows to select for update.

53 , returning :: Returning names a

60 , returning :: Returning names a

54 -- ^ What to return from the @UPDATE@ statement.

61 -- ^ What to return from the @UPDATE@ statement.

@@ -56,46 +63,29 @@ data Update a where

56 -> Update a

63 -> Update a

57

64

58

65

66+ppUpdate :: Update a -> Maybe Doc

67+ppUpdate Update {..} = do

68+ (fromDoc, i) <- ppFrom from

69+ pure $

70+ text "UPDATE" <+>

71+ ppTable target $$

72+ ppSet target (set i) $$

73+ fromDoc $$

74+ ppWhere target (updateWhere i) $$

75+ ppReturning target returning

76+

77+

59-- | Run an @UPDATE@ statement.

78-- | Run an @UPDATE@ statement.

60update :: Connection -> Update a -> IO a

79update :: Connection -> Update a -> IO a

61−update c Update {target, set, updateWhere, returning} =

80+update connection u@Update {returning} =

62− case returning of

81+ case show <$> ppUpdate u of

82+ Nothing -> pure (emptyReturning returning)

83+ Just sql ->

63− NumberOfRowsAffected -> Hasql.run session c >>= either throwIO pure

84+ Hasql.run session connection >>= either throwIO pure

64 where

85 where

65 session = Hasql.statement () statement

86 session = Hasql.statement () statement

66 statement = Hasql.Statement bytes params decode prepare

87 statement = Hasql.Statement bytes params decode prepare

67 bytes = encodeUtf8 $ Text.pack sql

88 bytes = encodeUtf8 $ Text.pack sql

68 params = Hasql.noParams

89 params = Hasql.noParams

69− decode = Hasql.rowsAffected

90+ decode = decodeReturning returning

70 prepare = False

91 prepare = False

71− sql = Opaleye.arrangeUpdateSql target' set' where'

72− where

73− target' = table $ toCols <$> target

74− set' = toCols . set . fromCols

75− where' = toColumn . toPrimExpr . updateWhere . fromCols

76−

77− Projection project -> Hasql.run session c >>= either throwIO pure

78− where

79− session = Hasql.statement () statement

80− statement = Hasql.Statement bytes params decode prepare

81− bytes = encodeUtf8 $ Text.pack sql

82− params = Hasql.noParams

83− decode = decoder project

84− prepare = False

85− sql =

86− Opaleye.arrangeUpdateReturningSql

87− unpackspec

88− target'

89− set'

90− where'

91− project'

92− where

93− target' = table $ toCols <$> target

94− set' = toCols . set . fromCols

95− where' = toColumn . toPrimExpr . updateWhere . fromCols

96− project' = castTable . toCols . project . fromCols

97−

98− where

99− decoder :: forall exprs projection a. Serializable projection a

100− => (exprs -> projection) -> Hasql.Result [a]

101− decoder _ = Hasql.rowList (parse @projection @a)

src/Rel8/Statement/Using.hsnew file+36

@@ -0,0 +1,36 @@

1+module Rel8.Statement.Using

2+ ( ppFrom

3+ , ppUsing

4+ )

5+where

6+

7+-- base

8+import Prelude

9+

10+-- pretty

11+import Text.PrettyPrint ( Doc, (<+>), parens, text )

12+

13+-- rel8

14+import Rel8.Query ( Query )

15+import Rel8.Schema.Table ( TableSchema(..), ppTable )

16+import Rel8.Statement.Select ( Optimized(..), ppPrimSelect )

17+

18+

19+ppFrom :: Query a -> Maybe (Doc, a)

20+ppFrom = ppJoin "FROM"

21+

22+

23+ppUsing :: Query a -> Maybe (Doc, a)

24+ppUsing = ppJoin "USING"

25+

26+

27+ppJoin :: String -> Query a -> Maybe (Doc, a)

28+ppJoin clause join = do

29+ doc <- case ofrom of

30+ Empty -> Nothing

31+ Unit -> Just mempty

32+ Optimized doc -> Just $ text clause <+> parens doc <+> ppTable alias

33+ pure (doc, a)

34+ where

35+ alias = TableSchema {name = "T1", schema = Nothing, columns = ()}

36+ (ofrom, a) = ppPrimSelect join

src/Rel8/Statement/View.hs+20−20

@@ -8,7 +8,6 @@ where

8

9-- base

10import Control.Exception ( throwIO )

11−import Control.Monad ( (>=>) )

12import Data.Foldable ( fold )

11import Data.Foldable ( fold )

13import Data.Maybe ( fromMaybe )

12import Data.Maybe ( fromMaybe )

14import Prelude

13import Prelude

@@ -22,11 +21,15 @@ import qualified Hasql.Statement as Hasql

22

21

23-- rel8

22-- rel8

24import Rel8.Query ( Query )

23import Rel8.Query ( Query )

25−import Rel8.Query.SQL ( sqlForQueryWithNames )

26import Rel8.Schema.Name ( Selects )

24import Rel8.Schema.Name ( Selects )

27−import Rel8.Schema.Table ( TableSchema( TableSchema ) )

25+import Rel8.Schema.Table ( TableSchema )

26+import Rel8.Statement.Insert ( ppInto )

27+import Rel8.Statement.Select ( ppSelect )

28import Rel8.Table.Alternative ( emptyTable )

29

30+-- pretty

31+import Text.PrettyPrint ( Doc, (<+>), ($$), text )

32+

30-- text

33-- text

31import qualified Data.Text as Text

34import qualified Data.Text as Text

32import Data.Text.Encoding ( encodeUtf8 )

35import Data.Text.Encoding ( encodeUtf8 )

@@ -36,9 +39,9 @@ import Data.Text.Encoding ( encodeUtf8 )

36-- statement that will save the given query as a view. This can be useful if

39-- statement that will save the given query as a view. This can be useful if

37-- you want to share Rel8 queries with other applications.

40-- you want to share Rel8 queries with other applications.

38createView :: Selects names exprs

41createView :: Selects names exprs

39− => TableSchema names -> Query exprs -> Connection -> IO ()

42+ => Connection -> TableSchema names -> Query exprs -> IO ()

40−createView (TableSchema name mschema names) query =

43+createView connection schema query =

41− Hasql.run session >=> either throwIO pure

44+ Hasql.run session connection >>= either throwIO pure

42 where

45 where

43 session = Hasql.statement () statement

46 session = Hasql.statement () statement

44 statement = Hasql.Statement bytes params decode prepare

47 statement = Hasql.Statement bytes params decode prepare

@@ -46,18 +49,15 @@ createView (TableSchema name mschema names) query =

46 params = Hasql.noParams

49 params = Hasql.noParams

47 decode = Hasql.noResult

50 decode = Hasql.noResult

48 prepare = False

51 prepare = False

52+ sql = show (ppCreateView schema query)

53+

54+

55+ppCreateView :: Selects names exprs

56+ => TableSchema names -> Query exprs -> Doc

57+ppCreateView schema query =

49− sql = "CREATE VIEW " <> title <> " AS " <> select

58+ text "CREATE VIEW" <+>

50− where

59+ ppInto schema $$

51− title = case mschema of

60+ text "AS" <+>

52− Nothing -> quote name

53− Just schema -> quote schema <> "." <> quote name

54− select = fromMaybe fallback $ sqlForQueryWithNames names query

61+ fromMaybe fallback (ppSelect query)

55− where

56− fallback = fold $ sqlForQueryWithNames names emptyTable

57−

58−

59−quote :: String -> String

60−quote string = "\"" <> concatMap go string <> "\""

61 where

62 where

62− go '"' = "\"\""

63+ fallback = fold (ppSelect (emptyTable `asTypeOf` query))

63− go c = [c]

src/Rel8/Statement/Where.hsnew file+31

@@ -0,0 +1,31 @@

1+{-# language MonoLocalBinds #-}

2+

3+module Rel8.Statement.Where

4+ ( ppWhere

5+ )

6+where

7+

8+-- base

9+import Prelude

10+

11+-- opaleye

12+import qualified Opaleye.Internal.HaskellDB.Sql.Print as Opaleye

13+import qualified Opaleye.Internal.Sql as Opaleye

14+

15+-- pretty

16+import Text.PrettyPrint ( Doc, (<+>), text )

17+

18+-- rel8

19+import Rel8.Expr ( Expr )

20+import Rel8.Expr.Opaleye ( toPrimExpr )

21+import Rel8.Schema.Name ( Selects )

22+import Rel8.Schema.Table ( TableSchema )

23+import Rel8.Table.Opaleye ( attributes )

24+

25+

26+ppWhere :: Selects names exprs

27+ => TableSchema names -> (exprs -> Expr Bool) -> Doc

28+ppWhere schema where_ = text "WHERE" <+> ppExpr condition

29+ where

30+ ppExpr = Opaleye.ppSqlExpr . Opaleye.sqlExpr . toPrimExpr

31+ condition = where_ (attributes schema)

src/Rel8/Table/Name.hs+3−17

@@ -12,7 +12,6 @@

12module Rel8.Table.Name

13 ( namesFromLabels

14 , namesFromLabelsWith

15− , showExprs

16 , showLabels

15 , showLabels

17 , showNames

16 , showNames

18 )

17 )

@@ -25,17 +24,11 @@ import Data.List.NonEmpty ( NonEmpty, intersperse, nonEmpty )

25import Data.Maybe ( fromMaybe )

24import Data.Maybe ( fromMaybe )

26import Prelude

25import Prelude

27

26

28−-- opaleye

29−import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye

30−

31-- rel8

27-- rel8

32−import Rel8.Expr ( Expr )

33−import Rel8.Expr.Opaleye ( toPrimExpr )

34import Rel8.Schema.HTable ( htabulate, htabulateA, hfield, hspecs )

28import Rel8.Schema.HTable ( htabulate, htabulateA, hfield, hspecs )

35import Rel8.Schema.Name ( Name( Name ) )

29import Rel8.Schema.Name ( Name( Name ) )

36import Rel8.Schema.Spec ( Spec(..) )

30import Rel8.Schema.Spec ( Spec(..) )

37import Rel8.Table ( Table(..) )

31import Rel8.Table ( Table(..) )

38−import Rel8.Table.Cols ( Cols( Cols ) )

39

32

40

33

41-- | Construct a table in the 'Name' context containing the names of all

34-- | Construct a table in the 'Name' context containing the names of all

@@ -70,23 +63,16 @@ namesFromLabelsWith f = fromColumns $ htabulate $ \field ->

70 Spec {labels} -> Name (f (renderLabels labels))

63 Spec {labels} -> Name (f (renderLabels labels))

71

64

72

65

73−showExprs :: Table Expr a => a -> [(String, Opaleye.PrimExpr)]

74−showExprs as = case (namesFromLabels, toColumns as) of

75− (Cols names, exprs) -> getConst $ htabulateA $ \field ->

76− case (hfield names field, hfield exprs field) of

77− (Name name, expr) -> Const [(name, toPrimExpr expr)]

78−

79−

80showLabels :: forall a. Table (Context a) a => a -> [NonEmpty String]

66showLabels :: forall a. Table (Context a) a => a -> [NonEmpty String]

81showLabels _ = getConst $

67showLabels _ = getConst $

82 htabulateA @(Columns a) $ \field -> case hfield hspecs field of

68 htabulateA @(Columns a) $ \field -> case hfield hspecs field of

83− Spec {labels} -> Const [renderLabels labels]

69+ Spec {labels} -> Const (pure (renderLabels labels))

84

70

85

71

86−showNames :: forall a. Table Name a => a -> [String]

72+showNames :: forall a. Table Name a => a -> NonEmpty String

87showNames (toColumns -> names) = getConst $

73showNames (toColumns -> names) = getConst $

88 htabulateA @(Columns a) $ \field -> case hfield names field of

74 htabulateA @(Columns a) $ \field -> case hfield names field of

89− Name name -> Const [name]

75+ Name name -> Const (pure name)

90

76

91

77

92renderLabels :: [String] -> NonEmpty String

78renderLabels :: [String] -> NonEmpty String

src/Rel8/Table/Opaleye.hs+36−4

@@ -2,7 +2,6 @@

2{-# language DataKinds #-}

3{-# language DisambiguateRecordFields #-}

4{-# language FlexibleContexts #-}

5−{-# language LambdaCase #-}

6{-# language NamedFieldPuns #-}

5{-# language NamedFieldPuns #-}

7{-# language RankNTypes #-}

6{-# language RankNTypes #-}

8{-# language TypeFamilies #-}

7{-# language TypeFamilies #-}

@@ -10,17 +9,23 @@

10

9

11module Rel8.Table.Opaleye

10module Rel8.Table.Opaleye

12 ( aggregator

11 ( aggregator

12+ , attributes

13 , binaryspec

14 , distinctspec

15+ , exprs

16+ , exprsWithNames

15 , table

17 , table

16 , tableFields

18 , tableFields

17 , unpackspec

19 , unpackspec

18 , valuesspec

20 , valuesspec

21+ , view

19 , castTable

22 , castTable

20 )

23 )

21where

24where

22

25

23-- base

26-- base

27+import Data.Functor.Const ( Const( Const ), getConst )

28+import Data.List.NonEmpty ( NonEmpty )

24import Prelude hiding ( undefined )

29import Prelude hiding ( undefined )

25

30

26-- opaleye

31-- opaleye

@@ -46,9 +51,9 @@ import Rel8.Expr.Opaleye

46 , scastExpr

51 , scastExpr

47 )

52 )

48import Rel8.Schema.HTable ( htabulateA, hfield, htraverse, hspecs, htabulate )

53import Rel8.Schema.HTable ( htabulateA, hfield, htraverse, hspecs, htabulate )

49−import Rel8.Schema.Name ( Name( Name ), Selects )

54+import Rel8.Schema.Name ( Name( Name ), Selects, ppColumn )

50import Rel8.Schema.Spec ( Spec(..) )

55import Rel8.Schema.Spec ( Spec(..) )

51−import Rel8.Schema.Table ( TableSchema(..) )

56+import Rel8.Schema.Table ( TableSchema(..), ppTable )

52import Rel8.Table ( Table, fromColumns, toColumns )

57import Rel8.Table ( Table, fromColumns, toColumns )

53import Rel8.Table.Undefined ( undefined )

58import Rel8.Table.Undefined ( undefined )

54

59

@@ -64,6 +69,14 @@ aggregator = Opaleye.Aggregator $ Opaleye.PackMap $ \f aggregates ->

64 inner f ()

69 inner f ()

65

70

66

71

72+attributes :: Selects names exprs => TableSchema names -> exprs

73+attributes schema@TableSchema {columns} = fromColumns $ htabulate $ \field ->

74+ case hfield (toColumns columns) field of

75+ Name column -> fromPrimExpr $ Opaleye.ConstExpr $

76+ Opaleye.OtherLit $

77+ show (ppTable schema) <> "." <> show (ppColumn column)

78+

79+

67binaryspec :: Table Expr a => Opaleye.Binaryspec a a

80binaryspec :: Table Expr a => Opaleye.Binaryspec a a

68binaryspec = Opaleye.Binaryspec $ Opaleye.PackMap $ \f (as, bs) ->

81binaryspec = Opaleye.Binaryspec $ Opaleye.PackMap $ \f (as, bs) ->

69 fmap fromColumns $ unwrapApplicative $ htabulateA $ \field ->

82 fmap fromColumns $ unwrapApplicative $ htabulateA $ \field ->

@@ -82,7 +95,20 @@ distinctspec =

82 toColumns

95 toColumns

83

96

84

97

98+exprs :: Table Expr a => a -> NonEmpty Opaleye.PrimExpr

99+exprs (toColumns -> as) = getConst $ htabulateA $ \field ->

100+ case hfield as field of

101+ expr -> Const (pure (toPrimExpr expr))

102+

103+

104+exprsWithNames :: Selects names exprs

105+ => names -> exprs -> NonEmpty (String, Opaleye.PrimExpr)

106+exprsWithNames names as = getConst $ htabulateA $ \field ->

107+ case (hfield (toColumns names) field, hfield (toColumns as) field) of

108+ (Name name, expr) -> Const (pure (name, toPrimExpr expr))

109+

110+

85−table ::Selects names exprs => TableSchema names -> Opaleye.Table exprs exprs

111+table :: Selects names exprs => TableSchema names -> Opaleye.Table exprs exprs

86table (TableSchema name schema columns) =

112table (TableSchema name schema columns) =

87 case schema of

113 case schema of

88 Nothing -> Opaleye.Table name (tableFields columns)

114 Nothing -> Opaleye.Table name (tableFields columns)

@@ -115,6 +141,12 @@ valuesspec :: Table Expr a => Opaleye.ValuesspecSafe a a

115valuesspec = Opaleye.ValuesspecSafe (toPackMap undefined) unpackspec

141valuesspec = Opaleye.ValuesspecSafe (toPackMap undefined) unpackspec

116

142

117

143

144+view :: Selects names exprs => names -> exprs

145+view columns = fromColumns $ htabulate $ \field ->

146+ case hfield (toColumns columns) field of

147+ Name column -> fromPrimExpr $ Opaleye.BaseTableAttrExpr column

148+

149+

118toPackMap :: Table Expr a

150toPackMap :: Table Expr a

119 => a -> Opaleye.PackMap Opaleye.PrimExpr Opaleye.PrimExpr () a

151 => a -> Opaleye.PackMap Opaleye.PrimExpr Opaleye.PrimExpr () a

120toPackMap as = Opaleye.PackMap $ \f () ->

152toPackMap as = Opaleye.PackMap $ \f () ->

src/Rel8/Table/Projection.hs+4−4

@@ -29,13 +29,13 @@ import Rel8.Table.Transpose ( Transposes )

29-- usable 'Projection'.

30type Projecting :: Type -> Type -> Constraint

31class

32− ( Transposes (Field a) (Context a) a (Transpose (Field a) a)

32+ ( Transposes (Context a) (Field a) a (Transpose (Field a) a)

33− , Transposes (Field a) (Context a) b (Transpose (Field a) b)

33+ , Transposes (Context a) (Field a) b (Transpose (Field a) b)

34 )

35 => Projecting a b

36instance

37− ( Transposes (Field a) (Context a) a (Transpose (Field a) a)

37+ ( Transposes (Context a) (Field a) a (Transpose (Field a) a)

38− , Transposes (Field a) (Context a) b (Transpose (Field b) b)

38+ , Transposes (Context a) (Field a) b (Transpose (Field b) b)

39 )

40 => Projecting a b

41

tests/Main.hs+20−19

@@ -185,14 +185,13 @@ testSelectTestTable = databasePropertyTest "Can SELECT TestTable" \transaction -

185 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable

186

187 transaction \connection -> do

188− void do

189− liftIO $ Rel8.insert connection

188+ liftIO $ Rel8.insert connection

190− Rel8.Insert

189+ Rel8.Insert

191− { into = testTableSchema

190+ { into = testTableSchema

192− , rows = map Rel8.lit rows

191+ , rows = Rel8.values $ map Rel8.lit rows

193− , onConflict = Rel8.DoNothing

192+ , onConflict = Rel8.DoNothing

194− , returning = Rel8.NumberOfRowsAffected

193+ , returning = pure ()

195− }

194+ }

196

195

197 selected <- liftIO $ Rel8.select connection do

196 selected <- liftIO $ Rel8.select connection do

198 Rel8.each testTableSchema

197 Rel8.each testTableSchema

@@ -599,18 +598,19 @@ testUpdate = databasePropertyTest "Can UPDATE TestTable" \transaction -> do

599 rows <- forAll $ Gen.map (Range.linear 0 5) $ liftA2 (,) genTestTable genTestTable

598 rows <- forAll $ Gen.map (Range.linear 0 5) $ liftA2 (,) genTestTable genTestTable

600

599

601 transaction \connection -> do

600 transaction \connection -> do

602− void $ liftIO $ Rel8.insert connection

601+ liftIO $ Rel8.insert connection

603 Rel8.Insert

602 Rel8.Insert

604 { into = testTableSchema

603 { into = testTableSchema

605− , rows = map Rel8.lit $ Map.keys rows

604+ , rows = Rel8.values $ map Rel8.lit $ Map.keys rows

606 , onConflict = Rel8.DoNothing

605 , onConflict = Rel8.DoNothing

607− , returning = Rel8.NumberOfRowsAffected

606+ , returning = pure ()

608 }

607 }

609

608

610− void $ liftIO $ Rel8.update connection

609+ liftIO $ Rel8.update connection

611 Rel8.Update

610 Rel8.Update

612 { target = testTableSchema

611 { target = testTableSchema

612+ , from = pure ()

613− , set = \r ->

613+ , set = \_ r ->

614 let updates = map (bimap Rel8.lit Rel8.lit) $ Map.toList rows

615 in

616 foldl

@@ -624,8 +624,8 @@ testUpdate = databasePropertyTest "Can UPDATE TestTable" \transaction -> do

624 )

625 r

626 updates

627− , updateWhere = \_ -> Rel8.lit True

627+ , updateWhere = \_ _ -> Rel8.lit True

628− , returning = Rel8.NumberOfRowsAffected

628+ , returning = pure ()

629 }

630

631 selected <- liftIO $ Rel8.select connection do

@@ -643,19 +643,20 @@ testDelete = databasePropertyTest "Can DELETE TestTable" \transaction -> do

643 rows <- forAll $ Gen.list (Range.linear 0 5) genTestTable

644

645 transaction \connection -> do

646− void $ liftIO $ Rel8.insert connection

646+ liftIO $ Rel8.insert connection

647 Rel8.Insert

648 { into = testTableSchema

649− , rows = map Rel8.lit rows

649+ , rows = Rel8.values $ map Rel8.lit rows

650 , onConflict = Rel8.DoNothing

651− , returning = Rel8.NumberOfRowsAffected

651+ , returning = pure ()

652 }

653

654 deleted <-

655 liftIO $ Rel8.delete connection

656 Rel8.Delete

657 { from = testTableSchema

658+ , using = pure ()

658− , deleteWhere = testTableColumn2

659+ , deleteWhere = const testTableColumn2

659 , returning = Rel8.Projection id

660 , returning = Rel8.Projection id

660 }

661 }

661

662