119c825..master · rel8

git.iko.soy/rel8

on master help sign in

.github/workflows/build.yaml+3−3

since splitsnapshots

unifiedsplit

@@ -9,14 +9,14 @@ jobs:

9 persist-credentials: false

10 submodules: true

12− - uses: cachix/install-nix-action@v12

12+ - uses: cachix/install-nix-action@v14.1

13 with:

14 nix_path: nixpkgs=channel:nixos-unstable

15 extra_nix_config: |

16 trusted-public-keys = cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY= hydra.iohk.io:f/Ea+s+dFdN+3Y/G+FDgSq+a5NEWhJGzdjvKNGv0/EQ=

17− substituters = https://cache.nixos.org/ https://hydra.iohk.io

17+ substituters = https://cache.nixos.org/ https://cache.iog.io

19− - uses: cachix/cachix-action@v8

19+ - uses: cachix/cachix-action@v10

20 with:

21 name: rel8

22 authToken: '${{ secrets.CACHIX_AUTH_TOKEN }}'

Changelog.md+126−1

@@ -1,7 +1,124 @@

1−# 1.1.0.0 (??)

1+# 1.4.0.0 (2002-08-17)

3## Breaking changes

5+* The behavior of `greatest`/`least` has been corrected, and was previously flipped. ([#183](https://github.com/circuithub/rel8/pull/183))

7+## New features

9+* `NullTable`/`HNull` have been added. This is an alternative to `MaybeTable` that doesn't use a tag columns. It's less flexible (no `Functor` or `Applicative` instance) and is meaningless when used with a table that has no non-nullable columns (so nesting `NullTable` is redundant). But in situations where the underlying `Table` does have non-nullable columns, it can losslessly converted to and from `MaybeTable`. It is useful for embedding into a base table when you don't want to store the extra tag column in your schema. ([#173](https://github.com/circuithub/rel8/pull/173))

10+* Add `fromMaybeTable`. ([#179](https://github.com/circuithub/rel8/pull/179))

11+* Add `alignMaybeTable`. ([#196](https://github.com/circuithub/rel8/pull/196))

12+

13+## Improvements

14+

15+* Optimize implementation of `AltTable` for `Tabulation` ([#178](https://github.com/circuithub/rel8/pull/178))

16+

17+## Other

18+

19+* Documentation improvements for `HADT`. ([#177](https://github.com/circuithub/rel8/pull/177))

20+* Document example usage of `groupBy`. ([#184](https://github.com/circuithub/rel8/pull/184))

21+* Build with and require Opaleye >= 0.9.3.3. ([#190](https://github.com/circuithub/rel8/pull/190))

22+* Build with `hasql` 1.6. ([#195](https://github.com/circuithub/rel8/pull/195))

23+

24+# 1.3.1.0 (2022-01-20)

25+

26+## Other

27+

28+* Rel8 now requires Opaleye >= 0.9.1. ([#165](https://github.com/circuithub/rel8/pull/165))

29+

30+# 1.3.0.0 (2022-01-31)

31+

32+## Breaking changes

33+

34+* `div` and `mod` have been changed to match Haskell semantics. If you need the PostgreSQL `div()` and `mod()` functions, use `quot` and `rem`. While this is not an API change, we feel this is a breaking change in semantics and have bumped the major version number. ([#155](https://github.com/circuithub/rel8/pull/155))

35+

36+## New features

37+

38+* `divMod` and `quotRem` functions have been added, matching Haskell's `Prelude` functions. ([#155](https://github.com/circuithub/rel8/pull/155))

39+* `avg` and `mode` aggregation functions to find the mean value of an expression, or the most common row in a query, respectively. ([#152](https://github.com/circuithub/rel8/pull/152))

40+* The full `EqTable` and `OrdTable` classes have been exported, allowing for instances to be manually created. ([#157](https://github.com/circuithub/rel8/pull/157))

41+* Added `like` and `ilike` (for the `LIKE` and `ILIKE` operators). ([#146](https://github.com/circuithub/rel8/pull/146))

42+

43+## Other

44+

45+* Rel8 now requires Opaleye 0.9. ([#158](https://github.com/circuithub/rel8/pull/158))

46+* Rel8's test suite supports Hedgehog 1.1. ([#160](https://github.com/circuithub/rel8/pull/160))

47+* The documentation for binary operations has been corrected. ([#162](https://github.com/circuithub/rel8/pull/162))

48+

49+# 1.2.2.0 (2021-11-21)

50+

51+## Other

52+

53+* Support GHC 9.2 ([#145](https://github.com/circuithub/rel8/pull/145))

54+* Correct the documentation for `except` ([#147](https://github.com/circuithub/rel8/pull/147))

55+* Support `hasql` 1.5 ([#149](https://github.com/circuithub/rel8/pull/149))

56+

57+# 1.2.1.0 (2021-11-21)

58+

59+## New features

60+

61+* `castTable` has been added, which casts all columns selected from in `Query` according to the types of columns. This can occasionally be useful when using `many`/`some` on older PostgreSQL versions. ([#137](https://github.com/circuithub/rel8/pull/137))

62+

63+* Added `<:`, `<=:`, `>:`, `>=:`, `greatest` and `least`, which sort all columns in a table lexicographically. These operators are like the `<.` operators which operate on `Expr`s, but the `<:` operate on entire tables. ([#139](https://github.com/circuithub/rel8/pull/139))

64+

65+## Other

66+

67+* Support opaleye-0.8 ([#142](https://github.com/circuithub/rel8/pull/142))

68+

69+# 1.2.0.0 (2021-10-22)

70+

71+## New features

72+

73+* New `$*` and `$+` operators for projecting out of `ListTable` and `NonEmptyTable` respectively (analogous to the existing `$?` for `MaybeTable`). ([#125](https://github.com/circuithub/rel8/pull/125))

74+

75+## Bug fixes

76+

77+* Fix `UPSERT` support (and add tests), which was broken due to a typo inside Rel8 that made it impossible to construct `Projection`s which are needed by `UPSERT`. ([#134](https://github.com/circuithub/rel8/pull/134))

78+

79+* Remove `DBMin` and `DBMax` instances for `Bool`, which are invalid as far as Postgres is concerned. `and` and `or` can be used to achieve the same thing. ([#126](https://github.com/circuithub/rel8/pull/126))

80+

81+* Fix `aggregateMaybeTable`, `aggregateEitherTable` and `aggregateTheseTable`, which generated invalid SQL previously. ([#127](https://github.com/circuithub/rel8/pull/127))

82+

83+## Breaking changes

84+

85+* `rebind` now takes an additional argument for the "name" of the binding. ([#128](https://github.com/circuithub/rel8/pull/128))

86+

87+# 1.1.0.0 (2021-07-16)

88+

89+## New features

90+

91+* You can derive `Rel8able` for "vanilla" higher-kinded data types - data types that don't use the `Column` type family. For example, the following is now possible:

92+

93+ ```haskell

94+ data MyTable f = MyTable

95+ { myTableX :: f Int32

96+ , myTableY :: f Text

97+ } deriving (Generic, Rel8able)

98+ ```

99+

100+* The `Projectable` and `Biprojectable` type classes have been introduced. These classes model a type of functors and bifunctors (respectively) on tables, where the mapping function is only able to rearrange columns. For example, the following is now possible:

101+

102+ ```haskell

103+ x <- project myTableX <$> many ...

104+ ```

105+

106+* `Insert`'s `onConflict` field now has a new option - `DoUpdate`. This maps to PostgreSQL's `ON CONFLICT DO UPDATE` syntax, which provides upsert support. ([#85](https://github.com/circuithub/rel8/pull/85))

107+

108+* `Insert`, `Update` and `Delete` has all been expanded to work with `Query`s. In particular:

109+

110+ * `Delete` now supports a `USING` sub-query

111+ * `Update` now supports a `FROM` sub-query

112+ * `Insert` can delete the result of any arbitrary `Query` (providing the types match)

113+

114+* The new `Rel8.Tabulate` module has been added, which gives a `Map`-esque interface to writing and composing queries. ([#70](https://github.com/circuithub/rel8/pull/70))

115+

116+* The new `indexed` `Query -> Query` function was added. This function augments each row in a query with it's 0-based index. ([#117](https://github.com/circuithub/rel8/pull/117))

117+

118+## Breaking changes

119+

120+* `Insert`, `Delete` and `Update` have all changed. In particular, for `Insert` users should now replace `rows = xs` with `rows = values xs`. ([#85](https://github.com/circuithub/rel8/pull/85))

121+

5* Rename `whereExists` and `whereNotExists` to `present` and `absent` respectively. ([#57](https://github.com/circuithub/rel8/pull/57))

122* Rename `whereExists` and `whereNotExists` to `present` and `absent` respectively. ([#57](https://github.com/circuithub/rel8/pull/57))

123

7* Simplify `evaluate` to run directly inside the `Query` monad, rendering the `Evaluate` monad unnecessary. ([#56](https://github.com/circuithub/rel8/pull/56))

124* Simplify `evaluate` to run directly inside the `Query` monad, rendering the `Evaluate` monad unnecessary. ([#56](https://github.com/circuithub/rel8/pull/56))

@@ -10,6 +127,14 @@

127

11* `EitherTable`, `ListTable`, `MaybeTable`, `NonEmptyTable` and `TheseTable` now all have an extra parameter which tracks the context of the table. If you manually specified any types before, you need to provide this parameter - usually `Expr` will be the correct choice. ([#101](https://github.com/circuithub/rel8/pull/101))

128* `EitherTable`, `ListTable`, `MaybeTable`, `NonEmptyTable` and `TheseTable` now all have an extra parameter which tracks the context of the table. If you manually specified any types before, you need to provide this parameter - usually `Expr` will be the correct choice. ([#101](https://github.com/circuithub/rel8/pull/101))

129

130+* We've done a lot of work to simplify the internals of Rel8, but some of these are breaking changes. However, most of these API changes shouldn't affect users as they are mostly types used in type inference, or affect classes where users don't need to define their own instances.

131+

132+ * The kind of a `Rel8able` is now `(Type -> Type) -> Type`. Previously it was `(X -> Type) -> Type`.

133+ * `Table` has a new associated type - `FromExprs`. This was previously an open type family.

134+ * `Table` has a new associated type - `Transpose` - and `Recontextualise` has been renamed to `Transposes`. This `Transposes` class now operates in terms of `Transpose`.

135+

136+* `select`, `insert`, `update` and `delete` now produce Hasql `Statement`s, rather than actually running the statement as IO. This allows Rel8 to be used with transaction/connection-managing monads like [`hasql-transaction`](https://hackage.haskell.org/package/hasql-transaction). ([#94](https://github.com/circuithub/rel8/pull/94))

137+

13## Bug fixes

138## Bug fixes

139

15* Fixes a bug where cartesian products of queries using `catListTable`, `catNonEmptyTable`, `catList` and `catNonEmpty` would incorrectly be zipped instead. ([#61](https://github.com/circuithub/rel8/pull/61))

140* Fixes a bug where cartesian products of queries using `catListTable`, `catNonEmptyTable`, `catList` and `catNonEmpty` would incorrectly be zipped instead. ([#61](https://github.com/circuithub/rel8/pull/61))

cabal.project−5

@@ -1,6 +1 @@

1packages: .

2−

3−allow-newer: generic-monoid:base

4−allow-newer: cryptohash-sha1:base

5−allow-newer: cryptohash-md5:base

6−allow-newer: entropy:Cabal

cabal.project.haskell-nix−6

@@ -2,9 +2,3 @@

2-- will interpret them as local packages, and try to build them when we cabal

3-- build. The only reason we have to specify these is for Haskell.nix to know to

4-- override these packages by fetching them rather than using Hackage.

5−

6−source-repository-package

7− type: git

8− location: git://github.com/jcpetruzza/barbies

9− tag: f99b05454874192e3511bd133555dfb6cc6a6ecb

10− --sha256: 0yy2i2jbllwavv5d2176rf8lmm4l1ws90lxkmdlfgvfzqxidx0gi

default.nix+2−2

@@ -1,11 +1,11 @@

1let

2 haskellNix = import (import ./nix/sources.nix)."haskell.nix" {};

4− nixpkgsSrc = haskellNix.sources.nixpkgs-2009;

4+ nixpkgsSrc = haskellNix.sources.nixpkgs-unstable;

6 nixpkgsArgs = haskellNix.nixpkgsArgs;

8− compiler-nix-name = "ghc901";

8+ compiler-nix-name = "ghc924";

10 pkgs = import nixpkgsSrc nixpkgsArgs;

docs/concepts/insert.rst+37−10

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

21``from``

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

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.

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.

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 ()``.

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::

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.

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::

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

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

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::

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

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

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.

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`.

103

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

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 }

docs/cookbook.rst+9−7

@@ -142,23 +142,25 @@ rows, but can also return *tree*\s.

142To understand what this means, we'll consider a small example query for blog

143posts. We want our query to return:

144

145−1. The latest 5 blog posts.

145+1. The latest 5 blog posts that have at least one tag each.

1462. For each blog post, all tags.

147−3. For each blog post, the latest 3 comments.

147+3. For each blog post, the latest 3 comments if they exist.

148

149In Rel8, we can write this query as::

150

151 latestBlogPosts = do

152 post <- each postSchema

153

154+ -- Returns a `NonEmptyTable a` which ends up as a `Data.List.NonEmpty a` after the query is run

154− tags <- aggregate do

155+ tags <- some $ do

155 tag <- each tagSchema

156 tag <- each tagSchema

156 where_ (tagPostId tag ==. postId post)

157 where_ (tagPostId tag ==. postId post)

157− return (listAgg (tagName tag))

158+ return (tagName tag)

158

159

160+ -- Returns a `ListTable a` which ends up as a `[a]` after the query is run

159− latestComments <-

161+ latestComments <-

160− many $

162+ many $

161− limit 3 $

163+ limit 3 $

162 orderBy (commentCreatedAt >$< desc) do

164 orderBy (commentCreatedAt >$< desc) do

163 comment <- each commentSchema

165 comment <- each commentSchema

164 where_ (commentPostId comment ==. postId post)

166 where_ (commentPostId comment ==. postId post)

nix/sources.json+9−9

@@ -5,10 +5,10 @@

5 "homepage": "https://input-output-hk.github.io/haskell.nix",

6 "owner": "input-output-hk",

7 "repo": "haskell.nix",

8− "rev": "3856d2d24dca0ecc71fcfc314253a2a2d07a3c4f",

8+ "rev": "0837156c56cb5350dd9bd84eb424187e00aa1e8a",

9− "sha256": "0s69nasqhkv8n0qmdv075k83p3z584ja9vkzdnp2291mymghvx87",

9+ "sha256": "1djmv5a0vfj78csw2cad6nicrs8iqrp928b9b3v4h7lwwhhzliwl",

10 "type": "tarball",

11− "url": "https://github.com/input-output-hk/haskell.nix/archive/3856d2d24dca0ecc71fcfc314253a2a2d07a3c4f.tar.gz",

11+ "url": "https://github.com/input-output-hk/haskell.nix/archive/0837156c56cb5350dd9bd84eb424187e00aa1e8a.tar.gz",

12 "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"

13 },

14 "niv": {

@@ -17,10 +17,10 @@

17 "homepage": "https://github.com/nmattia/niv",

18 "owner": "nmattia",

19 "repo": "niv",

20− "rev": "e0ca65c81a2d7a4d82a189f1e23a48d59ad42070",

20+ "rev": "acdb1726783637852c01e0ad639ac9cbec28d8c8",

21− "sha256": "1pq9nh1d8nn3xvbdny8fafzw87mj7gsmp6pxkdl65w2g18rmcmzx",

21+ "sha256": "1wszl8q70z6wfgkh2dvgmhhry6qp9nar421qq2ifd17hq2jj9ck3",

22 "type": "tarball",

23− "url": "https://github.com/nmattia/niv/archive/e0ca65c81a2d7a4d82a189f1e23a48d59ad42070.tar.gz",

23+ "url": "https://github.com/nmattia/niv/archive/acdb1726783637852c01e0ad639ac9cbec28d8c8.tar.gz",

24 "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"

25 },

26 "nixpkgs": {

@@ -29,10 +29,10 @@

29 "homepage": null,

30 "owner": "nixos",

31 "repo": "nixpkgs",

32− "rev": "59b8d9cf24e9fcf10341a0923c9bdca088dca8c8",

32+ "rev": "1c1f5649bb9c1b0d98637c8c365228f57126f361",

33− "sha256": "08f38v4b2kcxnbapdwrb54bglka92cxj9qlnqlk5px206jyq9v4c",

33+ "sha256": "0f2nvdijyxfgl5kwyb4465pppd5vkhqxddx6v40k2s0z9jfhj0xl",

34 "type": "tarball",

35− "url": "https://github.com/nixos/nixpkgs/archive/59b8d9cf24e9fcf10341a0923c9bdca088dca8c8.tar.gz",

35+ "url": "https://github.com/nixos/nixpkgs/archive/1c1f5649bb9c1b0d98637c8c365228f57126f361.tar.gz",

36 "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"

37 }

38}

nix/sources.nix+21−1

@@ -31,8 +31,28 @@ let

31 if spec ? branch then "refs/heads/${spec.branch}" else

32 if spec ? tag then "refs/tags/${spec.tag}" else

33 abort "In git source '${name}': Please specify `ref`, `tag` or `branch`!";

34+ submodules = if spec ? submodules then spec.submodules else false;

35+ submoduleArg =

36+ let

37+ nixSupportsSubmodules = builtins.compareVersions builtins.nixVersion "2.4" >= 0;

38+ emptyArgWithWarning =

39+ if submodules == true

40+ then

41+ builtins.trace

42+ (

43+ "The niv input \"${name}\" uses submodules "

44+ + "but your nix's (${builtins.nixVersion}) builtins.fetchGit "

45+ + "does not support them"

46+ )

47+ {}

48+ else {};

49+ in

50+ if nixSupportsSubmodules

51+ then { inherit submodules; }

52+ else emptyArgWithWarning;

34 in

53 in

54+ builtins.fetchGit

35− builtins.fetchGit { url = spec.repo; inherit (spec) rev; inherit ref; };

55+ ({ url = spec.repo; inherit (spec) rev; inherit ref; } // submoduleArg);

37 fetch_local = spec: spec.path;

57 fetch_local = spec: spec.path;

rel8.cabal+30−8

@@ -1,6 +1,6 @@

1cabal-version: 2.0

2name: rel8

3−version: 1.0.0.1

3+version: 1.4.0.0

4synopsis: Hey! Hey! Can u rel8?

5license: BSD3

6license-file: LICENSE

@@ -20,21 +20,23 @@ source-repository head

20library

21 build-depends:

22 aeson

23− , base ^>= 4.14 || ^>=4.15

23+ , base ^>= 4.14 || ^>=4.15 || ^>=4.16

24+ , bifunctors

24 , bytestring

25 , bytestring

25 , case-insensitive

26 , case-insensitive

26 , comonad

27 , comonad

27 , contravariant

28 , contravariant

28− , hasql ^>= 1.4.5.1

29+ , hasql ^>= 1.4.5.1 || ^>= 1.5.0.0 || ^>= 1.6.0.0

29− , opaleye ^>= 0.7.3.0

30+ , opaleye ^>= 0.9.6.1

31+ , pretty

30 , profunctors

32 , profunctors

33+ , product-profunctors

31 , scientific

34 , scientific

32 , semialign

35 , semialign

33 , semigroupoids

36 , semigroupoids

34 , text

37 , text

35 , these

38 , these

36 , time

39 , time

37− , transformers

38 , uuid

40 , uuid

39 default-language:

41 default-language:

40 Haskell2010

42 Haskell2010

@@ -44,6 +46,7 @@ library

44 -Wno-missing-import-lists -Wno-prepositive-qualified-module

46 -Wno-missing-import-lists -Wno-prepositive-qualified-module

45 -Wno-monomorphism-restriction

47 -Wno-monomorphism-restriction

46 -Wno-missing-local-signatures

48 -Wno-missing-local-signatures

49+ -Wno-missing-kind-signatures

47 hs-source-dirs:

50 hs-source-dirs:

48 src

51 src

49 exposed-modules:

52 exposed-modules:

@@ -51,6 +54,7 @@ library

51 Rel8.Expr.Num

54 Rel8.Expr.Num

52 Rel8.Expr.Text

55 Rel8.Expr.Text

53 Rel8.Expr.Time

56 Rel8.Expr.Time

57+ Rel8.Tabulate

55 other-modules:

59 other-modules:

56 Rel8.Aggregate

60 Rel8.Aggregate

@@ -62,6 +66,7 @@ library

62 Rel8.Column.List

66 Rel8.Column.List

63 Rel8.Column.Maybe

67 Rel8.Column.Maybe

64 Rel8.Column.NonEmpty

68 Rel8.Column.NonEmpty

69+ Rel8.Column.Null

65 Rel8.Column.These

70 Rel8.Column.These

67 Rel8.Expr

72 Rel8.Expr

@@ -77,6 +82,7 @@ library

77 Rel8.Expr.Order

82 Rel8.Expr.Order

78 Rel8.Expr.Sequence

83 Rel8.Expr.Sequence

79 Rel8.Expr.Serialize

84 Rel8.Expr.Serialize

85+ Rel8.Expr.Window

81 Rel8.FCF

87 Rel8.FCF

@@ -103,19 +109,23 @@ library

103 Rel8.Query.Evaluate

109 Rel8.Query.Evaluate

104 Rel8.Query.Exists

110 Rel8.Query.Exists

105 Rel8.Query.Filter

111 Rel8.Query.Filter

112+ Rel8.Query.Indexed

106 Rel8.Query.Limit

113 Rel8.Query.Limit

107 Rel8.Query.List

114 Rel8.Query.List

108 Rel8.Query.Maybe

115 Rel8.Query.Maybe

109 Rel8.Query.Null

116 Rel8.Query.Null

110 Rel8.Query.Opaleye

117 Rel8.Query.Opaleye

111 Rel8.Query.Order

118 Rel8.Query.Order

119+ Rel8.Query.Rebind

112 Rel8.Query.Set

120 Rel8.Query.Set

113 Rel8.Query.SQL

121 Rel8.Query.SQL

114 Rel8.Query.These

122 Rel8.Query.These

115 Rel8.Query.Values

123 Rel8.Query.Values

124+ Rel8.Query.Window

116

125

117 Rel8.Schema.Context.Nullify

126 Rel8.Schema.Context.Nullify

118 Rel8.Schema.Dict

127 Rel8.Schema.Dict

128+ Rel8.Schema.Field

119 Rel8.Schema.HTable

129 Rel8.Schema.HTable

120 Rel8.Schema.HTable.Either

130 Rel8.Schema.HTable.Either

121 Rel8.Schema.HTable.Identity

131 Rel8.Schema.HTable.Identity

@@ -137,10 +147,15 @@ library

137

147

138 Rel8.Statement.Delete

148 Rel8.Statement.Delete

139 Rel8.Statement.Insert

149 Rel8.Statement.Insert

150+ Rel8.Statement.OnConflict

140 Rel8.Statement.Returning

151 Rel8.Statement.Returning

141 Rel8.Statement.Select

152 Rel8.Statement.Select

153+ Rel8.Statement.Set

154+ Rel8.Statement.SQL

142 Rel8.Statement.Update

155 Rel8.Statement.Update

156+ Rel8.Statement.Using

143 Rel8.Statement.View

157 Rel8.Statement.View

158+ Rel8.Statement.Where

144

159

145 Rel8.Table

160 Rel8.Table

146 Rel8.Table.ADT

161 Rel8.Table.ADT

@@ -155,15 +170,18 @@ library

155 Rel8.Table.Maybe

170 Rel8.Table.Maybe

156 Rel8.Table.Name

171 Rel8.Table.Name

157 Rel8.Table.NonEmpty

172 Rel8.Table.NonEmpty

173+ Rel8.Table.Null

158 Rel8.Table.Nullify

174 Rel8.Table.Nullify

159 Rel8.Table.Opaleye

175 Rel8.Table.Opaleye

160 Rel8.Table.Ord

176 Rel8.Table.Ord

161 Rel8.Table.Order

177 Rel8.Table.Order

178+ Rel8.Table.Projection

162 Rel8.Table.Rel8able

179 Rel8.Table.Rel8able

163 Rel8.Table.Serialize

180 Rel8.Table.Serialize

164 Rel8.Table.These

181 Rel8.Table.These

165 Rel8.Table.Transpose

182 Rel8.Table.Transpose

166 Rel8.Table.Undefined

183 Rel8.Table.Undefined

184+ Rel8.Table.Window

167

185

168 Rel8.Type

186 Rel8.Type

169 Rel8.Type.Array

187 Rel8.Type.Array

@@ -182,6 +200,9 @@ library

182 Rel8.Type.Sum

200 Rel8.Type.Sum

183 Rel8.Type.Tag

201 Rel8.Type.Tag

184

202

203+ Rel8.Window

204+

205+

185test-suite tests

206test-suite tests

186 type: exitcode-stdio-1.0

207 type: exitcode-stdio-1.0

187 build-depends:

208 build-depends:

@@ -190,9 +211,9 @@ test-suite tests

190 , case-insensitive

211 , case-insensitive

191 , containers

212 , containers

192 , hasql

213 , hasql

214+ , hasql-transaction

193− , hedgehog ^>=1.0.2

215+ , hedgehog ^>= 1.0 || ^>= 1.1

194− , lifted-base ^>=0.2.3.12

216+ , mmorph

195− , monad-control ^>=1.0.2.3

196 , rel8

217 , rel8

197 , scientific

218 , scientific

198 , tasty

219 , tasty

@@ -200,6 +221,7 @@ test-suite tests

200 , text

221 , text

201 , time

222 , time

202 , tmp-postgres ^>=1.34.1.0

223 , tmp-postgres ^>=1.34.1.0

224+ , transformers

203 , uuid

225 , uuid

204

226

205 other-modules:

227 other-modules:

shell.nix+1−1

@@ -1,6 +1,6 @@

1let

2 sources = import ./nix/sources.nix;

3− pkgs = import sources.nixpkgs {};

3+ pkgs = import sources.nixpkgs {overlays = [];};

4 hsPkgs = import ./default.nix;

5in

6 hsPkgs.shellFor {

src/Rel8.hs+295−8

@@ -38,6 +38,7 @@ module Rel8

38 , HMaybe

39 , HList

40 , HNonEmpty

41+ , HNull

41 , HThese

42 , HThese

42 , Lift

43 , Lift

@@ -46,16 +47,18 @@ module Rel8

46 , Transposes

47 , Transposes

47 , AltTable((<|>:))

48 , AltTable((<|>:))

48 , AlternativeTable( emptyTable )

49 , AlternativeTable( emptyTable )

49− , EqTable, (==:), (/=:)

50+ , EqTable(..), (==:), (/=:)

50− , OrdTable, ascTable, descTable

51+ , OrdTable(..), (<:), (<=:), (>:), (>=:), ascTable, descTable, greatest, least

51 , lit

52 , lit

52 , bool

53 , bool

53 , case_

54 , case_

55+ , castTable

55 -- ** @MaybeTable@

57 -- ** @MaybeTable@

56 , MaybeTable

58 , MaybeTable

57 , maybeTable, ($?), nothingTable, justTable

59 , maybeTable, ($?), nothingTable, justTable

58 , isNothingTable, isJustTable

60 , isNothingTable, isJustTable

61+ , fromMaybeTable

59 , optional

62 , optional

60 , catMaybeTable

63 , catMaybeTable

61 , traverseMaybeTable

64 , traverseMaybeTable

@@ -78,6 +81,7 @@ module Rel8

78 , isThisTable, isThatTable, isThoseTable

81 , isThisTable, isThatTable, isThoseTable

79 , hasHereTable, hasThereTable

82 , hasHereTable, hasThereTable

80 , justHereTable, justThereTable

83 , justHereTable, justThereTable

84+ , alignMaybeTable

81 , alignBy

85 , alignBy

82 , keepHereTable, loseHereTable

86 , keepHereTable, loseHereTable

83 , keepThereTable, loseThereTable

87 , keepThereTable, loseThereTable

@@ -90,7 +94,7 @@ module Rel8

91 -- ** @ListTable@

95 -- ** @ListTable@

92 , ListTable

96 , ListTable

93− , listTable

97+ , listTable, ($*)

94 , nameListTable

98 , nameListTable

95 , many

99 , many

96 , manyExpr

100 , manyExpr

@@ -99,21 +103,44 @@ module Rel8

103

100 -- ** @NonEmptyTable@

104 -- ** @NonEmptyTable@

101 , NonEmptyTable

105 , NonEmptyTable

102− , nonEmptyTable

106+ , nonEmptyTable, ($+)

103 , nameNonEmptyTable

107 , nameNonEmptyTable

104 , some

108 , some

105 , someExpr

109 , someExpr

106 , catNonEmptyTable

110 , catNonEmptyTable

107 , catNonEmpty

111 , catNonEmpty

108

112

109− -- ** @ADT@

113+ -- ** @NullTable@

114+ , NullTable

115+ , nullableTable, nullTable, nullifyTable

116+ , isNullTable, isNonNullTable

117+ , catNullTable

118+ , nameNullTable

119+ , toNullTable, toMaybeTable

120+

121+ -- ** Algebraic data types / sum types

122+ -- $adts

123+

124+ -- *** Naming of ADTs

125+ -- $naming

126+ , NameADT, nameADT

110 , ADT, ADTable

127 , ADT, ADTable

128+

129+ -- *** Deconstruction of ADTs

130+ -- $deconstruction

131+ , DeconstructADT, deconstructADT

132+

133+ -- *** Construction of ADTs

134+ -- $construction

111 , BuildADT, buildADT

135 , BuildADT, buildADT

112 , ConstructADT, constructADT

136 , ConstructADT, constructADT

113− , DeconstructADT, deconstructADT

137+

114− , NameADT, nameADT

138+ -- *** Other ADT operations

115 , AggregateADT, aggregateADT

139 , AggregateADT, aggregateADT

116

140

141+ -- *** Miscellaneous notes

142+ -- $misc-notes

143+

117 -- ** @HKD@

144 -- ** @HKD@

118 , HKD, HKDable

145 , HKD, HKDable

119 , BuildHKD, buildHKD

146 , BuildHKD, buildHKD

@@ -138,6 +165,7 @@ module Rel8

138 -- ** @null@

165 -- ** @null@

139 , NotNull

166 , NotNull

140 , Nullable

167 , Nullable

168+ , Homonullable

141 , null

169 , null

142 , nullify

170 , nullify

143 , nullable

171 , nullable

@@ -156,6 +184,7 @@ module Rel8

156 , (==.), (/=.), (==?), (/=?)

184 , (==.), (/=.), (==?), (/=?)

157 , in_

185 , in_

158 , boolExpr, caseExpr

186 , boolExpr, caseExpr

187+ , like, ilike

159

188

160 -- ** Ordering

189 -- ** Ordering

161 , DBOrd

190 , DBOrd

@@ -173,6 +202,13 @@ module Rel8

173 , Query

202 , Query

174 , showQuery

203 , showQuery

175

204

205+ -- ** Projection

206+ , Projection

207+ , Projectable( project )

208+ , Biprojectable( biproject )

209+ , Projecting

210+ , Field

211+

176 -- ** Selecting rows

212 -- ** Selecting rows

177 , Selects

213 , Selects

178 , each

214 , each

@@ -217,10 +253,11 @@ module Rel8

217 , countRows

253 , countRows

218 , groupBy

254 , groupBy

219 , listAgg, listAggExpr

255 , listAgg, listAggExpr

256+ , mode

220 , nonEmptyAgg, nonEmptyAggExpr

257 , nonEmptyAgg, nonEmptyAggExpr

221 , DBMax, max

258 , DBMax, max

222 , DBMin, min

259 , DBMin, min

223− , DBSum, sum, sumWhere

260+ , DBSum, sum, sumWhere, avg

224 , DBString, stringAgg

261 , DBString, stringAgg

225 , count

262 , count

226 , countStar

263 , countStar

@@ -237,6 +274,32 @@ module Rel8

237 , nullsFirst

274 , nullsFirst

238 , nullsLast

275 , nullsLast

239

276

277+ -- ** Window functions

278+ , Window

279+ , window

280+ , Partition

281+ , over

282+ , partitionBy

283+ , orderPartitionBy

284+ , cumulative

285+ , cumulative_

286+ , currentRow

287+ , rowNumber

288+ , rank

289+ , denseRank

290+ , percentRank

291+ , cumeDist

292+ , ntile

293+ , lag

294+ , lead

295+ , firstValue

296+ , lastValue

297+ , nthValue

298+ , indexed

299+

300+ -- ** Bindings

301+ , rebind

302+

240 -- * IO

303 -- * IO

241 , Serializable

304 , Serializable

242 , ToExprs

305 , ToExprs

@@ -251,22 +314,27 @@ module Rel8

251 -- ** @INSERT@

314 -- ** @INSERT@

252 , Insert(..)

315 , Insert(..)

253 , OnConflict(..)

316 , OnConflict(..)

317+ , Upsert(..)

254 , insert

318 , insert

255 , unsafeDefault

319 , unsafeDefault

320+ , showInsert

256

321

257 -- ** @DELETE@

322 -- ** @DELETE@

258 , Delete(..)

323 , Delete(..)

259 , delete

324 , delete

325+ , showDelete

260

326

261 -- ** @UPDATE@

327 -- ** @UPDATE@

262 , Update(..)

328 , Update(..)

263 , update

329 , update

330+ , showUpdate

264

331

265 -- ** @.. RETURNING@

332 -- ** @.. RETURNING@

266 , Returning(..)

333 , Returning(..)

267

334

268 -- ** @CREATE VIEW@

335 -- ** @CREATE VIEW@

269 , createView

336 , createView

337+ , createOrReplaceView

270

338

271 -- ** Sequences

339 -- ** Sequences

272 , nextval

340 , nextval

@@ -285,6 +353,7 @@ import Rel8.Column.Lift

285import Rel8.Column.List

353import Rel8.Column.List

286import Rel8.Column.Maybe

354import Rel8.Column.Maybe

287import Rel8.Column.NonEmpty

355import Rel8.Column.NonEmpty

356+import Rel8.Column.Null

288import Rel8.Column.These

357import Rel8.Column.These

289import Rel8.Expr

358import Rel8.Expr

290import Rel8.Expr.Aggregate

359import Rel8.Expr.Aggregate

@@ -298,6 +367,8 @@ import Rel8.Expr.Ord

298import Rel8.Expr.Order

367import Rel8.Expr.Order

299import Rel8.Expr.Serialize

368import Rel8.Expr.Serialize

300import Rel8.Expr.Sequence

369import Rel8.Expr.Sequence

370+import Rel8.Expr.Text ( like, ilike )

371+import Rel8.Expr.Window hiding ( cumulative )

301import Rel8.Generic.Rel8able ( KRel8able, Rel8able )

372import Rel8.Generic.Rel8able ( KRel8able, Rel8able )

302import Rel8.Order

373import Rel8.Order

303import Rel8.Query

374import Rel8.Query

@@ -308,15 +379,19 @@ import Rel8.Query.Either

308import Rel8.Query.Evaluate

379import Rel8.Query.Evaluate

309import Rel8.Query.Exists

380import Rel8.Query.Exists

310import Rel8.Query.Filter

381import Rel8.Query.Filter

382+import Rel8.Query.Indexed

311import Rel8.Query.Limit

383import Rel8.Query.Limit

312import Rel8.Query.List

384import Rel8.Query.List

313import Rel8.Query.Maybe

385import Rel8.Query.Maybe

314import Rel8.Query.Null

386import Rel8.Query.Null

315import Rel8.Query.Order

387import Rel8.Query.Order

388+import Rel8.Query.Rebind

316import Rel8.Query.SQL (showQuery)

389import Rel8.Query.SQL (showQuery)

317import Rel8.Query.Set

390import Rel8.Query.Set

318import Rel8.Query.These

391import Rel8.Query.These

319import Rel8.Query.Values

392import Rel8.Query.Values

393+import Rel8.Query.Window

394+import Rel8.Schema.Field

320import Rel8.Schema.HTable

395import Rel8.Schema.HTable

321import Rel8.Schema.Name

396import Rel8.Schema.Name

322import Rel8.Schema.Null hiding ( nullable )

397import Rel8.Schema.Null hiding ( nullable )

@@ -324,8 +399,10 @@ import Rel8.Schema.Result ( Result )

324import Rel8.Schema.Table

399import Rel8.Schema.Table

325import Rel8.Statement.Delete

400import Rel8.Statement.Delete

326import Rel8.Statement.Insert

401import Rel8.Statement.Insert

402+import Rel8.Statement.OnConflict

327import Rel8.Statement.Returning

403import Rel8.Statement.Returning

328import Rel8.Statement.Select

404import Rel8.Statement.Select

405+import Rel8.Statement.SQL

329import Rel8.Statement.Update

406import Rel8.Statement.Update

330import Rel8.Statement.View

407import Rel8.Statement.View

331import Rel8.Table

408import Rel8.Table

@@ -340,12 +417,16 @@ import Rel8.Table.List

340import Rel8.Table.Maybe

417import Rel8.Table.Maybe

341import Rel8.Table.Name

418import Rel8.Table.Name

342import Rel8.Table.NonEmpty

419import Rel8.Table.NonEmpty

420+import Rel8.Table.Null

421+import Rel8.Table.Opaleye ( castTable )

343import Rel8.Table.Ord

422import Rel8.Table.Ord

344import Rel8.Table.Order

423import Rel8.Table.Order

424+import Rel8.Table.Projection

345import Rel8.Table.Rel8able ()

425import Rel8.Table.Rel8able ()

346import Rel8.Table.Serialize

426import Rel8.Table.Serialize

347import Rel8.Table.These

427import Rel8.Table.These

348import Rel8.Table.Transpose

428import Rel8.Table.Transpose

429+import Rel8.Table.Window

349import Rel8.Type

430import Rel8.Type

350import Rel8.Type.Composite

431import Rel8.Type.Composite

351import Rel8.Type.Eq

432import Rel8.Type.Eq

@@ -360,6 +441,7 @@ import Rel8.Type.ReadShow

360import Rel8.Type.Semigroup

441import Rel8.Type.Semigroup

361import Rel8.Type.String

442import Rel8.Type.String

362import Rel8.Type.Sum

443import Rel8.Type.Sum

444+import Rel8.Window

363

445

364

446

365-- $running

447-- $running

@@ -367,3 +449,208 @@ import Rel8.Type.Sum

367-- provides 'select', 'insert', 'update' and 'delete' functions. Note that

449-- provides 'select', 'insert', 'update' and 'delete' functions. Note that

368-- 'insert', 'update' and 'delete' will generally need the

450-- 'insert', 'update' and 'delete' will generally need the

369-- `DuplicateRecordFields` language extension enabled.

451-- `DuplicateRecordFields` language extension enabled.

452+

453+-- $adts

454+-- Algebraic data types can be modelled between Haskell and SQL.

455+--

456+-- * Your SQL table needs a certain text field that tags which Haskell constructor is in use.

457+-- * You have to use a few combinators to specify the sum type's individual constructors.

458+-- * If you want to do case analysis at the @Expr@ (SQL) level, you can use 'maybe'/'either'-like eliminators.

459+--

460+-- The documentation in this section will assume a set of database types like this:

461+--

462+-- @

463+-- data Thing f = ThingEmployer (Employer f) | ThingPotato (Potato f) | Nullary

464+-- deriving stock Generic

465+--

466+-- data Employer f = Employer { employerId :: f Int32, employerName :: f Text}

467+-- deriving stock Generic

468+-- deriving anyclass Rel8able

469+--

470+-- data Potato f = Potato { size :: f Int32, grower :: f Text }

471+-- deriving stock Generic

472+-- deriving anyclass Rel8able

473+-- @

474+

475+-- $naming

476+--

477+-- First, in your 'TableSchema', name your type like this:

478+--

479+-- @

480+-- thingSchema :: TableSchema (ADT Thing Name)

481+-- thingSchema =

482+-- TableSchema

483+-- { schema = Nothing,

484+-- name = \"thing\",

485+-- columns =

486+-- nameADT @Thing

487+-- \"tag\"

488+-- Employer

489+-- { employerName = \"name\",

490+-- employerId = \"id\"

491+-- }

492+-- Potato {size = \"size\", grower = \"Mary\"}

493+-- }

494+-- @

495+--

496+-- Note that @nameADT \@Thing "tag"@ is variadic: it accepts one

497+-- argument per constructor, except the nullary ones (Nullary) because

498+-- there's nothing to do for them.

499+

500+-- $deconstruction

501+--

502+-- To deconstruct sum types at the SQL level, use 'deconstructADT',

503+-- which is also variadic, and has one argument for each

504+-- constructor. Similar to 'maybe'.

505+--

506+-- @

507+-- query :: Query (ADT Thing Expr)

508+-- query = do

509+-- thingExpr <- each thingSchema

510+-- where_ $

511+-- deconstructADT @Thing

512+-- (\employer -> employerName employer ==. lit \"Mary\")

513+-- (\potato -> grower potato ==. lit \"Mary\")

514+-- (lit False) -- Nullary case

515+-- thingExpr

516+-- pure thingExpr

517+-- @

518+--

519+-- SQL output:

520+--

521+-- @

522+-- SELECT

523+-- CAST("tag0_1" AS text) as "tag",

524+-- CAST("id1_1" AS int4) as "ThingEmployer/_1/employerId",

525+-- CAST("name2_1" AS text) as "ThingEmployer/_1/employerName",

526+-- CAST("size3_1" AS int4) as "ThingPotato/_1/size",

527+-- CAST("Mary4_1" AS text) as "ThingPotato/_1/grower"

528+-- FROM (SELECT

529+-- *

530+-- FROM (SELECT

531+-- "tag" as "tag0_1",

532+-- "id" as "id1_1",

533+-- "name" as "name2_1",

534+-- "size" as "size3_1",

535+-- "Mary" as "Mary4_1"

536+-- FROM "thing" as "T1") as "T1"

537+-- WHERE (CASE WHEN ("tag0_1") = (CAST(E'ThingPotato' AS text)) THEN ("Mary4_1") = (CAST(E'Mary' AS text))

538+-- WHEN ("tag0_1") = (CAST(E'Nullary' AS text)) THEN CAST(FALSE AS bool) ELSE ("name2_1") = (CAST(E'Mary' AS text)) END)) as "T1"

539+-- @

540+

541+-- $construction

542+--

543+-- To construct an ADT, you can use 'buildADT' or 'constructADT'. Consider the following type:

544+--

545+-- @

546+-- data Task f = Pending | Complete (CompletedTask f)

547+-- @

548+--

549+-- 'buildADT' is for constructing values of 'Task' in the 'Expr'

550+-- context. 'buildADT' needs two type-level arguments before its type

551+-- makes any sense. The first argument is the type of the "ADT", which

552+-- in our case is 'Task'. The second is the name of the constructor we

553+-- want to use. So that means we have the following possible

554+-- instantiations of 'buildADT' for 'Task':

555+--

556+-- @

557+-- > :t buildADT @Task @\"Pending\"

558+-- buildADT @Task @\"Pending\" :: ADT Task Expr

559+-- > :t buildADT @Task @\"Complete\"

560+-- buildADT @Task @\"Complete\" :: CompletedTask Expr -> ADT Task Expr

561+-- @

562+--

563+-- Note that as the "Pending" constructor has no fields, @buildADT

564+-- \@Task \@"Pending"@ is equivalent to @lit Pending@. But @buildADT

565+-- \@Task \@"Complete"@ is not the same as @lit . Complete@:

566+--

567+-- @

568+-- > :t lit . Complete

569+-- lit . Complete :: CompletedTask Result -> ADT Task Expr

570+-- @

571+--

572+--

573+-- Note that the former takes a @CompletedTask Expr@ while the latter

574+-- takes a @CompletedTask Result@. The former is more powerful because

575+-- you can construct @Task@s using dynamic values coming a database

576+-- query.

577+--

578+-- To show what this can look like in SQL, consider:

579+--

580+-- @

581+-- > :{

582+-- showQuery $ values

583+-- [ buildADT @Task @\"Pending\"

584+-- , buildADT @Task @\"Complete\" CompletedTask {date = Rel8.Expr.Time.now}

585+-- ]

586+-- :}

587+-- @

588+--

589+-- This produces the following SQL:

590+--

591+-- @

592+-- SELECT

593+-- CAST(\"values0_1\" AS text) as \"tag\",

594+-- CAST(\"values1_1\" AS timestamptz) as \"Complete/_1/date\"

595+-- FROM (SELECT

596+-- *

597+-- FROM (SELECT \"column1\" as \"values0_1\",

598+-- \"column2\" as \"values1_1\"

599+-- FROM

600+-- (VALUES

601+-- (CAST(E'Pending' AS text),CAST(NULL AS timestamptz)),

602+-- (CAST(E'Complete' AS text),CAST(now() AS timestamptz))) as \"V\") as \"T1\") as \"T1\"

603+-- @

604+--

605+-- This is what you get if you run it in @psql@:

606+--

607+--

608+-- @

609+-- tag | Complete/_1/date

610+-- ----------+-------------------------------

611+-- Pending |

612+-- Complete | 2022-05-19 21:28:23.969065+00

613+-- (2 rows)

614+-- @

615+--

616+-- "constructADT" is less convenient but more general alternative to

617+-- "buildADT". It requires only one type-level argument for its type

618+-- to make sense:

619+--

620+-- @

621+-- > :t constructADT @Task

622+-- constructADT @Task

623+-- :: (forall r. r -> (CompletedTask Expr -> r) -> r) -> ADT Task Expr

624+-- @

625+--

626+-- This might still seem a bit opaque, but basically it gives you a

627+-- Church-encoded constructor for arbitrary algebraic data types. You

628+-- might use it as follows:

629+--

630+-- @

631+-- let

632+-- pending :: ADT Task Expr

633+-- pending = constructADT @Task $ \pending _complete -> pending

634+--

635+-- complete :: ADT Task Expr

636+-- complete = constructADT @Task $ \_pending complete -> complete CompletedTask {date = Rel8.Expr.Time.now}

637+-- @

638+--

639+-- These values are otherwise identical to the ones we saw above with

640+-- @buildADT@, it's just a different style of constructing them.

641+--

642+

643+-- $misc-notes

644+--

645+-- 1. Note that the order of the arguments for all of these functions

646+-- is determined by the order of the constructors in the data

647+-- definition. If it were @data Task = Complete (CompletedTask f) |

648+-- Pending@ then the order of all the invocations of @constructADT@

649+-- and @deconstructADT@ would need to change.

650+--

651+-- 2. Maybe this is obvious, but just to spell it out: once you're in

652+-- the @Result@ context, you can of course construct @Task@ values

653+-- normally and use standard Haskell pattern-matching. @constructADT@

654+-- and @deconstructADT@ are specifically only needed in the @Expr@

655+-- context, and they allow you to do the equivalent of pattern

656+-- matching in PostgreSQL.

src/Rel8/Aggregate.hs+19−43

@@ -2,29 +2,31 @@

2{-# language FlexibleContexts #-}

3{-# language FlexibleInstances #-}

4{-# language MultiParamTypeClasses #-}

5−{-# language NamedFieldPuns #-}

6{-# language RankNTypes #-}

5{-# language RankNTypes #-}

7{-# language StandaloneKindSignatures #-}

6{-# language StandaloneKindSignatures #-}

8{-# language TypeFamilies #-}

7{-# language TypeFamilies #-}

9{-# language UndecidableInstances #-}

8{-# language UndecidableInstances #-}

11module Rel8.Aggregate

10module Rel8.Aggregate

12− ( Aggregate(..), foldInputs, mapInputs

11+ ( Aggregate(..), zipOutputs

13− , Aggregator(..), unsafeMakeAggregate

12+ , unsafeMakeAggregate

14 , Aggregates

13 , Aggregates

15 )

14 )

16where

15where

18-- base

17-- base

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

18+import Control.Applicative ( liftA2 )

20import Data.Functor.Identity ( Identity( Identity ) )

19import Data.Functor.Identity ( Identity( Identity ) )

21import Data.Kind ( Constraint, Type )

20import Data.Kind ( Constraint, Type )

22import Prelude

21import Prelude

23+-- profunctors

24+import Data.Profunctor ( dimap )

25+

24-- opaleye

26-- opaleye

25−import qualified Opaleye.Internal.Aggregate as Opaleye

27+import qualified Opaleye.Aggregate as Opaleye

26import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye

28import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye

27−import qualified Opaleye.Internal.PackMap as Opaleye

29+import qualified Opaleye.Internal.Column as Opaleye

29-- rel8

31-- rel8

30import Rel8.Expr ( Expr )

32import Rel8.Expr ( Expr )

@@ -40,11 +42,7 @@ import Rel8.Table.Transpose ( Transposes )

40import Rel8.Type ( DBType )

42import Rel8.Type ( DBType )

43−-- | An @Aggregate a@ describes how to aggregate @Table@s of type @a@. You can

45+-- | 'Aggregate' is a special context used by 'Rel8.aggregate'.

44−-- unpack an @Aggregate@ back to @a@ by running it with 'Rel8.aggregate'. As

45−-- @Aggregate@ is almost an 'Applicative' functor - but there is no 'pure'

46−-- operation. This means 'Aggregate' is an instance of 'Apply', and you can

47−-- combine @Aggregate@s using the @<.>@ combinator.

48type Aggregate :: K.Context

46type Aggregate :: K.Context

49newtype Aggregate a = Aggregate (Opaleye.Aggregator () (Expr a))

47newtype Aggregate a = Aggregate (Opaleye.Aggregator () (Expr a))

@@ -61,47 +59,25 @@ instance Sql DBType a => Table Aggregate (Aggregate a) where

61 fromResult (HIdentity (Identity a)) = a

59 fromResult (HIdentity (Identity a)) = a

64−-- | @Aggregates a b@ means that the columns in @a@ are all 'Aggregate' 'Expr's

62+-- | @Aggregates a b@ means that the columns in @a@ are all 'Aggregate's

65−-- for the columns in @b@.

63+-- for the 'Expr' columns in @b@.

66type Aggregates :: Type -> Type -> Constraint

64type Aggregates :: Type -> Type -> Constraint

67class Transposes Aggregate Expr aggregates exprs => Aggregates aggregates exprs

65class Transposes Aggregate Expr aggregates exprs => Aggregates aggregates exprs

68instance Transposes Aggregate Expr aggregates exprs => Aggregates aggregates exprs

66instance Transposes Aggregate Expr aggregates exprs => Aggregates aggregates exprs

71−foldInputs :: forall (a :: Type) (b :: Type). Monoid b

69+zipOutputs :: ()

72− => (Maybe Aggregator -> Opaleye.PrimExpr -> b) -> Aggregate a -> b

70+ => (Expr a -> Expr b -> Expr c) -> Aggregate a -> Aggregate b -> Aggregate c

73−foldInputs f (Aggregate (Opaleye.Aggregator (Opaleye.PackMap agg))) =

71+zipOutputs f (Aggregate a) (Aggregate b) = Aggregate (liftA2 f a b)

74− getConst $ flip agg () $ \(aggregator, a) ->

75− Const $ f (detuplize <$> aggregator) a

76− where

77− detuplize (operation, ordering, distinction) =

78− Aggregator {operation, ordering, distinction}

79−

80−

81−mapInputs :: forall (a :: Type). ()

82− => (Opaleye.PrimExpr -> Opaleye.PrimExpr) -> Aggregate a -> Aggregate a

83−mapInputs transform (Aggregate (Opaleye.Aggregator (Opaleye.PackMap agg))) =

84− Aggregate $ Opaleye.Aggregator $ Opaleye.PackMap $ agg . \f input ->

85− f (fmap transform input)

86−

87−

88−type Aggregator :: Type

89−data Aggregator = Aggregator

90− { operation :: Opaleye.AggrOp

91− , ordering :: [Opaleye.OrderExpr]

92− , distinction :: Opaleye.AggrDistinct

93− }

96−unsafeMakeAggregate :: forall (input :: Type) (output :: Type). ()

74+unsafeMakeAggregate :: forall (input :: Type) (output :: Type) n n' a a'. ()

97 => (Expr input -> Opaleye.PrimExpr)

75 => (Expr input -> Opaleye.PrimExpr)

98 -> (Opaleye.PrimExpr -> Expr output)

76 -> (Opaleye.PrimExpr -> Expr output)

99− -> Maybe Aggregator

77+ -> Opaleye.Aggregator (Opaleye.Field_ n a) (Opaleye.Field_ n' a')

100 -> Expr input

78 -> Expr input

101 -> Aggregate output

79 -> Aggregate output

102unsafeMakeAggregate input output aggregator expr =

80unsafeMakeAggregate input output aggregator expr =

103− Aggregate $ Opaleye.Aggregator $ Opaleye.PackMap $ \f _ ->

81+ Aggregate $ dimap in_ out aggregator

104− output <$> f (tuplize <$> aggregator, input expr)

82+ where out = output . Opaleye.unColumn

105− where

83+ in_ = Opaleye.Column . input . const expr

106− tuplize Aggregator {operation, ordering, distinction} =

107− (operation, ordering, distinction)

src/Rel8/Column/Either.hs+1−6

@@ -12,10 +12,7 @@ import Data.Kind ( Type )

12import Prelude

14-- rel8

15−import Rel8.Aggregate ( Aggregate )

16−import Rel8.Expr ( Expr )

17import qualified Rel8.Schema.Kind as K

15import qualified Rel8.Schema.Kind as K

18−import Rel8.Schema.Name ( Name )

19import Rel8.Schema.Result ( Result )

16import Rel8.Schema.Result ( Result )

20import Rel8.Table.Either ( EitherTable )

17import Rel8.Table.Either ( EitherTable )

@@ -25,7 +22,5 @@ import Rel8.Table.Either ( EitherTable )

25-- 'Result' context.

22-- 'Result' context.

26type HEither :: K.Context -> Type -> Type -> Type

23type HEither :: K.Context -> Type -> Type -> Type

27type family HEither context = either | either -> context where

24type family HEither context = either | either -> context where

28− HEither Aggregate = EitherTable Aggregate

29− HEither Expr = EitherTable Expr

30− HEither Name = EitherTable Name

31 HEither Result = Either

25 HEither Result = Either

26+ HEither context = EitherTable context

src/Rel8/Column/List.hs+1−6

@@ -12,10 +12,7 @@ import Data.Kind ( Type )

12import Prelude ()

14-- rel8

15−import Rel8.Aggregate ( Aggregate )

16−import Rel8.Expr ( Expr )

17import qualified Rel8.Schema.Kind as K

15import qualified Rel8.Schema.Kind as K

18−import Rel8.Schema.Name ( Name )

19import Rel8.Schema.Result ( Result )

16import Rel8.Schema.Result ( Result )

20import Rel8.Table.List ( ListTable )

17import Rel8.Table.List ( ListTable )

@@ -24,7 +21,5 @@ import Rel8.Table.List ( ListTable )

24-- @a@ in the 'Expr' context, and a @[a]@ in the 'Result' context.

21-- @a@ in the 'Expr' context, and a @[a]@ in the 'Result' context.

25type HList :: K.Context -> Type -> Type

22type HList :: K.Context -> Type -> Type

26type family HList context = list | list -> context where

23type family HList context = list | list -> context where

27− HList Aggregate = ListTable Aggregate

28− HList Expr = ListTable Expr

29− HList Name = ListTable Name

30 HList Result = []

24 HList Result = []

25+ HList context = ListTable context

src/Rel8/Column/Maybe.hs+1−6

@@ -12,10 +12,7 @@ import Data.Kind ( Type )

12import Prelude

14-- rel8

15−import Rel8.Aggregate ( Aggregate )

16−import Rel8.Expr ( Expr )

17import qualified Rel8.Schema.Kind as K

15import qualified Rel8.Schema.Kind as K

18−import Rel8.Schema.Name ( Name )

19import Rel8.Schema.Result ( Result )

16import Rel8.Schema.Result ( Result )

20import Rel8.Table.Maybe ( MaybeTable )

17import Rel8.Table.Maybe ( MaybeTable )

@@ -25,7 +22,5 @@ import Rel8.Table.Maybe ( MaybeTable )

25-- context.

22-- context.

26type HMaybe :: K.Context -> Type -> Type

23type HMaybe :: K.Context -> Type -> Type

27type family HMaybe context = maybe | maybe -> context where

24type family HMaybe context = maybe | maybe -> context where

28− HMaybe Aggregate = MaybeTable Aggregate

29− HMaybe Expr = MaybeTable Expr

30− HMaybe Name = MaybeTable Name

31 HMaybe Result = Maybe

25 HMaybe Result = Maybe

26+ HMaybe context = MaybeTable context

src/Rel8/Column/NonEmpty.hs+1−6

@@ -13,10 +13,7 @@ import Data.List.NonEmpty ( NonEmpty )

13import Prelude ()

15-- rel8

16−import Rel8.Aggregate ( Aggregate )

17−import Rel8.Expr ( Expr )

18import qualified Rel8.Schema.Kind as K

16import qualified Rel8.Schema.Kind as K

19−import Rel8.Schema.Name ( Name )

20import Rel8.Schema.Result ( Result )

17import Rel8.Schema.Result ( Result )

21import Rel8.Table.NonEmpty ( NonEmptyTable )

18import Rel8.Table.NonEmpty ( NonEmptyTable )

@@ -26,7 +23,5 @@ import Rel8.Table.NonEmpty ( NonEmptyTable )

26-- 'Result' context.

23-- 'Result' context.

27type HNonEmpty :: K.Context -> Type -> Type

24type HNonEmpty :: K.Context -> Type -> Type

28type family HNonEmpty context = nonEmpty | nonEmpty -> context where

25type family HNonEmpty context = nonEmpty | nonEmpty -> context where

29− HNonEmpty Aggregate = NonEmptyTable Aggregate

30− HNonEmpty Expr = NonEmptyTable Expr

31− HNonEmpty Name = NonEmptyTable Name

32 HNonEmpty Result = NonEmpty

26 HNonEmpty Result = NonEmpty

27+ HNonEmpty context = NonEmptyTable context

src/Rel8/Column/Null.hsnew file+26

@@ -0,0 +1,26 @@

1+{-# language DataKinds #-}

2+{-# language StandaloneKindSignatures #-}

3+{-# language TypeFamilyDependencies #-}

5+module Rel8.Column.Null

6+ ( HNull

7+ )

8+where

10+-- base

11+import Data.Kind ( Type )

12+import Prelude

13+

14+-- rel8

15+import qualified Rel8.Schema.Kind as K

16+import Rel8.Schema.Result ( Result )

17+import Rel8.Table.Null ( NullTable )

18+

19+

20+-- | Nest a 'Null' value within a 'Rel8able'. @HNull f a@ will produce a

21+-- 'NullTable' @a@ in the 'Expr' context, and a @'Maybe' a@ in the 'Result'

22+-- context.

23+type HNull :: K.Context -> Type -> Type

24+type family HNull context = maybe | maybe -> context where

25+ HNull Result = Maybe

26+ HNull context = NullTable context

src/Rel8/Column/These.hs+1−6

@@ -12,10 +12,7 @@ import Data.Kind ( Type )

12import Prelude ()

14-- rel8

15−import Rel8.Aggregate ( Aggregate )

16−import Rel8.Expr ( Expr )

17import qualified Rel8.Schema.Kind as K

15import qualified Rel8.Schema.Kind as K

18−import Rel8.Schema.Name ( Name )

19import Rel8.Schema.Result ( Result )

16import Rel8.Schema.Result ( Result )

20import Rel8.Table.These ( TheseTable )

17import Rel8.Table.These ( TheseTable )

@@ -28,7 +25,5 @@ import Data.These ( These )

28-- 'Result' context.

25-- 'Result' context.

29type HThese :: K.Context -> Type -> Type -> Type

26type HThese :: K.Context -> Type -> Type -> Type

30type family HThese context = these | these -> context where

27type family HThese context = these | these -> context where

31− HThese Aggregate = TheseTable Aggregate

32− HThese Expr = TheseTable Expr

33− HThese Name = TheseTable Name

34 HThese Result = These

28 HThese Result = These

29+ HThese context = TheseTable context

src/Rel8/Expr.hs+1

@@ -1,5 +1,6 @@

1{-# language DataKinds #-}

2{-# language DerivingStrategies #-}

3+{-# language FlexibleContexts #-}

3{-# language FlexibleInstances #-}

4{-# language FlexibleInstances #-}

4{-# language MultiParamTypeClasses #-}

5{-# language MultiParamTypeClasses #-}

5{-# language ScopedTypeVariables #-}

6{-# language ScopedTypeVariables #-}

src/Rel8/Expr/Aggregate.hs+25−64

@@ -10,6 +10,7 @@ module Rel8.Expr.Aggregate

10 , and, or

11 , min, max

12 , sum, sumWhere

13+ , avg

13 , stringAgg

14 , stringAgg

14 , groupByExpr

15 , groupByExpr

15 , listAggExpr, nonEmptyAggExpr

16 , listAggExpr, nonEmptyAggExpr

@@ -23,10 +24,12 @@ import Data.List.NonEmpty ( NonEmpty )

23import Prelude hiding ( and, max, min, null, or, sum )

24import Prelude hiding ( and, max, min, null, or, sum )

25-- opaleye

26-- opaleye

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

27+import qualified Opaleye.Internal.Aggregate as Opaleye

28+import Opaleye.Internal.Column ( Field_( Column ) )

29+import qualified Opaleye.Aggregate as Opaleye

28-- rel8

31-- rel8

29−import Rel8.Aggregate ( Aggregate, Aggregator(..), unsafeMakeAggregate )

32+import Rel8.Aggregate ( Aggregate, unsafeMakeAggregate )

30import Rel8.Expr ( Expr )

33import Rel8.Expr ( Expr )

31import Rel8.Expr.Bool ( caseExpr )

34import Rel8.Expr.Bool ( caseExpr )

32import Rel8.Expr.Opaleye

35import Rel8.Expr.Opaleye

@@ -50,23 +53,13 @@ import Rel8.Type.Sum ( DBSum )

51-- | Count the occurances of a single column. Corresponds to @COUNT(a)@

54-- | Count the occurances of a single column. Corresponds to @COUNT(a)@

52count :: Expr a -> Aggregate Int64

55count :: Expr a -> Aggregate Int64

53−count = unsafeMakeAggregate toPrimExpr fromPrimExpr $

56+count = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.count

54− Just Aggregator

55− { operation = Opaleye.AggrCount

56− , ordering = []

57− , distinction = Opaleye.AggrAll

58− }

59−

61-- | Count the number of distinct occurances of a single column. Corresponds to

58-- | Count the number of distinct occurances of a single column. Corresponds to

62-- @COUNT(DISTINCT a)@

59-- @COUNT(DISTINCT a)@

63countDistinct :: Sql DBEq a => Expr a -> Aggregate Int64

60countDistinct :: Sql DBEq a => Expr a -> Aggregate Int64

64countDistinct = unsafeMakeAggregate toPrimExpr fromPrimExpr $

61countDistinct = unsafeMakeAggregate toPrimExpr fromPrimExpr $

65− Just Aggregator

62+ Opaleye.distinctAggregator Opaleye.count

66− { operation = Opaleye.AggrCount

67− , ordering = []

68− , distinction = Opaleye.AggrDistinct

69− }

72-- | Corresponds to @COUNT(*)@.

65-- | Corresponds to @COUNT(*)@.

@@ -81,56 +74,39 @@ countWhere condition = count (caseExpr [(condition, litExpr (Just True))] null)

82-- | Corresponds to @bool_and@.

75-- | Corresponds to @bool_and@.

83and :: Expr Bool -> Aggregate Bool

76and :: Expr Bool -> Aggregate Bool

84−and = unsafeMakeAggregate toPrimExpr fromPrimExpr $

77+and = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.boolAnd

85− Just Aggregator

86− { operation = Opaleye.AggrBoolAnd

87− , ordering = []

88− , distinction = Opaleye.AggrAll

89− }

92-- | Corresponds to @bool_or@.

80-- | Corresponds to @bool_or@.

93or :: Expr Bool -> Aggregate Bool

81or :: Expr Bool -> Aggregate Bool

94−or = unsafeMakeAggregate toPrimExpr fromPrimExpr $

82+or = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.boolOr

95− Just Aggregator

96− { operation = Opaleye.AggrBoolOr

97− , ordering = []

98− , distinction = Opaleye.AggrAll

99− }

100

101

102-- | Produce an aggregation for @Expr a@ using the @max@ function.

85-- | Produce an aggregation for @Expr a@ using the @max@ function.

103max :: Sql DBMax a => Expr a -> Aggregate a

86max :: Sql DBMax a => Expr a -> Aggregate a

104−max = unsafeMakeAggregate toPrimExpr fromPrimExpr $

87+max = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.unsafeMax

105− Just Aggregator

106− { operation = Opaleye.AggrMax

107− , ordering = []

108− , distinction = Opaleye.AggrAll

109− }

110

111

112-- | Produce an aggregation for @Expr a@ using the @max@ function.

90-- | Produce an aggregation for @Expr a@ using the @max@ function.

113min :: Sql DBMin a => Expr a -> Aggregate a

91min :: Sql DBMin a => Expr a -> Aggregate a

114−min = unsafeMakeAggregate toPrimExpr fromPrimExpr $

92+min = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.unsafeMin

115− Just Aggregator

116− { operation = Opaleye.AggrMin

117− , ordering = []

118− , distinction = Opaleye.AggrAll

119− }

120

121-- | Corresponds to @sum@. Note that in SQL, @sum@ is type changing - for

94-- | Corresponds to @sum@. Note that in SQL, @sum@ is type changing - for

122-- example the @sum@ of @integer@ returns a @bigint@. Rel8 doesn't support

95-- example the @sum@ of @integer@ returns a @bigint@. Rel8 doesn't support

123−-- this, and will add explicit cast back to the original input type. This can

96+-- this, and will add explicit casts back to the original input type. This can

124-- lead to overflows, and if you anticipate very large sums, you should upcast

97-- lead to overflows, and if you anticipate very large sums, you should upcast

125-- your input.

98-- your input.

126sum :: Sql DBSum a => Expr a -> Aggregate a

99sum :: Sql DBSum a => Expr a -> Aggregate a

127−sum = unsafeMakeAggregate toPrimExpr (castExpr . fromPrimExpr) $

100+sum = unsafeMakeAggregate toPrimExpr (castExpr . fromPrimExpr) Opaleye.unsafeSum

128− Just Aggregator

101+

129− { operation = Opaleye.AggrSum

130− , ordering = []

131− , distinction = Opaleye.AggrAll

132− }

133

102

103+-- | Corresponds to @avg@. Note that in SQL, @avg@ is type changing - for

104+-- example, the @avg@ of @integer@ returns a @numeric@. Rel8 doesn't support

105+-- this, and will add explicit casts back to the original input type. If you

106+-- need a fractional result on an integral column, you should cast your input

107+-- to 'Double' or 'Data.Scientific.Scientific' before calling 'avg'.

108+avg :: Sql DBSum a => Expr a -> Aggregate a

109+avg = unsafeMakeAggregate toPrimExpr (castExpr . fromPrimExpr) Opaleye.unsafeAvg

134

110

135-- | Take the sum of all expressions that satisfy a predicate.

111-- | Take the sum of all expressions that satisfy a predicate.

136sumWhere :: (Sql DBNum a, Sql DBSum a)

112sumWhere :: (Sql DBNum a, Sql DBSum a)

@@ -142,17 +118,12 @@ sumWhere condition a = sum (caseExpr [(condition, a)] 0)

142stringAgg :: Sql DBString a

118stringAgg :: Sql DBString a

143 => Expr db -> Expr a -> Aggregate a

119 => Expr db -> Expr a -> Aggregate a

144stringAgg delimiter =

120stringAgg delimiter =

145− unsafeMakeAggregate toPrimExpr (castExpr . fromPrimExpr) $

121+ unsafeMakeAggregate toPrimExpr (castExpr . fromPrimExpr) (Opaleye.stringAgg (Column (toPrimExpr delimiter)))

146− Just Aggregator

147− { operation = Opaleye.AggrStringAggr (toPrimExpr delimiter)

148− , ordering = []

149− , distinction = Opaleye.AggrAll

150− }

151

122

152

123

153-- | Aggregate a value by grouping by it.

124-- | Aggregate a value by grouping by it.

154groupByExpr :: Sql DBEq a => Expr a -> Aggregate a

125groupByExpr :: Sql DBEq a => Expr a -> Aggregate a

155−groupByExpr = unsafeMakeAggregate toPrimExpr fromPrimExpr Nothing

126+groupByExpr = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.groupBy

156

127

157

128

158-- | Collect expressions values as a list.

129-- | Collect expressions values as a list.

@@ -167,23 +138,13 @@ nonEmptyAggExpr = snonEmptyAggExpr typeInformation

167

138

168slistAggExpr :: ()

139slistAggExpr :: ()

169 => TypeInformation (Unnullify a) -> Expr a -> Aggregate [a]

140 => TypeInformation (Unnullify a) -> Expr a -> Aggregate [a]

170−slistAggExpr info = unsafeMakeAggregate to fromPrimExpr $ Just

141+slistAggExpr info = unsafeMakeAggregate to fromPrimExpr Opaleye.arrayAgg

171− Aggregator

172− { operation = Opaleye.AggrArr

173− , ordering = []

174− , distinction = Opaleye.AggrAll

175− }

176 where

142 where

177 to = encodeArrayElement info . toPrimExpr

143 to = encodeArrayElement info . toPrimExpr

178

144

179

145

180snonEmptyAggExpr :: ()

146snonEmptyAggExpr :: ()

181 => TypeInformation (Unnullify a) -> Expr a -> Aggregate (NonEmpty a)

147 => TypeInformation (Unnullify a) -> Expr a -> Aggregate (NonEmpty a)

182−snonEmptyAggExpr info = unsafeMakeAggregate to fromPrimExpr $ Just

148+snonEmptyAggExpr info = unsafeMakeAggregate to fromPrimExpr Opaleye.arrayAgg

183− Aggregator

184− { operation = Opaleye.AggrArr

185− , ordering = []

186− , distinction = Opaleye.AggrAll

187− }

188 where

149 where

189 to = encodeArrayElement info . toPrimExpr

150 to = encodeArrayElement info . toPrimExpr

src/Rel8/Expr/Num.hs+39−6

@@ -4,18 +4,24 @@

4{-# options_ghc -fno-warn-redundant-constraints #-}

6module Rel8.Expr.Num

7+ ( fromIntegral

8+ , realToFrac

9+ , div, mod, divMod

10+ , quot, rem, quotRem

7− ( fromIntegral, realToFrac, div, mod, ceiling, floor, round, truncate

11+ , ceiling, floor, round, truncate

8 )

12 )

9where

13where

11-- base

15-- base

12−import Prelude ()

16+import Prelude ( (+), (-), fst, negate, signum, snd )

14-- rel

18-- rel

15import Rel8.Expr ( Expr( Expr ) )

19import Rel8.Expr ( Expr( Expr ) )

20+import Rel8.Expr.Eq ( (==.) )

16import Rel8.Expr.Function ( function )

21import Rel8.Expr.Function ( function )

17import Rel8.Expr.Opaleye ( castExpr )

22import Rel8.Expr.Opaleye ( castExpr )

18import Rel8.Schema.Null ( Homonullable, Sql )

23import Rel8.Schema.Null ( Homonullable, Sql )

24+import Rel8.Table.Bool ( bool )

19import Rel8.Type.Num ( DBFractional, DBIntegral, DBNum )

25import Rel8.Type.Num ( DBFractional, DBIntegral, DBNum )

@@ -42,14 +48,41 @@ ceiling :: (Sql DBFractional a, Sql DBIntegral b, Homonullable a b)

42ceiling = function "ceiling"

48ceiling = function "ceiling"

45−-- | Perform integral division. Corresponds to the @div()@ function.

51+-- | Emulates the behaviour of the Haskell function 'Prelude.div' in

52+-- PostgreSQL.

46div :: Sql DBIntegral a => Expr a -> Expr a -> Expr a

53div :: Sql DBIntegral a => Expr a -> Expr a -> Expr a

47−div = function "div"

54+div n d = fst (divMod n d)

50−-- | Corresponds to the @mod()@ function.

57+-- | Emulates the behaviour of the Haskell function 'Prelude.mod' in

58+-- PostgreSQL.

51mod :: Sql DBIntegral a => Expr a -> Expr a -> Expr a

59mod :: Sql DBIntegral a => Expr a -> Expr a -> Expr a

52−mod = function "mod"

60+mod n d = snd (divMod n d)

61+

62+

63+-- | Simultaneous 'div' and 'mod'.

64+divMod :: Sql DBIntegral a => Expr a -> Expr a -> (Expr a, Expr a)

65+divMod n d = bool qr (q - 1, r + d) (signum r ==. negate (signum d))

66+ where

67+ qr@(q, r) = quotRem n d

68+

69+

70+-- | Perform integral division. Corresponds to the @div()@ function in

71+-- PostgreSQL, which behaves like Haskell's 'Prelude.quot' rather than

72+-- 'Prelude.div'.

73+quot :: Sql DBIntegral a => Expr a -> Expr a -> Expr a

74+quot = function "div"

75+

76+

77+-- | Corresponds to the @mod()@ function in PostgreSQL, which behaves like

78+-- Haskell's 'Prelude.rem' rather than 'Prelude.mod'.

79+rem :: Sql DBIntegral a => Expr a -> Expr a -> Expr a

80+rem = function "mod"

81+

82+

83+-- | Simultaneous 'quot' and 'rem'.

84+quotRem :: Sql DBIntegral a => Expr a -> Expr a -> (Expr a, Expr a)

85+quotRem n d = (quot n d, rem n d)

55-- | Round a 'DFractional' to a 'DBIntegral' by rounding to the nearest smaller

88-- | Round a 'DFractional' to a 'DBIntegral' by rounding to the nearest smaller

src/Rel8/Expr/Opaleye.hs+12−3

@@ -10,7 +10,7 @@ module Rel8.Expr.Opaleye

10 , scastExpr, sunsafeCastExpr

11 , unsafeLiteral

12 , fromPrimExpr, toPrimExpr, mapPrimExpr, zipPrimExprsWith, traversePrimExpr

13− , toColumn, fromColumn

13+ , toColumn, fromColumn, traverseFieldP

14 )

15where

@@ -27,6 +27,9 @@ import Rel8.Schema.Null ( Unnullify, Sql )

27import Rel8.Type ( DBType, typeInformation )

28import Rel8.Type.Information ( TypeInformation(..) )

30+-- profunctors

31+import Data.Profunctor ( Profunctor, dimap )

32+

31castExpr :: Sql DBType a => Expr a -> Expr a

34castExpr :: Sql DBType a => Expr a -> Expr a

32castExpr = scastExpr typeInformation

35castExpr = scastExpr typeInformation

@@ -80,9 +83,15 @@ traversePrimExpr :: Functor f

80traversePrimExpr f = fmap fromPrimExpr . f . toPrimExpr

83traversePrimExpr f = fmap fromPrimExpr . f . toPrimExpr

86+traverseFieldP :: Profunctor p

87+ => p (Opaleye.Field_ n x) (Opaleye.Field_ m y)

88+ -> p (Expr a) (Expr b)

89+traverseFieldP = dimap (toColumn . toPrimExpr) (fromPrimExpr . fromColumn)

90+

91+

83−toColumn :: Opaleye.PrimExpr -> Opaleye.Column b

92+toColumn :: Opaleye.PrimExpr -> Opaleye.Field_ n b

84toColumn = Opaleye.Column

93toColumn = Opaleye.Column

87−fromColumn :: Opaleye.Column b -> Opaleye.PrimExpr

96+fromColumn :: Opaleye.Field_ n b -> Opaleye.PrimExpr

88fromColumn (Opaleye.Column a) = a

97fromColumn (Opaleye.Column a) = a

src/Rel8/Expr/Sequence.hs+2−1

@@ -11,6 +11,7 @@ import Prelude

11import Rel8.Expr ( Expr )

12import Rel8.Expr.Function ( function )

13import Rel8.Expr.Serialize ( litExpr )

14+import Rel8.Expr.Text ( quoteIdent )

15-- text

16-- text

16import Data.Text ( pack )

17import Data.Text ( pack )

@@ -18,4 +19,4 @@ import Data.Text ( pack )

19-- | See https://www.postgresql.org/docs/current/functions-sequence.html

20-- | See https://www.postgresql.org/docs/current/functions-sequence.html

20nextval :: String -> Expr Int64

21nextval :: String -> Expr Int64

21−nextval = function "nextval" . litExpr . pack

22+nextval = function "nextval" . quoteIdent . litExpr . pack

src/Rel8/Expr/Text.hs+23−2

@@ -17,6 +17,9 @@ module Rel8.Expr.Text

17 , pgClientEncoding, quoteIdent, quoteLiteral, quoteNullable, regexpReplace

18 , regexpSplitToArray, repeat, replace, reverse, right, rpad, rtrim

19 , splitPart, strpos, substr, translate

20+

21+ -- * @LIKE@ and @ILIKE@

22+ , like, ilike

20 )

23 )

21where

24where

@@ -24,7 +27,7 @@ where

24import Data.Bool ( Bool )

27import Data.Bool ( Bool )

25import Data.Int ( Int32 )

28import Data.Int ( Int32 )

26import Data.Maybe ( Maybe( Nothing, Just ) )

29import Data.Maybe ( Maybe( Nothing, Just ) )

27−import Prelude ()

30+import Prelude ( flip )

29-- bytestring

32-- bytestring

30import Data.ByteString ( ByteString )

33import Data.ByteString ( ByteString )

@@ -49,7 +52,7 @@ infixr 6 ++.

51-- | Matches regular expression, case sensitive

54-- | Matches regular expression, case sensitive

52−--

55+--

53-- Corresponds to the @~.@ operator.

56-- Corresponds to the @~.@ operator.

54(~.) :: Expr Text -> Expr Text -> Expr Bool

57(~.) :: Expr Text -> Expr Text -> Expr Bool

55(~.) = binaryOperator "~."

58(~.) = binaryOperator "~."

@@ -273,3 +276,21 @@ substr a b Nothing = function "substr" a b

273-- | Corresponds to the @translate@ function.

276-- | Corresponds to the @translate@ function.

274translate :: Expr Text -> Expr Text -> Expr Text -> Expr Text

277translate :: Expr Text -> Expr Text -> Expr Text -> Expr Text

275translate = function "translate"

278translate = function "translate"

279+

280+

281+-- | @like x y@ corresponds to the expression @y LIKE x@.

282+--

283+-- Note that the arguments to @like@ are swapped. This is to aid currying, so

284+-- you can write expressions like

285+-- @filter (like "Rel%" . packageName) =<< each haskellPackages@

286+like :: Expr Text -> Expr Text -> Expr Bool

287+like = flip (binaryOperator "LIKE")

288+

289+

290+-- | @ilike x y@ corresponds to the expression @y ILIKE x@.

291+--

292+-- Note that the arguments to @ilike@ are swapped. This is to aid currying, so

293+-- you can write expressions like

294+-- @filter (ilike "Rel%" . packageName) =<< each haskellPackages@

295+ilike :: Expr Text -> Expr Text -> Expr Bool

296+ilike = flip (binaryOperator "ILIKE")

src/Rel8/Expr/Window.hsnew file+121

@@ -0,0 +1,121 @@

1+module Rel8.Expr.Window

2+ ( cumulative

3+ , rowNumber

4+ , rank

5+ , denseRank

6+ , percentRank

7+ , cumeDist

8+ , ntile

9+ , lag

10+ , lead

11+ , firstValue

12+ , lastValue

13+ , nthValue

14+ )

15+where

16+

17+-- base

18+import Data.Int ( Int32, Int64 )

19+import Prelude

20+

21+-- opaleye

22+import qualified Opaleye.Internal.Aggregate as Opaleye

23+import qualified Opaleye.Internal.PackMap as Opaleye

24+import qualified Opaleye.Internal.Window as Opaleye

25+import qualified Opaleye.Window as Opaleye

26+

27+-- profunctors

28+import Data.Profunctor (dimap)

29+

30+-- rel8

31+import Rel8.Aggregate ( Aggregate( Aggregate ) )

32+import Rel8.Expr ( Expr )

33+import Rel8.Expr.Opaleye ( fromColumn, fromPrimExpr, toColumn, toPrimExpr )

34+import Rel8.Schema.Null ( Nullify )

35+import Rel8.Window ( Window( Window ) )

36+

37+

38+cumulative :: (a -> Aggregate b) -> Window a (Expr b)

39+cumulative f =

40+ fromWindowFunction $ Opaleye.aggregatorWindowFunction (fromAggregate f) id

41+

42+

43+-- | [@row_number()@](https://www.postgresql.org/docs/current/functions-window.html)

44+rowNumber :: Window a (Expr Int64)

45+rowNumber = fromWindowFunction $ fromPrimExpr . fromColumn <$> Opaleye.rowNumber

46+

47+

48+-- | [@rank()@](https://www.postgresql.org/docs/current/functions-window.html)

49+rank :: Window a (Expr Int64)

50+rank = fromWindowFunction $ fromPrimExpr . fromColumn <$> Opaleye.rank

51+

52+

53+-- | [@dense_rank()@](https://www.postgresql.org/docs/current/functions-window.html)

54+denseRank :: Window a (Expr Int64)

55+denseRank = fromWindowFunction $ fromPrimExpr . fromColumn <$> Opaleye.denseRank

56+

57+

58+-- | [@percent_rank()@](https://www.postgresql.org/docs/current/functions-window.html)

59+percentRank :: Window a (Expr Double)

60+percentRank = fromWindowFunction $ fromPrimExpr . fromColumn <$> Opaleye.percentRank

61+

62+

63+-- | [@cume_dist()@](https://www.postgresql.org/docs/current/functions-window.html)

64+cumeDist :: Window a (Expr Double)

65+cumeDist = fromWindowFunction $ fromPrimExpr . fromColumn <$> Opaleye.cumeDist

66+

67+

68+-- | [@ntile(num_buckets)@](https://www.postgresql.org/docs/current/functions-window.html)

69+ntile :: Expr Int32 -> Window a (Expr Int32)

70+ntile buckets = fromWindowFunction $ fromPrimExpr . fromColumn <$>

71+ Opaleye.ntile (toColumn (toPrimExpr buckets))

72+

73+

74+-- | [@lag(value, offset, default)@](https://www.postgresql.org/docs/current/functions-window.html)

75+lag :: Expr Int32 -> Expr a -> Window (Expr a) (Expr a)

76+lag offset def =

77+ fromWindowFunction $

78+ dimap (toColumn . toPrimExpr) (fromPrimExpr . fromColumn) $

79+ Opaleye.lag (toColumn (toPrimExpr offset)) (toColumn (toPrimExpr def))

80+

81+

82+-- | [@lead(value, offset, default)@](https://www.postgresql.org/docs/current/functions-window.html)

83+lead :: Expr Int32 -> Expr a -> Window (Expr a) (Expr a)

84+lead offset def =

85+ fromWindowFunction $

86+ dimap (toColumn . toPrimExpr) (fromPrimExpr . fromColumn) $

87+ Opaleye.lead (toColumn (toPrimExpr offset)) (toColumn (toPrimExpr def))

88+

89+

90+-- | [@first_value(value)@](https://www.postgresql.org/docs/current/functions-window.html)

91+firstValue :: Window (Expr a) (Expr a)

92+firstValue =

93+ fromWindowFunction $

94+ dimap (toColumn . toPrimExpr) (fromPrimExpr . fromColumn)

95+ Opaleye.firstValue

96+

97+

98+-- | [@last_value(value)@](https://www.postgresql.org/docs/current/functions-window.html)

99+lastValue :: Window (Expr a) (Expr a)

100+lastValue =

101+ fromWindowFunction $

102+ dimap (toColumn . toPrimExpr) (fromPrimExpr . fromColumn)

103+ Opaleye.lastValue

104+

105+

106+-- | [@nth_value(value, n)@](https://www.postgresql.org/docs/current/functions-window.html)

107+nthValue :: Expr Int32 -> Window (Expr a) (Expr (Nullify a))

108+nthValue n =

109+ fromWindowFunction $

110+ dimap (toColumn . toPrimExpr) (fromPrimExpr . fromColumn) $

111+ Opaleye.nthValue (toColumn (toPrimExpr n))

112+

113+

114+fromAggregate :: (a -> Aggregate b) -> Opaleye.Aggregator a (Expr b)

115+fromAggregate f = Opaleye.Aggregator $ Opaleye.PackMap $ \w a -> case f a of

116+ Aggregate (Opaleye.Aggregator (Opaleye.PackMap x)) -> x w ()

117+

118+

119+fromWindowFunction :: Opaleye.WindowFunction a b -> Window a b

120+fromWindowFunction (Opaleye.WindowFunction (Opaleye.PackMap w)) =

121+ Window $ Opaleye.Windows $ Opaleye.PackMap $ \f -> w $ \o -> f (o, mempty)

src/Rel8/Generic/Construction/ADT.hs+1

@@ -1,6 +1,7 @@

1{-# language AllowAmbiguousTypes #-}

2{-# language BlockArguments #-}

3{-# language DataKinds #-}

4+{-# language FlexibleContexts #-}

4{-# language FlexibleInstances #-}

5{-# language FlexibleInstances #-}

5{-# language MultiParamTypeClasses #-}

6{-# language MultiParamTypeClasses #-}

6{-# language RankNTypes #-}

7{-# language RankNTypes #-}

src/Rel8/Generic/Record.hs+2

@@ -1,5 +1,6 @@

1{-# language AllowAmbiguousTypes #-}

2{-# language DataKinds #-}

3+{-# language FlexibleContexts #-}

3{-# language FlexibleInstances #-}

4{-# language FlexibleInstances #-}

4{-# language MultiParamTypeClasses #-}

5{-# language MultiParamTypeClasses #-}

5{-# language PolyKinds #-}

6{-# language PolyKinds #-}

@@ -141,6 +142,7 @@ instance {-# OVERLAPPABLE #-} Snd (Count n rep) ~ rep => Countable n rep where

141 uncount = id

142 uncount = id

142

143

144

145+type Record :: Type -> Type

144newtype Record a = Record

146newtype Record a = Record

145 { unrecord :: a

147 { unrecord :: a

146 }

148 }

src/Rel8/Generic/Rel8able.hs+37−3

@@ -6,6 +6,8 @@

6{-# language FlexibleInstances #-}

7{-# language LambdaCase #-}

8{-# language MultiParamTypeClasses #-}

9+{-# language PolyKinds #-}

10+{-# language QuantifiedConstraints #-}

9{-# language ScopedTypeVariables #-}

11{-# language ScopedTypeVariables #-}

10{-# language StandaloneKindSignatures #-}

12{-# language StandaloneKindSignatures #-}

11{-# language TypeApplications #-}

13{-# language TypeApplications #-}

@@ -24,8 +26,9 @@ module Rel8.Generic.Rel8able

24where

26where

26-- base

28-- base

29+import Data.Functor.Identity ( Identity )

27import Data.Kind ( Constraint, Type )

30import Data.Kind ( Constraint, Type )

28−import Data.Type.Equality ( type (==) )

31+import Data.Type.Bool ( type (&&) )

29import GHC.Generics ( Generic, Rep, from, to )

32import GHC.Generics ( Generic, Rep, from, to )

30import Prelude

33import Prelude

@@ -38,6 +41,7 @@ import Rel8.Generic.Table ( GAlgebra )

38import qualified Rel8.Generic.Table.Record as G

41import qualified Rel8.Generic.Table.Record as G

39import qualified Rel8.Kind.Algebra as K ( Algebra(..) )

42import qualified Rel8.Kind.Algebra as K ( Algebra(..) )

40import Rel8.Kind.Context ( SContext(..) )

43import Rel8.Kind.Context ( SContext(..) )

44+import Rel8.Schema.Field ( Field )

41import Rel8.Schema.HTable ( HTable )

45import Rel8.Schema.HTable ( HTable )

42import qualified Rel8.Schema.Kind as K

46import qualified Rel8.Schema.Kind as K

43import Rel8.Schema.Name ( Name )

47import Rel8.Schema.Name ( Name )

@@ -56,6 +60,25 @@ type KRel8able :: Type

56type KRel8able = K.Rel8able

60type KRel8able = K.Rel8able

63+-- This is almost 'Data.Type.Equality.==', but we add an extra case.

64+type (==) :: k -> k -> Bool

65+type family a == b where

66+ -- This extra case is needed to solve the equation "a == a" (where a is a

67+ -- KRel8able), which occurs when we have polymorphic Rel8ables

68+ -- (e.g., newtype T t f = T { x :: t a })

69+ (a :: KRel8able) == (a :: KRel8able) = 'True

70+

71+ -- This extra case is needed to solve the equation "a == Identity a",

72+ -- which occurs when we have polymorphic Rel8ables

73+ -- (e.g., newtype T a f = T { x :: Column f a })

74+ a == Identity a = 'False

75+

76+ -- These cases are exactly the same as those in 'Data.Type.Equality.==.

77+ f a == g b = f == g && a == b

78+ a == a = 'True

79+ _ == _ = 'False

80+

81+

59type Serialize :: Bool -> Type -> Type -> Constraint

82type Serialize :: Bool -> Type -> Type -> Constraint

60class transposition ~ (a == Transpose Result expr) =>

83class transposition ~ (a == Transpose Result expr) =>

61 Serialize transposition expr a

84 Serialize transposition expr a

@@ -123,7 +146,7 @@ type instance Eval (TSerialize expr a) =

123-- [Supplying @Rel8able@ instances]

146-- [Supplying @Rel8able@ instances]

124--

147--

125-- This type class should be derived generically for all table types in your

148-- This type class should be derived generically for all table types in your

126−-- project. To do this, enable the @DeriveAnyType@ and @DeriveGeneric@ language

149+-- project. To do this, enable the @DeriveAnyClass@ and @DeriveGeneric@ language

127-- extensions:

150-- extensions:

128--

151--

129-- @

152-- @

@@ -149,6 +172,7 @@ class HTable (GColumns t) => Rel8able t where

149 default gfromColumns :: forall context.

172 default gfromColumns :: forall context.

150 ( SRel8able t Aggregate

173 ( SRel8able t Aggregate

151 , SRel8able t Expr

174 , SRel8able t Expr

175+ , forall table. SRel8able t (Field table)

152 , SRel8able t Name

176 , SRel8able t Name

153 , SSerialize t

177 , SSerialize t

154 )

178 )

@@ -156,12 +180,14 @@ class HTable (GColumns t) => Rel8able t where

156 gfromColumns = \case

180 gfromColumns = \case

157 SAggregate -> sfromColumns

181 SAggregate -> sfromColumns

158 SExpr -> sfromColumns

182 SExpr -> sfromColumns

183+ SField -> sfromColumns

159 SName -> sfromColumns

184 SName -> sfromColumns

160 SResult -> sfromResult

185 SResult -> sfromResult

161

186

162 default gtoColumns :: forall context.

187 default gtoColumns :: forall context.

163 ( SRel8able t Aggregate

188 ( SRel8able t Aggregate

164 , SRel8able t Expr

189 , SRel8able t Expr

190+ , forall table. SRel8able t (Field table)

165 , SRel8able t Name

191 , SRel8able t Name

166 , SSerialize t

192 , SSerialize t

167 )

193 )

@@ -169,6 +195,7 @@ class HTable (GColumns t) => Rel8able t where

169 gtoColumns = \case

195 gtoColumns = \case

170 SAggregate -> stoColumns

196 SAggregate -> stoColumns

171 SExpr -> stoColumns

197 SExpr -> stoColumns

198+ SField -> stoColumns

172 SName -> stoColumns

199 SName -> stoColumns

173 SResult -> stoResult

200 SResult -> stoResult

174

201

@@ -190,11 +217,18 @@ type GRep t context = Rep (Record (t context))

190

217

191

218

192type SRel8able :: K.Rel8able -> K.Context -> Constraint

219type SRel8able :: K.Rel8able -> K.Context -> Constraint

220+class

221+ ( Generic (Record (t context))

222+ , G.GTable (TTable context) TColumns (GRep t context)

223+ , G.GColumns TColumns (GRep t context) ~ GColumns t

224+ )

193−type SRel8able t context =

225+ => SRel8able t context

226+instance

194 ( Generic (Record (t context))

227 ( Generic (Record (t context))

195 , G.GTable (TTable context) TColumns (GRep t context)

228 , G.GTable (TTable context) TColumns (GRep t context)

196 , G.GColumns TColumns (GRep t context) ~ GColumns t

229 , G.GColumns TColumns (GRep t context) ~ GColumns t

197 )

230 )

231+ => SRel8able t context

198

232

199

233

200type SSerialize :: K.Rel8able -> Constraint

234type SSerialize :: K.Rel8able -> Constraint

src/Rel8/Generic/Table/ADT.hs+1

@@ -1,5 +1,6 @@

1{-# language AllowAmbiguousTypes #-}

2{-# language DataKinds #-}

3+{-# language FlexibleContexts #-}

3{-# language FlexibleInstances #-}

4{-# language FlexibleInstances #-}

4{-# language LambdaCase #-}

5{-# language LambdaCase #-}

5{-# language MultiParamTypeClasses #-}

6{-# language MultiParamTypeClasses #-}

src/Rel8/Kind/Context.hs+6

@@ -16,6 +16,7 @@ import Prelude ()

16-- rel8

17import Rel8.Aggregate ( Aggregate )

18import Rel8.Expr ( Expr )

19+import Rel8.Schema.Field ( Field )

19import Rel8.Schema.Kind ( Context )

20import Rel8.Schema.Kind ( Context )

20import Rel8.Schema.Name ( Name )

21import Rel8.Schema.Name ( Name )

21import Rel8.Schema.Result ( Result )

22import Rel8.Schema.Result ( Result )

@@ -25,6 +26,7 @@ type SContext :: Context -> Type

25data SContext context where

26data SContext context where

26 SAggregate :: SContext Aggregate

27 SAggregate :: SContext Aggregate

27 SExpr :: SContext Expr

28 SExpr :: SContext Expr

29+ SField :: SContext (Field table)

28 SName :: SContext Name

30 SName :: SContext Name

29 SResult :: SContext Result

31 SResult :: SContext Result

@@ -42,6 +44,10 @@ instance Reifiable Expr where

42 contextSing = SExpr

44 contextSing = SExpr

47+instance Reifiable (Field table) where

48+ contextSing = SField

49+

50+

45instance Reifiable Result where

51instance Reifiable Result where

46 contextSing = SResult

52 contextSing = SResult

src/Rel8/Order.hs+1−8

@@ -4,7 +4,6 @@

5module Rel8.Order

6 ( Order(..)

7− , toOrderExprs

8 )

7 )

9where

8where

@@ -17,8 +16,7 @@ import Prelude

17import Data.Functor.Contravariant.Divisible ( Decidable, Divisible )

16import Data.Functor.Contravariant.Divisible ( Decidable, Divisible )

19-- opaleye

18-- opaleye

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

19+import qualified Opaleye.Order as Opaleye

21−import qualified Opaleye.Internal.Order as Opaleye

24-- | An ordering expression for @a@. Primitive orderings are defined with

22-- | An ordering expression for @a@. Primitive orderings are defined with

@@ -30,8 +28,3 @@ import qualified Opaleye.Internal.Order as Opaleye

30type Order :: Type -> Type

28type Order :: Type -> Type

31newtype Order a = Order (Opaleye.Order a)

29newtype Order a = Order (Opaleye.Order a)

32 deriving newtype (Contravariant, Divisible, Decidable, Semigroup, Monoid)

30 deriving newtype (Contravariant, Divisible, Decidable, Semigroup, Monoid)

33−

34−

35−toOrderExprs :: Order a -> a -> [Opaleye.OrderExpr]

36−toOrderExprs (Order (Opaleye.Order order)) a =

37− uncurry Opaleye.OrderExpr <$> order a

src/Rel8/Query.hs+28−9

@@ -1,4 +1,6 @@

1+{-# language FlexibleContexts #-}

1{-# language StandaloneKindSignatures #-}

2{-# language StandaloneKindSignatures #-}

3+{-# language UndecidableInstances #-}

3module Rel8.Query

5module Rel8.Query

4 ( Query( Query )

6 ( Query( Query )

@@ -15,18 +17,21 @@ import Prelude

15-- opaleye

17-- opaleye

16import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye

18import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye

17import qualified Opaleye.Internal.PackMap as Opaleye

19import qualified Opaleye.Internal.PackMap as Opaleye

18−import qualified Opaleye.Internal.PrimQuery as Opaleye

20+import qualified Opaleye.Internal.PrimQuery as Opaleye hiding (lateral)

19import qualified Opaleye.Internal.QueryArr as Opaleye

21import qualified Opaleye.Internal.QueryArr as Opaleye

20import qualified Opaleye.Internal.Tag as Opaleye

22import qualified Opaleye.Internal.Tag as Opaleye

22-- rel8

24-- rel8

25+import Rel8.Expr ( Expr )

23import Rel8.Query.Set ( unionAll )

26import Rel8.Query.Set ( unionAll )

24import Rel8.Query.Opaleye ( fromOpaleye )

27import Rel8.Query.Opaleye ( fromOpaleye )

25import Rel8.Query.Values ( values )

28import Rel8.Query.Values ( values )

29+import Rel8.Table ( Table, fromColumns, toColumns )

26import Rel8.Table.Alternative

30import Rel8.Table.Alternative

27 ( AltTable, (<|>:)

31 ( AltTable, (<|>:)

28 , AlternativeTable, emptyTable

32 , AlternativeTable, emptyTable

29 )

33 )

34+import Rel8.Table.Projection ( Projectable, apply, project )

31-- semigroupoids

36-- semigroupoids

32import Data.Functor.Apply ( Apply, (<.>) )

37import Data.Functor.Apply ( Apply, (<.>) )

@@ -151,6 +156,10 @@ newtype Query a =

151 )

156 )

152

157

153

158

159+instance Projectable Query where

160+ project f = fmap (fromColumns . apply f . toColumns)

161+

162+

154instance Functor Query where

163instance Functor Query where

155 fmap f (Query a) = Query (fmap (fmap (fmap f)) a)

164 fmap f (Query a) = Query (fmap (fmap (fmap f)) a)

156

165

@@ -169,14 +178,14 @@ instance Bind Query where

169

178

170

179

171instance Monad Query where

180instance Monad Query where

172− Query q >>= f = Query $ \dummies -> Opaleye.QueryArr $ \(_, tag) ->

181+ Query q >>= f = Query $ \dummies -> Opaleye.stateQueryArr $ \_ tag ->

173 let

182 let

174− Opaleye.QueryArr qa = q dummies

183+ qa = q dummies

175− ((m, a), query, tag') = qa ((), tag)

184+ ((m, a), query, tag') = Opaleye.runStateQueryArr qa () tag

176 Query q' = f a

185 Query q' = f a

177 (dummies', query', tag'') =

186 (dummies', query', tag'') =

178 ( dummy : dummies

187 ( dummy : dummies

179− , \lateral -> Opaleye.Rebind True bindings . query lateral

188+ , query <> Opaleye.aRebind bindings

180 , Opaleye.next tag'

189 , Opaleye.next tag'

181 )

190 )

182 where

191 where

@@ -184,11 +193,11 @@ instance Monad Query where

184 where

193 where

185 random = Opaleye.FunExpr "random" []

194 random = Opaleye.FunExpr "random" []

186 name = Opaleye.extractAttr "dummy" tag'

195 name = Opaleye.extractAttr "dummy" tag'

187− Opaleye.QueryArr qa' = Opaleye.lateral $ \_ -> q' dummies'

196+ qa' = Opaleye.lateral $ \_ -> q' dummies'

188− ((m'@(Any needsDummies), b), query'', tag''') = qa' ((), tag'')

197+ ((m'@(Any needsDummies), b), query'', tag''') = Opaleye.runStateQueryArr qa' () tag''

189 query'''

198 query'''

190− | needsDummies = \lateral -> query'' lateral . query' lateral

199+ | needsDummies = query' <> query''

191− | otherwise = \lateral -> query'' lateral . query lateral

200+ | otherwise = query <> query''

192 m'' = m <> m'

201 m'' = m <> m'

193 in

202 in

194 ((m'', b), query''', tag''')

203 ((m'', b), query''', tag''')

@@ -202,3 +211,13 @@ instance AltTable Query where

202-- | 'emptyTable' = 'values' @[]@.

211-- | 'emptyTable' = 'values' @[]@.

203instance AlternativeTable Query where

212instance AlternativeTable Query where

204 emptyTable = values []

213 emptyTable = values []

214+

215+

216+-- | '<>' = 'unionAll'.

217+instance Table Expr a => Semigroup (Query a) where

218+ (<>) = (<|>:)

219+

220+

221+-- | 'mempty' = @'values' []@.

222+instance Table Expr a => Monoid (Query a) where

223+ mempty = emptyTable

src/Rel8/Query/Aggregate.hs+19

@@ -1,13 +1,17 @@

1{-# language FlexibleContexts #-}

2{-# language MonoLocalBinds #-}

3+{-# language ScopedTypeVariables #-}

4+{-# language TypeApplications #-}

4module Rel8.Query.Aggregate

6module Rel8.Query.Aggregate

5 ( aggregate

7 ( aggregate

6 , countRows

8 , countRows

9+ , mode

7 )

10 )

8where

11where

10-- base

13-- base

14+import Data.Functor.Contravariant ( (>$<) )

11import Data.Int ( Int64 )

15import Data.Int ( Int64 )

12import Prelude

16import Prelude

@@ -18,9 +22,16 @@ import qualified Opaleye.Aggregate as Opaleye

18import Rel8.Aggregate ( Aggregates )

22import Rel8.Aggregate ( Aggregates )

19import Rel8.Expr ( Expr )

23import Rel8.Expr ( Expr )

20import Rel8.Expr.Aggregate ( countStar )

24import Rel8.Expr.Aggregate ( countStar )

25+import Rel8.Expr.Order ( desc )

21import Rel8.Query ( Query )

26import Rel8.Query ( Query )

27+import Rel8.Query.Limit ( limit )

22import Rel8.Query.Maybe ( optional )

28import Rel8.Query.Maybe ( optional )

23import Rel8.Query.Opaleye ( mapOpaleye )

29import Rel8.Query.Opaleye ( mapOpaleye )

30+import Rel8.Query.Order ( orderBy )

31+import Rel8.Table ( toColumns )

32+import Rel8.Table.Aggregate ( hgroupBy )

33+import Rel8.Table.Cols ( Cols( Cols ), fromCols )

34+import Rel8.Table.Eq ( EqTable, eqTable )

24import Rel8.Table.Opaleye ( aggregator )

35import Rel8.Table.Opaleye ( aggregator )

25import Rel8.Table.Maybe ( maybeTable )

36import Rel8.Table.Maybe ( maybeTable )

@@ -35,3 +46,11 @@ aggregate = mapOpaleye (Opaleye.aggregate aggregator)

35-- will return @0@.

46-- will return @0@.

36countRows :: Query a -> Query (Expr Int64)

47countRows :: Query a -> Query (Expr Int64)

37countRows = fmap (maybeTable 0 id) . optional . aggregate . fmap (const countStar)

48countRows = fmap (maybeTable 0 id) . optional . aggregate . fmap (const countStar)

49+

50+

51+-- | Return the most common row in a query.

52+mode :: forall a. EqTable a => Query a -> Query a

53+mode rows = limit 1 $ fmap (fromCols . snd) $ orderBy (fst >$< desc) $ do

54+ aggregate $ do

55+ row <- toColumns <$> rows

56+ pure (countStar, Cols $ hgroupBy (eqTable @a) row)

src/Rel8/Query/Distinct.hs+4−9

@@ -1,5 +1,3 @@

1−{-# options_ghc -fno-warn-redundant-constraints #-}

2−

3module Rel8.Query.Distinct

1module Rel8.Query.Distinct

4 ( distinct

2 ( distinct

5 , distinctOn

3 , distinctOn

@@ -8,12 +6,11 @@ module Rel8.Query.Distinct

8where

6where

10-- base

8-- base

11−import Prelude

9+import Prelude ()

13-- opaleye

11-- opaleye

14import qualified Opaleye.Distinct as Opaleye

12import qualified Opaleye.Distinct as Opaleye

15−import qualified Opaleye.Internal.Order as Opaleye

13+import qualified Opaleye.Order as Opaleye

16−import qualified Opaleye.Internal.QueryArr as Opaleye

18-- rel8

15-- rel8

19import Rel8.Order ( Order( Order ) )

16import Rel8.Order ( Order( Order ) )

@@ -33,13 +30,11 @@ distinct = mapOpaleye (Opaleye.distinctExplicit distinctspec)

33-- to a projection. If multiple rows have the same projection, it is

30-- to a projection. If multiple rows have the same projection, it is

34-- unspecified which row will be returned. If this matters, use 'distinctOnBy'.

31-- unspecified which row will be returned. If this matters, use 'distinctOnBy'.

35distinctOn :: EqTable b => (a -> b) -> Query a -> Query a

32distinctOn :: EqTable b => (a -> b) -> Query a -> Query a

36−distinctOn proj =

37− mapOpaleye (\q -> Opaleye.productQueryArr (Opaleye.distinctOn unpackspec proj . Opaleye.runSimpleQueryArr q))

33+distinctOn proj = mapOpaleye (Opaleye.distinctOnExplicit unpackspec proj)

40-- | Select all distinct rows from a query, where rows are equivalent according

36-- | Select all distinct rows from a query, where rows are equivalent according

41-- to a projection. If there are multiple rows with the same projection, the

37-- to a projection. If there are multiple rows with the same projection, the

42-- first row according to the specified 'Order' will be returned.

38-- first row according to the specified 'Order' will be returned.

43distinctOnBy :: EqTable b => (a -> b) -> Order a -> Query a -> Query a

39distinctOnBy :: EqTable b => (a -> b) -> Order a -> Query a -> Query a

44−distinctOnBy proj (Order order) =

40+distinctOnBy proj (Order order) = mapOpaleye (Opaleye.distinctOnByExplicit unpackspec proj order)

45− mapOpaleye (\q -> Opaleye.productQueryArr (Opaleye.distinctOnBy unpackspec proj order . Opaleye.runSimpleQueryArr q))

src/Rel8/Query/Evaluate.hs+3−22

@@ -3,7 +3,6 @@

4module Rel8.Query.Evaluate

5 ( evaluate

6− , rebind

7 )

6 )

8where

7where

@@ -16,28 +15,23 @@ import Prelude hiding ( undefined )

17-- opaleye

16-- opaleye

18import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye

17import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye

19−import qualified Opaleye.Internal.PackMap as Opaleye

20−import qualified Opaleye.Internal.PrimQuery as Opaleye

21−import qualified Opaleye.Internal.QueryArr as Opaleye

22−import qualified Opaleye.Internal.Tag as Opaleye

23−import qualified Opaleye.Internal.Unpackspec as Opaleye

25-- rel8

19-- rel8

26import Rel8.Expr ( Expr )

20import Rel8.Expr ( Expr )

27import Rel8.Expr.Bool ( (&&.) )

21import Rel8.Expr.Bool ( (&&.) )

28import Rel8.Expr.Opaleye ( fromPrimExpr )

22import Rel8.Expr.Opaleye ( fromPrimExpr )

29import Rel8.Query ( Query( Query ) )

23import Rel8.Query ( Query( Query ) )

24+import Rel8.Query.Rebind ( rebind )

30import Rel8.Table ( Table )

25import Rel8.Table ( Table )

31import Rel8.Table.Bool ( case_ )

26import Rel8.Table.Bool ( case_ )

32−import Rel8.Table.Opaleye ( unpackspec )

27+import Rel8.Table.Undefined ( undefined )

33−import Rel8.Table.Undefined

36-- | 'evaluate' takes expressions that could potentially have side effects and

30-- | 'evaluate' takes expressions that could potentially have side effects and

37-- \"runs\" them in the 'Query' monad. The returned expressions have no side

31-- \"runs\" them in the 'Query' monad. The returned expressions have no side

38-- effects and can safely be reused.

32-- effects and can safely be reused.

39evaluate :: Table Expr a => a -> Query a

33evaluate :: Table Expr a => a -> Query a

40−evaluate = laterally >=> rebind

34+evaluate = laterally >=> rebind "eval"

43laterally :: Table Expr a => a -> Query a

37laterally :: Table Expr a => a -> Query a

@@ -51,18 +45,5 @@ laterally a = Query $ \bindings -> pure $ (Any True,) $

51 go = fromPrimExpr . Opaleye.UnExpr Opaleye.OpIsNotNull

45 go = fromPrimExpr . Opaleye.UnExpr Opaleye.OpIsNotNull

54−-- | 'rebind' takes some expressions, and binds each of them to a new

55−-- variable in the SQL. The @a@ returned consists only of these

56−-- variables. It's essentially a @let@ binding for Postgres expressions.

57−rebind :: Table Expr a => a -> Query a

58−rebind a = Query $ \_ -> Opaleye.QueryArr $ \(_, tag) ->

59− let

60− tag' = Opaleye.next tag

61− (a', bindings) = Opaleye.run $

62− Opaleye.runUnpackspec unpackspec (Opaleye.extractAttr "eval" tag') a

63− in

64− ((mempty, a'), \_ -> Opaleye.Rebind True bindings, tag')

65−

66−

67foldl1' :: (a -> a -> a) -> NonEmpty a -> a

48foldl1' :: (a -> a -> a) -> NonEmpty a -> a

68foldl1' f (a :| as) = foldl' f a as

49foldl1' f (a :| as) = foldl' f a as

src/Rel8/Query/Exists.hs+1−1

@@ -12,7 +12,7 @@ import Prelude hiding ( filter )

13-- opaleye

14import qualified Opaleye.Exists as Opaleye

15−import qualified Opaleye.Operators as Opaleye hiding ( exists )

15+import qualified Opaleye.Operators as Opaleye

17-- rel8

18import Rel8.Expr ( Expr )

src/Rel8/Query/Indexed.hsnew file+21

@@ -0,0 +1,21 @@

1+module Rel8.Query.Indexed

2+ ( indexed

3+ )

4+where

6+-- base

7+import Control.Applicative ( liftA2 )

8+import Data.Int ( Int64 )

9+import Prelude

10+

11+-- rel8

12+import Rel8.Expr ( Expr )

13+import Rel8.Expr.Window ( rowNumber )

14+import Rel8.Query ( Query )

15+import Rel8.Query.Window ( window )

16+import Rel8.Table.Window ( currentRow )

17+

18+

19+-- | Pair each row of a query with its index within the query.

20+indexed :: Query a -> Query (Expr Int64, a)

21+indexed = window (liftA2 (,) (subtract 1 <$> rowNumber) currentRow)

src/Rel8/Query/List.hs+9−7

@@ -24,8 +24,8 @@ import Rel8.Expr.Aggregate ( listAggExpr, nonEmptyAggExpr )

24import Rel8.Expr.Opaleye ( mapPrimExpr )

25import Rel8.Query ( Query )

26import Rel8.Query.Aggregate ( aggregate )

27−import Rel8.Query.Evaluate ( rebind )

28import Rel8.Query.Maybe ( optional )

27import Rel8.Query.Maybe ( optional )

28+import Rel8.Query.Rebind ( rebind )

29import Rel8.Schema.HTable.Vectorize ( hunvectorize )

30import Rel8.Schema.Null ( Sql, Unnullify )

31import Rel8.Schema.Spec ( Spec( Spec, info ) )

@@ -85,8 +85,9 @@ someExpr = aggregate . fmap nonEmptyAggExpr

85--

86-- @catListTable@ is an inverse to 'many'.

87catListTable :: Table Expr a => ListTable Expr a -> Query a

88+catListTable (ListTable as) =

88−catListTable (ListTable as) = rebind $ fromColumns $ runIdentity $

89+ rebind "unnest" $ fromColumns $ runIdentity $

89− hunvectorize (\Spec {info} -> pure . sunnest info) as

90+ hunvectorize (\Spec {info} -> pure . sunnest info) as

92-- | Expand a 'NonEmptyTable' into a 'Query', where each row in the query is an

93-- | Expand a 'NonEmptyTable' into a 'Query', where each row in the query is an

@@ -94,8 +95,9 @@ catListTable (ListTable as) = rebind $ fromColumns $ runIdentity $

94--

95--

95-- @catNonEmptyTable@ is an inverse to 'some'.

96-- @catNonEmptyTable@ is an inverse to 'some'.

96catNonEmptyTable :: Table Expr a => NonEmptyTable Expr a -> Query a

97catNonEmptyTable :: Table Expr a => NonEmptyTable Expr a -> Query a

97−catNonEmptyTable (NonEmptyTable as) = rebind $ fromColumns $ runIdentity $

98+catNonEmptyTable (NonEmptyTable as) =

99+ rebind "unnest" $ fromColumns $ runIdentity $

98− hunvectorize (\Spec {info} -> pure . sunnest info) as

100+ hunvectorize (\Spec {info} -> pure . sunnest info) as

101

100

102

101-- | Expand an expression that contains a list into a 'Query', where each row

103-- | Expand an expression that contains a list into a 'Query', where each row

@@ -103,7 +105,7 @@ catNonEmptyTable (NonEmptyTable as) = rebind $ fromColumns $ runIdentity $

103--

105--

104-- @catList@ is an inverse to 'manyExpr'.

106-- @catList@ is an inverse to 'manyExpr'.

105catList :: Sql DBType a => Expr [a] -> Query (Expr a)

107catList :: Sql DBType a => Expr [a] -> Query (Expr a)

106−catList = rebind . sunnest typeInformation

108+catList = rebind "unnest" . sunnest typeInformation

107

109

108

110

109-- | Expand an expression that contains a non-empty list into a 'Query', where

111-- | Expand an expression that contains a non-empty list into a 'Query', where

@@ -111,7 +113,7 @@ catList = rebind . sunnest typeInformation

111--

113--

112-- @catNonEmpty@ is an inverse to 'someExpr'.

114-- @catNonEmpty@ is an inverse to 'someExpr'.

113catNonEmpty :: Sql DBType a => Expr (NonEmpty a) -> Query (Expr a)

115catNonEmpty :: Sql DBType a => Expr (NonEmpty a) -> Query (Expr a)

114−catNonEmpty = rebind . sunnest typeInformation

116+catNonEmpty = rebind "unnest" . sunnest typeInformation

115

117

116

118

117sunnest :: TypeInformation (Unnullify a) -> Expr (list a) -> Expr a

119sunnest :: TypeInformation (Unnullify a) -> Expr (list a) -> Expr a

src/Rel8/Query/Null.hs+15

@@ -1,5 +1,8 @@

1+{-# language FlexibleContexts #-}

1module Rel8.Query.Null

3module Rel8.Query.Null

2 ( catNull

4 ( catNull

5+ , catNullTable

3 )

6 )

4where

7where

@@ -9,6 +12,8 @@ import Prelude

9-- rel8

12-- rel8

10import Rel8.Expr ( Expr )

13import Rel8.Expr ( Expr )

11import Rel8.Expr.Null ( isNonNull, unsafeUnnullify )

14import Rel8.Expr.Null ( isNonNull, unsafeUnnullify )

15+import Rel8.Table ( Table )

16+import Rel8.Table.Null ( NullTable, isNonNullTable, unsafeUnnullifyTable )

12import Rel8.Query ( Query )

17import Rel8.Query ( Query )

13import Rel8.Query.Filter ( where_ )

18import Rel8.Query.Filter ( where_ )

@@ -21,3 +26,13 @@ catNull :: Expr (Maybe a) -> Query (Expr a)

21catNull a = do

26catNull a = do

22 where_ $ isNonNull a

27 where_ $ isNonNull a

23 pure $ unsafeUnnullify a

28 pure $ unsafeUnnullify a

29+

30+

31+-- | Filter a 'Query' that might return @nullTable@ to a 'Query' without any

32+-- @nullTable@s.

33+--

34+-- Corresponds to 'Data.Maybe.catMaybes'.

35+catNullTable :: Table Expr a => NullTable Expr a -> Query a

36+catNullTable a = do

37+ where_ $ isNonNullTable a

38+ pure $ unsafeUnnullifyTable a

src/Rel8/Query/Opaleye.hs+18−10

@@ -5,6 +5,7 @@ module Rel8.Query.Opaleye

5 , toOpaleye

6 , mapOpaleye

7 , zipOpaleyeWith

8+ , unsafePeekQuery

8 )

9 )

9where

10where

@@ -14,6 +15,7 @@ import Prelude

15-- opaleye

16-- opaleye

16import qualified Opaleye.Internal.QueryArr as Opaleye

17import qualified Opaleye.Internal.QueryArr as Opaleye

18+import qualified Opaleye.Internal.Tag as Opaleye

18-- rel8

20-- rel8

19import {-# SOURCE #-} Rel8.Query ( Query( Query ) )

21import {-# SOURCE #-} Rel8.Query ( Query( Query ) )

@@ -37,26 +39,32 @@ zipOpaleyeWith :: ()

37zipOpaleyeWith f (Query a) (Query b) = Query $ liftA2 (zipping f) a b

39zipOpaleyeWith f (Query a) (Query b) = Query $ liftA2 (zipping f) a b

42+unsafePeekQuery :: Query a -> a

43+unsafePeekQuery (Query q) = case q mempty of

44+ f -> case Opaleye.runStateQueryArr f () Opaleye.start of

45+ ((_, a), _, _) -> a

46+

47+

40mapping :: ()

48mapping :: ()

41 => (Opaleye.Select a -> Opaleye.Select b)

49 => (Opaleye.Select a -> Opaleye.Select b)

42 -> Opaleye.Select (m, a) -> Opaleye.Select (m, b)

50 -> Opaleye.Select (m, a) -> Opaleye.Select (m, b)

43−mapping f q@(Opaleye.QueryArr qa) = Opaleye.QueryArr $ \(_, tag) ->

51+mapping f q = Opaleye.stateQueryArr $ \_ tag ->

44 let

52 let

45− ((m, _), _, _) = qa ((), tag)

53+ ((m, _), _, _) = Opaleye.runStateQueryArr q () tag

46− Opaleye.QueryArr qa' = (m,) <$> f (snd <$> q)

54+ q' = (m,) <$> f (snd <$> q)

47 in

55 in

48− qa' ((), tag)

56+ Opaleye.runStateQueryArr q' () tag

51zipping :: Semigroup m

59zipping :: Semigroup m

52 => (Opaleye.Select a -> Opaleye.Select b -> Opaleye.Select c)

60 => (Opaleye.Select a -> Opaleye.Select b -> Opaleye.Select c)

53 -> Opaleye.Select (m, a) -> Opaleye.Select (m, b) -> Opaleye.Select (m, c)

61 -> Opaleye.Select (m, a) -> Opaleye.Select (m, b) -> Opaleye.Select (m, c)

54−zipping f q@(Opaleye.QueryArr qa) q'@(Opaleye.QueryArr qa') =

62+zipping f q q' =

55− Opaleye.QueryArr $ \(_, tag) ->

63+ Opaleye.stateQueryArr $ \_ tag ->

56 let

64 let

57− ((m, _), _, _) = qa ((), tag)

65+ ((m, _), _, _) = Opaleye.runStateQueryArr q () tag

58− ((m', _), _, _) = qa' ((), tag)

66+ ((m', _), _, _) = Opaleye.runStateQueryArr q' () tag

59 m'' = m <> m'

67 m'' = m <> m'

60− Opaleye.QueryArr qa'' = (m'',) <$> f (snd <$> q) (snd <$> q')

68+ q'' = (m'',) <$> f (snd <$> q) (snd <$> q')

61 in

69 in

62− qa'' ((), tag)

70+ Opaleye.runStateQueryArr q'' () tag

src/Rel8/Query/Rebind.hsnew file+27

@@ -0,0 +1,27 @@

1+{-# language FlexibleContexts #-}

3+module Rel8.Query.Rebind

4+ ( rebind

5+ )

6+where

8+-- base

9+import Prelude

10+import Control.Arrow ((<<<))

11+

12+-- opaleye

13+import qualified Opaleye.Internal.Rebind as Opaleye

14+

15+-- rel8

16+import Rel8.Expr ( Expr )

17+import Rel8.Query ( Query )

18+import Rel8.Table ( Table )

19+import Rel8.Table.Opaleye ( unpackspec )

20+import Rel8.Query.Opaleye (fromOpaleye)

21+

22+

23+-- | 'rebind' takes a variable name, some expressions, and binds each of them

24+-- to a new variable in the SQL. The @a@ returned consists only of these

25+-- variables. It's essentially a @let@ binding for Postgres expressions.

26+rebind :: Table Expr a => String -> a -> Query a

27+rebind prefix a = fromOpaleye (Opaleye.rebindExplicitPrefix prefix unpackspec <<< pure a)

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

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

1{-# language FlexibleContexts #-}

2−{-# language TypeFamilies #-}

2+{-# language MonoLocalBinds #-}

3−{-# language ViewPatterns #-}

5module Rel8.Query.SQL

4module Rel8.Query.SQL

6 ( showQuery

5 ( showQuery

7− , sqlForQuery, sqlForQueryWithNames

8 )

6 )

9where

7where

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

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 )

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 = 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/Query/Set.hs+6−6

@@ -23,36 +23,36 @@ import Rel8.Table.Opaleye ( binaryspec )

25-- | Combine the results of two queries of the same type, collapsing

26−-- duplicates. @union a b@ is the same as the SQL statement @x UNION b@.

26+-- duplicates. @union a b@ is the same as the SQL statement @a UNION b@.

27union :: EqTable a => Query a -> Query a -> Query a

28union = zipOpaleyeWith (Opaleye.unionExplicit binaryspec)

31-- | Combine the results of two queries of the same type, retaining duplicates.

32−-- @unionAll a b@ is the same as the SQL statement @x UNION ALL b@.

32+-- @unionAll a b@ is the same as the SQL statement @a UNION ALL b@.

33unionAll :: Table Expr a => Query a -> Query a -> Query a

34unionAll = zipOpaleyeWith (Opaleye.unionAllExplicit binaryspec)

37-- | Find the intersection of two queries, collapsing duplicates. @intersect a

38−-- b@ is the same as the SQL statement @x INTERSECT b@.

38+-- b@ is the same as the SQL statement @a INTERSECT b@.

39intersect :: EqTable a => Query a -> Query a -> Query a

40intersect = zipOpaleyeWith (Opaleye.intersectExplicit binaryspec)

43-- | Find the intersection of two queries, retaining duplicates. @intersectAll

44−-- a b@ is the same as the SQL statement @x INTERSECT ALL b@.

44+-- a b@ is the same as the SQL statement @a INTERSECT ALL b@.

45intersectAll :: EqTable a => Query a -> Query a -> Query a

46intersectAll = zipOpaleyeWith (Opaleye.intersectAllExplicit binaryspec)

49-- | Find the difference of two queries, collapsing duplicates @except a b@ is

50−-- the same as the SQL statement @x INTERSECT b@.

50+-- the same as the SQL statement @a EXCEPT b@.

51except :: EqTable a => Query a -> Query a -> Query a

52except = zipOpaleyeWith (Opaleye.exceptExplicit binaryspec)

55-- | Find the difference of two queries, retaining duplicates. @exceptAll a b@

56−-- is the same as the SQL statement @x EXCEPT ALL b@.

56+-- is the same as the SQL statement @a EXCEPT ALL b@.

57exceptAll :: EqTable a => Query a -> Query a -> Query a

58exceptAll = zipOpaleyeWith (Opaleye.exceptAllExplicit binaryspec)

src/Rel8/Query/These.hs+8−8

@@ -48,11 +48,11 @@ import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ) )

48alignBy :: ()

49 => (a -> b -> Expr Bool)

50 -> Query a -> Query b -> Query (TheseTable Expr a b)

51−alignBy condition = zipOpaleyeWith $ \left right -> Opaleye.QueryArr $ \i -> case i of

51+alignBy condition = zipOpaleyeWith $ \left right -> Opaleye.stateQueryArr $ \_ t -> case t of

52− (_, tag) -> (tab, join', tag''')

52+ tag -> (tab, join', tag''')

53 where

54− (ma, left', tag') = Opaleye.runSimpleQueryArr (pure <$> left) ((), tag)

54+ (ma, left', tag') = Opaleye.runStateQueryArr (pure <$> left) () tag

55− (mb, right', tag'') = Opaleye.runSimpleQueryArr (pure <$> right) ((), tag')

55+ (mb, right', tag'') = Opaleye.runStateQueryArr (pure <$> right) () tag'

56 MaybeTable hasHere a = ma

57 MaybeTable hasThere b = mb

58 (hasHere', lbindings) = Opaleye.run $ do

@@ -60,15 +60,15 @@ alignBy condition = zipOpaleyeWith $ \left right -> Opaleye.QueryArr $ \i -> cas

60 (hasThere', rbindings) = Opaleye.run $ do

61 traversePrimExpr (Opaleye.extractAttr "hasThere" tag'') hasThere

62 tag''' = Opaleye.next tag''

63− join lateral = Opaleye.Join Opaleye.FullJoin on left'' right''

63+ join = Opaleye.Join Opaleye.FullJoin on left'' right''

64 where

65 on = toPrimExpr $ condition (extract a) (extract b)

66− left'' = (lateral, Opaleye.Rebind True lbindings left')

66+ left'' = (Opaleye.NonLateral, Opaleye.toPrimQuery (left' <> Opaleye.aRebind lbindings))

67− right'' = (lateral, Opaleye.Rebind True rbindings right')

67+ right'' = (Opaleye.NonLateral, Opaleye.toPrimQuery (right' <> Opaleye.aRebind rbindings))

68 ma' = MaybeTable hasHere' a

69 mb' = MaybeTable hasThere' b

70 tab = TheseTable {here = ma', there = mb'}

71− join' lateral input = Opaleye.times lateral input (join lateral)

71+ join' = Opaleye.aProduct join

74keepHereTable :: TheseTable Expr a b -> Query (a, MaybeTable Expr b)

src/Rel8/Query/Window.hsnew file+26

@@ -0,0 +1,26 @@

1+module Rel8.Query.Window

2+ ( window

3+ )

4+where

6+-- base

7+import Prelude ()

9+-- opaleye

10+import qualified Opaleye.Window as Opaleye

11+

12+-- rel8

13+import Rel8.Query ( Query )

14+import Rel8.Query.Opaleye ( mapOpaleye )

15+import Rel8.Window ( Window( Window ) )

16+

17+

18+-- | 'window' runs a query composed of expressions containing

19+-- [window functions](https://www.postgresql.org/docs/current/tutorial-window.html).

20+-- 'window' is similar to 'Rel8.aggregate', with the main difference being

21+-- that in a window query, each input row corresponds to one output row,

22+-- whereas aggregation queries fold the entire input query down into a single

23+-- row. To put this into a Haskell context, 'Rel8.aggregate' is to 'foldl' as

24+-- 'window' is to 'scanl'.

25+window :: Window a b -> Query a -> Query b

26+window (Window a) = mapOpaleye (Opaleye.runWindows a)

src/Rel8/Schema/Context/Nullify.hs+24−28

@@ -18,19 +18,19 @@ where

18import Data.Bool ( bool )

19import Data.Functor.Identity ( Identity( Identity ) )

20import Data.Kind ( Constraint, Type )

21−import Data.Monoid ( getFirst )

22import Prelude hiding ( null )

21import Prelude hiding ( null )

24-- opaleye

23-- opaleye

25import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye

24import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye

27-- rel8

26-- rel8

28−import Rel8.Aggregate ( Aggregate( Aggregate ), foldInputs, mapInputs )

27+import Rel8.Aggregate ( Aggregate(..), zipOutputs )

29import Rel8.Expr ( Expr )

28import Rel8.Expr ( Expr )

30import Rel8.Expr.Bool ( boolExpr )

29import Rel8.Expr.Bool ( boolExpr )

31import Rel8.Expr.Null ( nullify, unsafeUnnullify )

30import Rel8.Expr.Null ( nullify, unsafeUnnullify )

32−import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr )

31+import Rel8.Expr.Opaleye ( fromPrimExpr )

33import Rel8.Kind.Context ( SContext(..) )

32import Rel8.Kind.Context ( SContext(..) )

33+import Rel8.Schema.Field ( Field )

34import qualified Rel8.Schema.Kind as K

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

36import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ) )

@@ -64,7 +64,8 @@ instance Nullifiable Name where

65type NonNullifiability :: K.Context -> Type

66data NonNullifiability context where

67+ NField :: NonNullifiability (Field table)

67− NNResult :: NonNullifiability Result

68+ NResult :: NonNullifiability Result

70nullifiableOrNot :: ()

71nullifiableOrNot :: ()

@@ -73,8 +74,9 @@ nullifiableOrNot :: ()

73nullifiableOrNot = \case

74nullifiableOrNot = \case

74 SAggregate -> Right NAggregate

75 SAggregate -> Right NAggregate

75 SExpr -> Right NExpr

76 SExpr -> Right NExpr

77+ SField -> Left NField

76 SName -> Right NName

78 SName -> Right NName

77− SResult -> Left NNResult

79+ SResult -> Left NResult

80absurd :: Nullifiability context -> NonNullifiability context -> a

82absurd :: Nullifiability context -> NonNullifiability context -> a

@@ -91,21 +93,13 @@ guarder :: ()

91 -> (Expr tag -> Expr Bool)

93 -> (Expr tag -> Expr Bool)

92 -> context (Maybe a)

94 -> context (Maybe a)

93 -> context (Maybe a)

95 -> context (Maybe a)

96+guarder = \case

94−guarder SAggregate tag _ isNonNull (Aggregate a) =

97+ SAggregate -> \tag _ isNonNull -> zipOutputs (sguard . isNonNull) tag

95− mapInputs (toPrimExpr . run . fromPrimExpr) $

96− Aggregate $

97− run <$> a

98− where

99− mtag = foldInputs (\_ -> pure . fromPrimExpr) tag

100− run = maybe id (sguard . isNonNull) (getFirst mtag)

101−guarder SExpr tag _ isNonNull a = sguard condition a

98+ SExpr -> \tag _ isNonNull -> sguard (isNonNull tag)

102− where

99+ SField -> \_ _ _ -> id

103− condition = isNonNull tag

104−guarder SName _ _ _ name = name

100+ SName -> \_ _ _ -> id

105−guarder SResult (Identity tag) isNonNull _ (Identity a) =

101+ SResult -> \(Identity tag) isNonNull _ (Identity a) ->

106− Identity (bool Nothing a condition)

102+ Identity (bool Nothing a (isNonNull tag))

107− where

108− condition = isNonNull tag

109

103

110

104

111nullifier :: ()

105nullifier :: ()

@@ -113,10 +107,11 @@ nullifier :: ()

113 -> Spec a

107 -> Spec a

114 -> context a

108 -> context a

115 -> context (Nullify a)

109 -> context (Nullify a)

110+nullifier = \case

116−nullifier NAggregate Spec {nullity} (Aggregate a) =

111+ NAggregate -> \Spec {nullity} (Aggregate a) ->

117− Aggregate $ snullify nullity <$> a

112+ Aggregate $ snullify nullity <$> a

118−nullifier NExpr Spec {nullity} a = snullify nullity a

113+ NExpr -> \Spec {nullity} a -> snullify nullity a

119−nullifier NName _ (Name a) = Name a

114+ NName -> \_ (Name a) -> Name a

120

115

121

116

122unnullifier :: ()

117unnullifier :: ()

@@ -124,10 +119,11 @@ unnullifier :: ()

124 -> Spec a

119 -> Spec a

125 -> context (Nullify a)

120 -> context (Nullify a)

126 -> context a

121 -> context a

122+unnullifier = \case

127−unnullifier NAggregate Spec {nullity} (Aggregate a) =

123+ NAggregate -> \Spec {nullity} (Aggregate a) ->

128− Aggregate $ sunnullify nullity <$> a

124+ Aggregate $ sunnullify nullity <$> a

129−unnullifier NExpr Spec {nullity} a = sunnullify nullity a

125+ NExpr -> \Spec {nullity} a -> sunnullify nullity a

130−unnullifier NName _ (Name a) = Name a

126+ NName -> \_ (Name a) -> Name a

131

127

132

128

133sguard :: Expr Bool -> Expr (Maybe a) -> Expr (Maybe a)

129sguard :: Expr Bool -> Expr (Maybe a) -> Expr (Maybe a)

src/Rel8/Schema/Field.hsnew file+50

@@ -0,0 +1,50 @@

1+{-# language DataKinds #-}

2+{-# language FlexibleContexts #-}

3+{-# language MultiParamTypeClasses #-}

4+{-# language StandaloneKindSignatures #-}

5+{-# language TypeFamilies #-}

7+module Rel8.Schema.Field

8+ ( Field(..)

9+ , fields

10+ )

11+where

12+

13+-- base

14+import Data.Functor.Identity ( Identity( Identity ) )

15+import Data.Kind ( Type )

16+import Prelude

17+

18+-- rel8

19+import Rel8.Schema.HTable ( HField, htabulate )

20+import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )

21+import Rel8.Schema.Kind as K

22+import Rel8.Schema.Null ( Sql )

23+import Rel8.Table

24+ ( Table, Columns, Context, fromColumns, toColumns

25+ , FromExprs, fromResult, toResult

26+ , Transpose

27+ )

28+import Rel8.Table.Transpose ( Transposes )

29+import Rel8.Type ( DBType )

30+

31+

32+-- | A special context used in the construction of 'Rel8.Projection's.

33+type Field :: Type -> K.Context

34+newtype Field table a = Field (HField (Columns table) a)

35+

36+

37+instance Sql DBType a => Table (Field table) (Field table a) where

38+ type Columns (Field table a) = HIdentity a

39+ type Context (Field table a) = Field table

40+ type FromExprs (Field table a) = a

41+ type Transpose to (Field table a) = to a

42+

43+ toColumns = HIdentity

44+ fromColumns (HIdentity a) = a

45+ toResult a = HIdentity (Identity a)

46+ fromResult (HIdentity (Identity a)) = a

47+

48+

49+fields :: Transposes context (Field table) table fields => fields

50+fields = fromColumns $ htabulate Field

src/Rel8/Schema/HTable.hs+29−2

@@ -16,11 +16,12 @@

16module Rel8.Schema.HTable

17 ( HTable (HField, HConstrainTable)

18 , hfield, htabulate, htraverse, hdicts, hspecs

19− , hmap, htabulateA

19+ , hfoldMap, hmap, htabulateA, htraverseP, htraversePWithField

20 )

21where

23-- base

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

24import Data.Kind ( Constraint, Type )

25import Data.Kind ( Constraint, Type )

25import Data.Functor.Compose ( Compose( Compose ), getCompose )

26import Data.Functor.Compose ( Compose( Compose ), getCompose )

26import Data.Proxy ( Proxy )

27import Data.Proxy ( Proxy )

@@ -32,6 +33,12 @@ import GHC.Generics

32 )

33 )

33import Prelude

34import Prelude

36+-- profunctors

37+import Data.Profunctor ( rmap, Profunctor (lmap) )

38+

39+-- product-profunctors

40+import Data.Profunctor.Product ( ProductProfunctor ((****)) )

41+

35-- rel8

42-- rel8

36import Rel8.Schema.Dict ( Dict )

43import Rel8.Schema.Dict ( Dict )

37import Rel8.Schema.Spec ( Spec )

44import Rel8.Schema.Spec ( Spec )

@@ -41,7 +48,6 @@ import qualified Rel8.Schema.Kind as K

41-- semigroupoids

48-- semigroupoids

42import Data.Functor.Apply ( Apply, (<.>) )

49import Data.Functor.Apply ( Apply, (<.>) )

44−

45-- | A @HTable@ is a functor-indexed/higher-kinded data type that is

51-- | A @HTable@ is a functor-indexed/higher-kinded data type that is

46-- representable ('htabulate'/'hfield'), constrainable ('hdicts'), and

52-- representable ('htabulate'/'hfield'), constrainable ('hdicts'), and

47-- specified ('hspecs').

53-- specified ('hspecs').

@@ -114,6 +120,11 @@ class HTable t where

114 {-# INLINABLE hspecs #-}

120 {-# INLINABLE hspecs #-}

115

121

116

122

123+hfoldMap :: (HTable t, Semigroup s)

124+ => (forall a. context a -> s) -> t context -> s

125+hfoldMap f a = getConst $ htraverse (Const . f) a

126+

127+

117hmap :: HTable t

128hmap :: HTable t

118 => (forall a. context a -> context' a) -> t context -> t context'

129 => (forall a. context a -> context' a) -> t context -> t context'

119hmap f a = htabulate $ \field -> f (hfield a field)

130hmap f a = htabulate $ \field -> f (hfield a field)

@@ -124,6 +135,22 @@ htabulateA :: (HTable t, Apply m)

124htabulateA f = htraverse getCompose $ htabulate $ Compose . f

135htabulateA f = htraverse getCompose $ htabulate $ Compose . f

125{-# INLINABLE htabulateA #-}

136{-# INLINABLE htabulateA #-}

126

137

138+newtype ApplyP p a b = ApplyP { unApplyP :: p a b }

139+

140+instance Profunctor p => Functor (ApplyP p a) where

141+ fmap f = ApplyP . rmap f . unApplyP

142+

143+instance ProductProfunctor p => Apply (ApplyP p a) where

144+ ApplyP f <.> ApplyP x = ApplyP (rmap id f **** x)

145+

146+htraverseP :: (HTable t, ProductProfunctor p)

147+ => (forall a. p (f a) (g a)) -> p (t f) (t g)

148+htraverseP f = htraversePWithField (const f)

149+

150+htraversePWithField :: (HTable t, ProductProfunctor p)

151+ => (forall a. HField t a -> p (f a) (g a)) -> p (t f) (t g)

152+htraversePWithField f = unApplyP $ htabulateA $ \field -> ApplyP $

153+ lmap (flip hfield field) (f field)

127

154

128type GHField :: K.HTable -> Type -> Type

155type GHField :: K.HTable -> Type -> Type

129newtype GHField t a = GHField (HField (GHColumns (Rep (t Proxy))) a)

156newtype GHField t a = GHField (HField (GHColumns (Rep (t Proxy))) a)

src/Rel8/Schema/HTable/Label.hs+11

@@ -1,4 +1,5 @@

1{-# language DataKinds #-}

2+{-# language RankNTypes #-}

2{-# language RecordWildCards #-}

3{-# language RecordWildCards #-}

3{-# language ScopedTypeVariables #-}

4{-# language ScopedTypeVariables #-}

4{-# language StandaloneKindSignatures #-}

5{-# language StandaloneKindSignatures #-}

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

8module Rel8.Schema.HTable.Label

9module Rel8.Schema.HTable.Label

9 ( HLabel, hlabel, hrelabel, hunlabel

10 ( HLabel, hlabel, hrelabel, hunlabel

11+ , hproject

10 )

12 )

11where

13where

@@ -18,6 +20,9 @@ import Prelude

19-- rel8

21-- rel8

20import Rel8.Schema.HTable

22import Rel8.Schema.HTable

23+ ( HTable, HConstrainTable, HField

24+ , htabulate, hfield, htraverse, hdicts, hspecs

25+ )

21import qualified Rel8.Schema.Kind as K

26import qualified Rel8.Schema.Kind as K

22import Rel8.Schema.Spec ( Spec(..) )

27import Rel8.Schema.Spec ( Spec(..) )

@@ -57,3 +62,9 @@ hrelabel = hlabel . hunlabel

57hunlabel :: forall label t context. HLabel label t context -> t context

62hunlabel :: forall label t context. HLabel label t context -> t context

58hunlabel (HLabel a) = a

63hunlabel (HLabel a) = a

59{-# INLINABLE hunlabel #-}

64{-# INLINABLE hunlabel #-}

65+

66+

67+hproject :: ()

68+ => (forall ctx. t ctx -> t' ctx)

69+ -> HLabel label t context -> HLabel label t' context

70+hproject f (HLabel a) = HLabel (f a)

src/Rel8/Schema/HTable/MapTable.hs+8

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

6{-# language GADTs #-}

7{-# language InstanceSigs #-}

8{-# language MultiParamTypeClasses #-}

9+{-# language RankNTypes #-}

9{-# language ScopedTypeVariables #-}

10{-# language ScopedTypeVariables #-}

10{-# language StandaloneKindSignatures #-}

11{-# language StandaloneKindSignatures #-}

11{-# language TypeApplications #-}

12{-# language TypeApplications #-}

@@ -18,6 +19,7 @@ module Rel8.Schema.HTable.MapTable

18 , MapSpec(..)

19 , MapSpec(..)

19 , Precompose(..)

20 , Precompose(..)

20 , HMapTableField(..)

21 , HMapTableField(..)

22+ , hproject

21 )

23 )

22where

24where

@@ -89,3 +91,9 @@ class MapSpec f where

89type ComposeConstraint :: (Type -> Exp Type) -> (Type -> Constraint) -> Type -> Constraint

91type ComposeConstraint :: (Type -> Exp Type) -> (Type -> Constraint) -> Type -> Constraint

90class c (Eval (f a)) => ComposeConstraint f c a

92class c (Eval (f a)) => ComposeConstraint f c a

91instance c (Eval (f a)) => ComposeConstraint f c a

93instance c (Eval (f a)) => ComposeConstraint f c a

94+

95+

96+hproject :: ()

97+ => (forall ctx. t ctx -> t' ctx)

98+ -> HMapTable f t context -> HMapTable f t' context

99+hproject f (HMapTable a) = HMapTable (f a)

src/Rel8/Schema/HTable/Nullify.hs+8

@@ -23,6 +23,7 @@ module Rel8.Schema.HTable.Nullify

23 , hnulls

24 , hnullify

25 , hunnullify

26+ , hproject

26 )

27 )

27where

28where

@@ -38,6 +39,7 @@ import Rel8.Schema.HTable.MapTable

38 ( HMapTable, HMapTableField( HMapTableField )

39 ( HMapTable, HMapTableField( HMapTableField )

39 , MapSpec, mapInfo

40 , MapSpec, mapInfo

40 )

41 )

42+import qualified Rel8.Schema.HTable.MapTable as HMapTable ( hproject )

41import qualified Rel8.Schema.Kind as K

43import qualified Rel8.Schema.Kind as K

42import Rel8.Schema.Null ( Nullity( Null, NotNull ) )

44import Rel8.Schema.Null ( Nullity( Null, NotNull ) )

43import qualified Rel8.Schema.Null as Type ( Nullify )

45import qualified Rel8.Schema.Null as Type ( Nullify )

@@ -107,3 +109,9 @@ hunnullify unnullifier (HNullify as) =

107 spec@Spec {} -> case hfield as (HMapTableField field) of

109 spec@Spec {} -> case hfield as (HMapTableField field) of

108 a -> unnullifier spec a

110 a -> unnullifier spec a

109{-# INLINABLE hunnullify #-}

111{-# INLINABLE hunnullify #-}

112+

113+

114+hproject :: ()

115+ => (forall ctx. t ctx -> t' ctx)

116+ -> HNullify t context -> HNullify t' context

117+hproject f (HNullify a) = HNullify (HMapTable.hproject f a)

src/Rel8/Schema/HTable/Vectorize.hs+23−4

@@ -21,18 +21,29 @@ module Rel8.Schema.HTable.Vectorize

21 ( HVectorize

22 , hvectorize, hunvectorize

23 , happend, hempty

24+ , hproject

25+ , hcolumn

24 )

26 )

25where

27where

27-- base

29-- base

28−import Data.Kind ( Type )

30+import Data.Kind ( Constraint, Type )

29import Data.List.NonEmpty ( NonEmpty )

31import Data.List.NonEmpty ( NonEmpty )

32+import GHC.Generics (Generic)

30import Prelude

33import Prelude

32-- rel8

35-- rel8

36+import Rel8.FCF ( Eval, Exp )

33import Rel8.Schema.Dict ( Dict( Dict ) )

37import Rel8.Schema.Dict ( Dict( Dict ) )

34import qualified Rel8.Schema.Kind as K

38import qualified Rel8.Schema.Kind as K

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

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

40+import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )

41+import Rel8.Schema.HTable.MapTable

42+ ( HMapTable( HMapTable ), HMapTableField( HMapTableField )

43+ , MapSpec, mapInfo

44+ , Precompose( Precompose )

45+ )

46+import qualified Rel8.Schema.HTable.MapTable as HMapTable ( hproject )

36import Rel8.Schema.Null ( Unnullify, NotNull, Nullity( NotNull ) )

47import Rel8.Schema.Null ( Unnullify, NotNull, Nullity( NotNull ) )

37import Rel8.Schema.Spec ( Spec(..) )

48import Rel8.Schema.Spec ( Spec(..) )

38import Rel8.Type.Array ( listTypeInformation, nonEmptyTypeInformation )

49import Rel8.Type.Array ( listTypeInformation, nonEmptyTypeInformation )

@@ -40,11 +51,9 @@ import Rel8.Type.Information ( TypeInformation )

41-- semialign

52-- semialign

42import Data.Zip ( Unzip, Zip, Zippy(..) )

53import Data.Zip ( Unzip, Zip, Zippy(..) )

43−import Rel8.FCF

44−import Rel8.Schema.HTable.MapTable

45−import GHC.Generics (Generic)

56+type Vector :: (Type -> Type) -> Constraint

48class Vector list where

57class Vector list where

49 listNotNull :: proxy a -> Dict NotNull (list a)

58 listNotNull :: proxy a -> Dict NotNull (list a)

50 vectorTypeInformation :: ()

59 vectorTypeInformation :: ()

@@ -122,3 +131,13 @@ hempty :: HTable t

122 -> HVectorize [] t context

131 -> HVectorize [] t context

123hempty empty = HVectorize $ htabulate $ \(HMapTableField field) ->

132hempty empty = HVectorize $ htabulate $ \(HMapTableField field) ->

124 empty (hfield hspecs field)

133 empty (hfield hspecs field)

134+

135+

136+hproject :: ()

137+ => (forall ctx. t ctx -> t' ctx)

138+ -> HVectorize list t context -> HVectorize list t' context

139+hproject f (HVectorize a) = HVectorize (HMapTable.hproject f a)

140+

141+

142+hcolumn :: HVectorize list (HIdentity a) context -> context (list a)

143+hcolumn (HVectorize (HMapTable (HIdentity (Precompose a)))) = a

src/Rel8/Schema/Name.hs+12

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

13module Rel8.Schema.Name

14 ( Name(..)

15 , Selects

16+ , ppColumn

16 )

17 )

17where

18where

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

22import Data.String ( IsString )

23import Data.String ( IsString )

23import Prelude

24import Prelude

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+20

@@ -1,14 +1,26 @@

1{-# language DeriveFunctor #-}

2{-# language DerivingStrategies #-}

3+{-# language DisambiguateRecordFields #-}

4+{-# language NamedFieldPuns #-}

5+{-# language StandaloneKindSignatures #-}

4module Rel8.Schema.Table

7module Rel8.Schema.Table

5 ( TableSchema(..)

8 ( TableSchema(..)

9+ , ppTable

6 )

10 )

7where

11where

9-- base

13-- base

14+import Data.Kind ( Type )

10import Prelude

15import Prelude

17+-- opaleye

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

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

20+

21+-- pretty

22+import Text.PrettyPrint ( Doc )

23+

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

25-- | 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

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

@@ -16,6 +28,7 @@ import Prelude

16--

28--

17-- For each selectable table in your database, you should provide a

29-- For each selectable table in your database, you should provide a

18-- @TableSchema@ in order to interact with the table via Rel8.

30-- @TableSchema@ in order to interact with the table via Rel8.

31+type TableSchema :: Type -> Type

19data TableSchema names = TableSchema

32data TableSchema names = TableSchema

20 { name :: String

33 { name :: String

21 -- ^ The name of the table.

34 -- ^ The name of the table.

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

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

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

28 }

41 }

29 deriving stock Functor

42 deriving stock Functor

43+

44+

45+ppTable :: TableSchema a -> Doc

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

47+ { sqlTableSchemaName = schema

48+ , sqlTableName = name

49+ }

src/Rel8/Statement/Delete.hs+35−48

@@ -1,40 +1,37 @@

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 #-}

8module Rel8.Statement.Delete

9module Rel8.Statement.Delete

9 ( Delete(..)

10 ( Delete(..)

10 , delete

11 , delete

12+ , ppDelete

11 )

13 )

12where

14where

14-- base

16-- base

15−import Control.Exception ( throwIO )

16import Data.Kind ( Type )

17import Data.Kind ( Type )

17import Prelude

18import Prelude

19-- hasql

20-- hasql

20−import Hasql.Connection ( Connection )

21−import qualified Hasql.Decoders as Hasql

22import qualified Hasql.Encoders as Hasql

21import qualified Hasql.Encoders as Hasql

23−import qualified Hasql.Session as Hasql

24import qualified Hasql.Statement as Hasql

22import qualified Hasql.Statement as Hasql

26−-- opaleye

24+-- pretty

27−import qualified Opaleye.Internal.Manipulation as Opaleye

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

29-- rel8

27-- rel8

30import Rel8.Expr ( Expr )

28import Rel8.Expr ( Expr )

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

29+import Rel8.Query ( Query )

32import Rel8.Schema.Name ( Selects )

30import Rel8.Schema.Name ( Selects )

33−import Rel8.Schema.Table ( TableSchema )

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

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

32+import Rel8.Statement.Returning ( Returning, decodeReturning, ppReturning )

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

33+import Rel8.Statement.Using ( ppUsing )

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

34+import Rel8.Statement.Where ( ppWhere )

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

39-- text

36-- text

40import qualified Data.Text as Text

37import qualified Data.Text as Text

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

47 Delete :: Selects names exprs =>

44 Delete :: Selects names exprs =>

48 { from :: TableSchema names

45 { from :: TableSchema names

49 -- ^ Which table to delete from.

46 -- ^ Which table to delete from.

47+ , using :: Query using

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

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

50− , deleteWhere :: exprs -> Expr Bool

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

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

52 , returning :: Returning names a

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

@@ -55,38 +55,25 @@ data Delete a where

55 -> Delete a

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

58+ppDelete :: Delete a -> Doc

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

59+ppDelete Delete {..} = case ppUsing using of

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

60+ Nothing ->

61− case returning of

61+ text "DELETE FROM" <+> ppTable from $$

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

62+ text "WHERE false"

63− where

63+ Just (usingDoc, i) ->

64− session = Hasql.statement () statement

64+ text "DELETE FROM" <+> ppTable from $$

65− statement = Hasql.Statement bytes params decode prepare

65+ usingDoc $$

66− bytes = encodeUtf8 $ Text.pack sql

66+ ppWhere from (deleteWhere i) $$

67− params = Hasql.noParams

67+ ppReturning from returning

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

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

69+

76− where

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

77− session = Hasql.statement () statement

71+delete :: Delete a -> Hasql.Statement () a

78− statement = Hasql.Statement bytes params decode prepare

72+delete d@Delete {returning} = Hasql.Statement bytes params decode prepare

79− bytes = encodeUtf8 $ Text.pack sql

80− params = Hasql.noParams

81− decode = decoder project

82− 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

73 where

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

74+ bytes = encodeUtf8 $ Text.pack sql

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

75+ params = Hasql.noParams

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

76+ decode = decodeReturning returning

77+ prepare = False

78+ sql = show doc

79+ doc = ppDelete d

src/Rel8/Statement/Insert.hs+43−72

@@ -1,64 +1,59 @@

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 #-}

8module Rel8.Statement.Insert

9module Rel8.Statement.Insert

9 ( Insert(..)

10 ( Insert(..)

10− , OnConflict(..)

11 , insert

12+ , ppInsert

13+ , ppInto

12 )

14 )

13where

15where

15-- base

17-- base

16−import Control.Exception ( throwIO )

18+import Data.Foldable ( toList )

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

18import Data.Kind ( Type )

19import Data.Kind ( Type )

19import Prelude

20import Prelude

21-- hasql

22-- hasql

22−import Hasql.Connection ( Connection )

23−import qualified Hasql.Decoders as Hasql

24import qualified Hasql.Encoders as Hasql

23import qualified Hasql.Encoders as Hasql

25−import qualified Hasql.Session as Hasql

26import qualified Hasql.Statement as Hasql

24import qualified Hasql.Statement as Hasql

28-- opaleye

26-- opaleye

29−import qualified Opaleye.Internal.Manipulation as Opaleye

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

30−import qualified Opaleye.Manipulation as Opaleye

28+

29+-- pretty

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

32-- rel8

33+import Rel8.Query ( Query )

33−import Rel8.Schema.Name ( Selects )

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

34−import Rel8.Schema.Table ( TableSchema )

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

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

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

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

37+import Rel8.Statement.Returning ( Returning, decodeReturning, ppReturning )

38+import Rel8.Statement.Select ( ppRows )

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

39+import Rel8.Table ( Table )

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

40+import Rel8.Table.Name ( showNames )

40-- text

42-- text

41import qualified Data.Text as Text ( pack )

43import qualified Data.Text as Text ( pack )

42import Data.Text.Encoding ( encodeUtf8 )

44import Data.Text.Encoding ( encodeUtf8 )

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.

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

54type Insert :: Type -> Type

48type Insert :: Type -> Type

55data Insert a where

49data Insert a where

56 Insert :: Selects names exprs =>

50 Insert :: Selects names exprs =>

57 { into :: TableSchema names

51 { into :: TableSchema names

58 -- ^ Which table to insert into.

52 -- ^ Which table to insert into.

59− , rows :: [exprs]

53+ , rows :: Query exprs

60− -- ^ The rows to insert.

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

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

61− , onConflict :: OnConflict

56+ , onConflict :: OnConflict names

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

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

63 -- table.

58 -- table.

64 , returning :: Returning names a

59 , returning :: Returning names a

@@ -67,52 +62,28 @@ data Insert a where

67 -> Insert a

62 -> Insert a

70−-- | Run an @INSERT@ statement

65+ppInsert :: Insert a -> Doc

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

66+ppInsert Insert {..} =

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

67+ text "INSERT INTO" <+>

73− case (rows, returning) of

68+ ppInto into $$

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

69+ ppRows rows $$

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

70+ ppOnConflict into onConflict $$

71+ ppReturning into returning

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

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

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

91− where

75+ppInto table@TableSchema {columns} =

92− session = Hasql.statement () statement

76+ ppTable table <+>

93− statement = Hasql.Statement bytes params decode prepare

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

94− bytes = encodeUtf8 $ Text.pack sql

95− params = Hasql.noParams

96− decode = decoder project

97− 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

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

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

81+insert :: Insert a -> Hasql.Statement () a

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

82+insert i@Insert {returning} = Hasql.Statement bytes params decode prepare

83+ where

84+ bytes = encodeUtf8 $ Text.pack sql

85+ params = Hasql.noParams

86+ decode = decodeReturning returning

87+ prepare = False

88+ sql = show doc

89+ doc = ppInsert i

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 #-}

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+114−10

@@ -1,29 +1,133 @@

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 #-}

4module Rel8.Statement.Returning

10module Rel8.Statement.Returning

5− ( Returning(..)

11+ ( Returning( NumberOfRowsAffected, Projection )

12+ , decodeReturning

13+ , ppReturning

6 )

14 )

7where

15where

9-- base

17-- base

18+import Control.Applicative ( liftA2 )

19+import Data.Foldable ( toList )

10import Data.Int ( Int64 )

20import Data.Int ( Int64 )

11import Data.Kind ( Type )

21import Data.Kind ( Type )

22+import Data.List.NonEmpty ( NonEmpty )

12−import Prelude ()

23+import Prelude

24+

25+-- hasql

26+import qualified Hasql.Decoders as Hasql

27+

28+-- opaleye

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

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

31+import qualified Opaleye.Internal.Sql as Opaleye

32+

33+-- pretty

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

14-- rel8

36-- rel8

15import Rel8.Schema.Name ( Selects )

37import Rel8.Schema.Name ( Selects )

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

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

16−import Rel8.Table.Serialize ( Serializable )

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

42+-- semigropuoids

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

45+

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

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

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

47+-- 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

48type Returning :: Type -> Type -> Type

25data Returning names a where

49data Returning names a where

50+ Pure :: a -> Returning names a

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

52+

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

26 NumberOfRowsAffected :: Returning names Int64

54 NumberOfRowsAffected :: Returning names Int64

55+

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

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

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

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

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

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

28− => (exprs -> projection)

61+ => (exprs -> returning)

29 -> Returning names [a]

62 -> Returning names [a]

63+

64+

65+instance Functor (Returning names) where

66+ fmap f = \case

67+ Pure a -> Pure (f a)

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

69+ m -> Ap (Pure f) m

70+

71+

72+instance Apply (Returning names) where

73+ (<.>) = Ap

74+

75+

76+instance Applicative (Returning names) where

77+ pure = Pure

78+ (<*>) = Ap

79+

80+

81+projections :: ()

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

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

84+ Pure _ -> Nothing

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

86+ NumberOfRowsAffected -> Nothing

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

88+

89+

90+runReturning :: ()

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

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

93+ -> Returning names a

94+ -> r

95+runReturning rowCount rowList = \case

96+ Pure a -> rowCount (const a)

97+ Ap fs as ->

98+ runReturning

99+ (\withCount ->

100+ runReturning

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

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

103+ as)

104+ (\decoder withRows ->

105+ runReturning

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

107+ (\decoder' withRows' ->

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

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

110+ as)

111+ fs

112+ NumberOfRowsAffected -> rowCount id

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

114+ where

115+ decoder' = parse @returning

116+ where

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

118+ length64 = fromIntegral . length

119+

120+

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

122+decodeReturning = runReturning

123+ (<$> Hasql.rowsAffected)

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

125+

126+

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

128+ppReturning schema returning = case projections schema returning of

129+ Nothing -> mempty

130+ Just columns ->

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

132+ where

133+ 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

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 = show . ppDelete

20+

21+

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

23+showInsert :: Insert a -> String

24+showInsert = show . ppInsert

25+

26+

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

28+showUpdate :: Update a -> String

29+showUpdate = show . ppUpdate

src/Rel8/Statement/Select.hs+120−35

@@ -1,62 +1,147 @@

1+{-# language DeriveTraversable #-}

2+{-# language DerivingStrategies #-}

3+{-# language FlexibleContexts #-}

1{-# language MonoLocalBinds #-}

4{-# language MonoLocalBinds #-}

2{-# language ScopedTypeVariables #-}

5{-# language ScopedTypeVariables #-}

6+{-# language StandaloneKindSignatures #-}

3{-# language TypeApplications #-}

7{-# language TypeApplications #-}

5module Rel8.Statement.Select

9module Rel8.Statement.Select

6 ( select

10 ( select

7− , selectWithNames

11+ , ppSelect

12+

13+ , Optimized(..)

14+ , ppPrimSelect

15+ , ppRows

8 )

16 )

9where

17where

11-- base

19-- base

12−import Control.Exception ( throwIO )

20+import Data.Foldable ( toList )

21+import Data.Kind ( Type )

22+import Data.Void ( Void )

13−import Prelude

23+import Prelude hiding ( undefined )

15-- hasql

25-- hasql

16−import Hasql.Connection ( Connection )

17import qualified Hasql.Decoders as Hasql

26import qualified Hasql.Decoders as Hasql

18import qualified Hasql.Encoders as Hasql

27import qualified Hasql.Encoders as Hasql

19−import qualified Hasql.Session as Hasql

20import qualified Hasql.Statement as Hasql

28import qualified Hasql.Statement as Hasql

30+-- opaleye

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

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

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

34+import qualified Opaleye.Internal.PrimQuery as Opaleye

35+import qualified Opaleye.Internal.Print as Opaleye

36+import qualified Opaleye.Internal.Optimize as Opaleye

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

38+import qualified Opaleye.Internal.Sql as Opaleye hiding ( Values )

39+import qualified Opaleye.Internal.Tag as Opaleye

40+

41+-- pretty

42+import Text.PrettyPrint ( Doc )

43+

22-- rel8

44-- rel8

45+import Rel8.Expr ( Expr )

46+import Rel8.Expr.Bool ( false )

47+import Rel8.Expr.Opaleye ( toPrimExpr )

23import Rel8.Query ( Query )

48import Rel8.Query ( Query )

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

49+import Rel8.Query.Opaleye ( toOpaleye )

25import Rel8.Schema.Name ( Selects )

50import Rel8.Schema.Name ( Selects )

51+import Rel8.Table ( Table )

52+import Rel8.Table.Cols ( toCols )

53+import Rel8.Table.Name ( namesFromLabels )

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

55+import qualified Rel8.Table.Opaleye as T

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

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

57+import Rel8.Table.Undefined ( undefined )

28-- text

59-- text

29import qualified Data.Text as Text

60import qualified Data.Text as Text

30import Data.Text.Encoding ( encodeUtf8 )

61import Data.Text.Encoding ( encodeUtf8 )

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

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

34select :: forall exprs a. Serializable exprs a

65select :: forall exprs a. Serializable exprs a

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

66+ => Query exprs -> Hasql.Statement () [a]

36−select c query = case sqlForQuery query of

67+select query = Hasql.Statement bytes params decode prepare

37− Nothing -> pure []

68+ where

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

69+ bytes = encodeUtf8 (Text.pack sql)

39− where

70+ params = Hasql.noParams

40− session = Hasql.statement () statement

71+ decode = Hasql.rowList (parse @exprs @a)

41− statement = Hasql.Statement bytes params decode prepare

72+ prepare = False

42− bytes = encodeUtf8 (Text.pack sql)

73+ sql = show doc

43− params = Hasql.noParams

74+ doc = ppSelect query

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

75+

45− prepare = False

76+

46−

77+ppSelect :: Table Expr a => Query a -> Doc

47−

78+ppSelect query =

48−selectWithNames :: forall exprs a names.

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

80+ where

81+ names = namesFromLabels

82+ (exprs, primQuery, _) =

83+ Opaleye.runSimpleQueryArrStart (toOpaleye query) ()

84+ (exprs', primQuery') = case optimize primQuery of

85+ Empty -> (undefined, Opaleye.Product (pure (pure Opaleye.Unit)) never)

86+ Unit -> (exprs, Opaleye.Unit)

87+ Optimized pq -> (exprs, pq)

88+ never = pure (toPrimExpr false)

89+

90+

91+ppRows :: Table Expr a => Query a -> Doc

92+ppRows query = case optimize primQuery of

93+ -- Special case VALUES because we can't use DEFAULT inside a SELECT

94+ Optimized (Opaleye.Values symbols rows)

95+ | eqSymbols symbols (toList (T.exprs a)) ->

96+ Opaleye.ppValues_ (map Opaleye.sqlExpr <$> toList rows)

97+ _ -> ppSelect query

98+ where

99+ (a, primQuery, _) = Opaleye.runSimpleQueryArrStart (toOpaleye query) ()

100+

101+ eqSymbols (symbol : symbols) (Opaleye.AttrExpr symbol' : exprs)

102+ | eqSymbol symbol symbol' = eqSymbols symbols exprs

103+ | otherwise = False

104+ eqSymbols [] [] = True

105+ eqSymbols _ _ = False

106+

107+ eqSymbol

108+ (Opaleye.Symbol name (Opaleye.UnsafeTag tag))

109+ (Opaleye.Symbol name' (Opaleye.UnsafeTag tag'))

110+ = name == name' && tag == tag'

111+

112+

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

114+ppPrimSelect query =

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

116+ where

117+ (a, primQuery, _) = Opaleye.runSimpleQueryArrStart (toOpaleye query) ()

118+

119+

120+type Optimized :: Type -> Type

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

122+ deriving stock (Functor, Foldable, Traversable, Show)

123+

124+

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

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

127+ Nothing -> Empty

128+ Just Opaleye.Unit -> Unit

129+ Just query' -> Optimized query'

130+

131+

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

133+primSelect = Opaleye.foldPrimQuery Opaleye.sqlQueryGenerator

134+

135+

49− ( Selects names exprs

136+primSelectWith :: Selects names exprs

50− , Serializable exprs a

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

51− )

138+primSelectWith names exprs query =

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

139+ Opaleye.SelectFrom $ Opaleye.newSelect

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

140+ { Opaleye.attrs = Opaleye.SelectAttrs attrs

54− Nothing -> pure []

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

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

142+ }

56− where

143+ where

57− session = Hasql.statement () statement

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

58− statement = Hasql.Statement bytes params decode prepare

145+ where

59− bytes = encodeUtf8 (Text.pack sql)

146+ makeAttr (label, expr) =

60− params = Hasql.noParams

147+ (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 #-}

4+module Rel8.Statement.Set

5+ ( ppSet

6+ )

7+where

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−56

@@ -1,39 +1,37 @@

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 #-}

7module Rel8.Statement.Update

8module Rel8.Statement.Update

8 ( Update(..)

9 ( Update(..)

9 , update

10 , update

11+ , ppUpdate

10 )

12 )

11where

13where

13-- base

15-- base

14−import Control.Exception ( throwIO )

15import Data.Kind ( Type )

16import Data.Kind ( Type )

16import Prelude

17import Prelude

18-- hasql

19-- hasql

19−import Hasql.Connection ( Connection )

20−import qualified Hasql.Decoders as Hasql

21import qualified Hasql.Encoders as Hasql

20import qualified Hasql.Encoders as Hasql

22−import qualified Hasql.Session as Hasql

23import qualified Hasql.Statement as Hasql

21import qualified Hasql.Statement as Hasql

25−-- opaleye

23+-- pretty

26−import qualified Opaleye.Internal.Manipulation as Opaleye

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

28-- rel8

26-- rel8

29import Rel8.Expr ( Expr )

27import Rel8.Expr ( Expr )

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

28+import Rel8.Query ( Query )

31import Rel8.Schema.Name ( Selects )

29import Rel8.Schema.Name ( Selects )

32−import Rel8.Schema.Table ( TableSchema )

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

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

31+import Rel8.Statement.Returning ( Returning, decodeReturning, ppReturning )

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

32+import Rel8.Statement.Set ( ppSet )

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

33+import Rel8.Statement.Using ( ppFrom )

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

34+import Rel8.Statement.Where ( ppWhere )

38-- text

36-- text

39import qualified Data.Text as Text

37import qualified Data.Text as Text

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

46 Update :: Selects names exprs =>

44 Update :: Selects names exprs =>

47 { target :: TableSchema names

45 { target :: TableSchema names

48 -- ^ Which table to update.

46 -- ^ Which table to update.

47+ , from :: Query from

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

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

49− , set :: exprs -> exprs

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

50 -- ^ How to update each selected row.

51 -- ^ How to update each selected row.

51− , updateWhere :: exprs -> Expr Bool

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

52 -- ^ Which rows to select for update.

53 -- ^ Which rows to select for update.

53 , returning :: Returning names a

54 , returning :: Returning names a

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

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

@@ -56,46 +57,27 @@ data Update a where

56 -> Update a

57 -> Update a

59−-- | Run an @UPDATE@ statement.

60+ppUpdate :: Update a -> Doc

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

61+ppUpdate Update {..} = case ppFrom from of

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

62+ Nothing ->

62− case returning of

63+ text "UPDATE" <+> ppTable target $$

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

64+ ppSet target id $$

64− where

65+ text "WHERE false"

65− session = Hasql.statement () statement

66+ Just (fromDoc, i) ->

66− statement = Hasql.Statement bytes params decode prepare

67+ text "UPDATE" <+> ppTable target $$

67− bytes = encodeUtf8 $ Text.pack sql

68+ ppSet target (set i) $$

68− params = Hasql.noParams

69+ fromDoc $$

69− decode = Hasql.rowsAffected

70+ ppWhere target (updateWhere i) $$

70− prepare = False

71+ ppReturning target returning

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

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

74+-- | Run an @UPDATE@ statement.

75+update :: Update a -> Hasql.Statement () a

76+update u@Update {returning} = Hasql.Statement bytes params decode prepare

98 where

77 where

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

78+ bytes = encodeUtf8 $ Text.pack sql

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

79+ params = Hasql.noParams

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

80+ decode = decodeReturning returning

81+ prepare = False

82+ sql = show doc

83+ doc = ppUpdate u

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

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

1+module Rel8.Statement.Using

2+ ( ppFrom

3+ , ppUsing

4+ )

5+where

7+-- base

8+import Prelude

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+43−28

@@ -3,61 +3,76 @@

4module Rel8.Statement.View

5 ( createView

6+ , createOrReplaceView

6 )

7 )

7where

8where

9-- base

10-- base

10−import Control.Exception ( throwIO )

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

12−import Data.Foldable ( fold )

13−import Data.Maybe ( fromMaybe )

14import Prelude

11import Prelude

16-- hasql

13-- hasql

17−import Hasql.Connection ( Connection )

18import qualified Hasql.Decoders as Hasql

14import qualified Hasql.Decoders as Hasql

19import qualified Hasql.Encoders as Hasql

15import qualified Hasql.Encoders as Hasql

20−import qualified Hasql.Session as Hasql

21import qualified Hasql.Statement as Hasql

16import qualified Hasql.Statement as Hasql

23-- rel8

18-- rel8

24import Rel8.Query ( Query )

19import Rel8.Query ( Query )

25−import Rel8.Query.SQL ( sqlForQueryWithNames )

26import Rel8.Schema.Name ( Selects )

20import Rel8.Schema.Name ( Selects )

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

21+import Rel8.Schema.Table ( TableSchema )

28−import Rel8.Table.Alternative ( emptyTable )

22+import Rel8.Statement.Insert ( ppInto )

23+import Rel8.Statement.Select ( ppSelect )

24+

25+-- pretty

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

30-- text

28-- text

31import qualified Data.Text as Text

29import qualified Data.Text as Text

32import Data.Text.Encoding ( encodeUtf8 )

30import Data.Text.Encoding ( encodeUtf8 )

33+data CreateView = Create | CreateOrReplace

34+

35+

35-- | Given a 'TableSchema' and 'Query', @createView@ runs a @CREATE VIEW@

36-- | Given a 'TableSchema' and 'Query', @createView@ runs a @CREATE VIEW@

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

37-- 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.

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

38createView :: Selects names exprs

39createView :: Selects names exprs

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

40+ => TableSchema names -> Query exprs -> Hasql.Statement () ()

40−createView (TableSchema name mschema names) query =

41+createView =

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

42+ createViewGeneric Create

43+

44+

45+-- | Given a 'TableSchema' and 'Query', @createOrReplaceView@ runs a

46+-- @CREATE OR REPLACE VIEW@ statement that will save the given query

47+-- as a view, replacing the current view definition if it exists and

48+-- adheres to the restrictions in place for replacing a view in

49+-- PostgreSQL.

50+createOrReplaceView :: Selects names exprs

51+ => TableSchema names -> Query exprs -> Hasql.Statement () ()

52+createOrReplaceView =

53+ createViewGeneric CreateOrReplace

54+

55+

56+createViewGeneric :: Selects names exprs

57+ => CreateView -> TableSchema names -> Query exprs -> Hasql.Statement () ()

58+createViewGeneric replace schema query =

59+ Hasql.Statement bytes params decode prepare

42 where

60 where

43− session = Hasql.statement () statement

44− statement = Hasql.Statement bytes params decode prepare

45 bytes = encodeUtf8 (Text.pack sql)

61 bytes = encodeUtf8 (Text.pack sql)

46 params = Hasql.noParams

62 params = Hasql.noParams

47 decode = Hasql.noResult

63 decode = Hasql.noResult

48 prepare = False

64 prepare = False

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

65+ sql = show doc

50− where

66+ doc = ppCreateView schema query replace

51− title = case mschema of

67+

52− Nothing -> quote name

68+

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

69+ppCreateView :: Selects names exprs

54− select = fromMaybe fallback $ sqlForQueryWithNames names query

70+ => TableSchema names -> Query exprs -> CreateView -> Doc

55− where

71+ppCreateView schema query replace =

56− fallback = fold $ sqlForQueryWithNames names emptyTable

72+ createOrReplace replace <+>

57−

73+ ppInto schema $$

58−

74+ text "AS" <+>

59−quote :: String -> String

75+ ppSelect query

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

61 where

76 where

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

77+ createOrReplace Create = text "CREATE VIEW"

63− go c = [c]

78+ createOrReplace CreateOrReplace = text "CREATE OR REPLACE VIEW"

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

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

1+{-# language MonoLocalBinds #-}

3+module Rel8.Statement.Where

4+ ( ppWhere

5+ )

6+where

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/Aggregate.hs+12

@@ -37,6 +37,18 @@ import Rel8.Type.Eq ( DBEq )

38-- | Group equal tables together. This works by aggregating each column in the

39-- given table with 'groupByExpr'.

40+--

41+-- For example, if we have a table of items, we could group the items by the

42+-- order they belong to:

43+--

44+-- @

45+-- itemsByOrder :: Query (OrderId Expr, ListTable Expr (Item Expr))

46+-- itemsByOrder = aggregate $ do

47+-- item <- each itemSchema

48+-- let orderId = groupBy (itemOrderId item)

49+-- let orderItems = listAgg item

50+-- pure (orderId, orderItems)

51+-- @

40groupBy :: forall exprs aggregates. (EqTable exprs, Aggregates aggregates exprs)

52groupBy :: forall exprs aggregates. (EqTable exprs, Aggregates aggregates exprs)

41 => exprs -> aggregates

53 => exprs -> aggregates

42groupBy = fromColumns . hgroupBy (eqTable @exprs) . toColumns

54groupBy = fromColumns . hgroupBy (eqTable @exprs) . toColumns

src/Rel8/Table/Either.hs+10

@@ -54,6 +54,7 @@ import Rel8.Table.Bool ( bool )

54import Rel8.Table.Eq ( EqTable, eqTable )

55import Rel8.Table.Nullify ( Nullify, aggregateNullify, guard )

56import Rel8.Table.Ord ( OrdTable, ordTable )

57+import Rel8.Table.Projection ( Biprojectable, Projectable, biproject, project )

57import Rel8.Table.Serialize ( ToExprs )

58import Rel8.Table.Serialize ( ToExprs )

58import Rel8.Table.Undefined ( undefined )

59import Rel8.Table.Undefined ( undefined )

59import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ), isLeft, isRight )

60import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ), isLeft, isRight )

@@ -78,10 +79,19 @@ data EitherTable context a b = EitherTable

78 deriving stock Functor

79 deriving stock Functor

82+instance Biprojectable (EitherTable context) where

83+ biproject f g (EitherTable tag a b) =

84+ EitherTable tag (project f a) (project g b)

85+

86+

81instance Nullifiable context => Bifunctor (EitherTable context) where

87instance Nullifiable context => Bifunctor (EitherTable context) where

82 bimap f g (EitherTable tag a b) = EitherTable tag (fmap f a) (fmap g b)

88 bimap f g (EitherTable tag a b) = EitherTable tag (fmap f a) (fmap g b)

91+instance Projectable (EitherTable context a) where

92+ project f (EitherTable tag a b) = EitherTable tag a (project f b)

93+

94+

85instance (context ~ Expr, Table Expr a) => Apply (EitherTable context a) where

95instance (context ~ Expr, Table Expr a) => Apply (EitherTable context a) where

86 EitherTable tag l1 f <.> EitherTable tag' l2 a =

96 EitherTable tag l1 f <.> EitherTable tag' l2 a =

87 EitherTable (tag <> tag') (bool l1 l2 (isLeft tag)) (f <.> a)

97 EitherTable (tag <> tag') (bool l1 l2 (isLeft tag)) (f <.> a)

src/Rel8/Table/HKD.hs+1

@@ -157,6 +157,7 @@ instance

157 => HKDable a

158

159

160+type Top_ :: Constraint

160class Top_

161class Top_

161instance Top_

162instance Top_

162

163

src/Rel8/Table/List.hs+22−2

@@ -11,7 +11,9 @@

12module Rel8.Table.List

13 ( ListTable(..)

14+ , ($*)

15+ , listTable

14− , listTable, nameListTable

16+ , nameListTable

15 )

17 )

16where

18where

@@ -25,7 +27,11 @@ import Rel8.Expr ( Expr )

25import Rel8.Expr.Array ( sappend, sempty, slistOf )

27import Rel8.Expr.Array ( sappend, sempty, slistOf )

26import Rel8.Schema.Dict ( Dict( Dict ) )

28import Rel8.Schema.Dict ( Dict( Dict ) )

27import Rel8.Schema.HTable.List ( HListTable )

29import Rel8.Schema.HTable.List ( HListTable )

28−import Rel8.Schema.HTable.Vectorize ( happend, hempty, hvectorize, hunvectorize )

30+import Rel8.Schema.HTable.Vectorize

31+ ( hvectorize, hunvectorize

32+ , happend, hempty

33+ , hproject, hcolumn

34+ )

29import qualified Rel8.Schema.Kind as K

35import qualified Rel8.Schema.Kind as K

30import Rel8.Schema.Name ( Name( Name ) )

36import Rel8.Schema.Name ( Name( Name ) )

31import Rel8.Schema.Null ( Nullity( Null, NotNull ) )

37import Rel8.Schema.Null ( Nullity( Null, NotNull ) )

@@ -42,6 +48,9 @@ import Rel8.Table.Alternative

42 )

48 )

43import Rel8.Table.Eq ( EqTable, eqTable )

49import Rel8.Table.Eq ( EqTable, eqTable )

44import Rel8.Table.Ord ( OrdTable, ordTable )

50import Rel8.Table.Ord ( OrdTable, ordTable )

51+import Rel8.Table.Projection

52+ ( Projectable, Projecting, Projection, project, apply

53+ )

45import Rel8.Table.Serialize ( ToExprs )

54import Rel8.Table.Serialize ( ToExprs )

@@ -52,6 +61,10 @@ newtype ListTable context a =

52 ListTable (HListTable (Columns a) (Context a))

61 ListTable (HListTable (Columns a) (Context a))

64+instance Projectable (ListTable context) where

65+ project f (ListTable a) = ListTable (hproject (apply f) a)

66+

67+

55instance (Table context a, context ~ context') =>

68instance (Table context a, context ~ context') =>

56 Table context' (ListTable context a)

69 Table context' (ListTable context a)

57 where

70 where

@@ -107,6 +120,13 @@ instance (context ~ Expr, Table Expr a) =>

107 mempty = ListTable $ hempty $ \Spec {info} -> sempty info

120 mempty = ListTable $ hempty $ \Spec {info} -> sempty info

108

121

109

122

123+-- | Project a single expression out of a 'ListTable'.

124+($*) :: Projecting a (Expr b)

125+ => Projection a (Expr b) -> ListTable Expr a -> Expr [b]

126+f $* ListTable a = hcolumn $ hproject (apply f) a

127+infixl 4 $*

128+

129+

110-- | Construct a @ListTable@ from a list of expressions.

130-- | Construct a @ListTable@ from a list of expressions.

111listTable :: Table Expr a => [a] -> ListTable Expr a

131listTable :: Table Expr a => [a] -> ListTable Expr a

112listTable =

132listTable =

src/Rel8/Table/Maybe.hs+11

@@ -15,6 +15,7 @@ module Rel8.Table.Maybe

15 ( MaybeTable(..)

16 , maybeTable, nothingTable, justTable

17 , isNothingTable, isJustTable

18+ , fromMaybeTable

18 , ($?)

19 , ($?)

19 , aggregateMaybeTable

20 , aggregateMaybeTable

20 , nameMaybeTable

21 , nameMaybeTable

@@ -58,6 +59,7 @@ import Rel8.Table.Alternative

58import Rel8.Table.Bool ( bool )

59import Rel8.Table.Bool ( bool )

59import Rel8.Table.Eq ( EqTable, eqTable )

60import Rel8.Table.Eq ( EqTable, eqTable )

60import Rel8.Table.Ord ( OrdTable, ordTable )

61import Rel8.Table.Ord ( OrdTable, ordTable )

62+import Rel8.Table.Projection ( Projectable, project )

61import Rel8.Table.Nullify ( Nullify, aggregateNullify, guard )

63import Rel8.Table.Nullify ( Nullify, aggregateNullify, guard )

62import Rel8.Table.Serialize ( ToExprs )

64import Rel8.Table.Serialize ( ToExprs )

63import Rel8.Table.Undefined ( undefined )

65import Rel8.Table.Undefined ( undefined )

@@ -85,6 +87,10 @@ data MaybeTable context a = MaybeTable

85 deriving stock Functor

87 deriving stock Functor

90+instance Projectable (MaybeTable context) where

91+ project f (MaybeTable tag a) = MaybeTable tag (project f a)

92+

93+

88instance context ~ Expr => Apply (MaybeTable context) where

94instance context ~ Expr => Apply (MaybeTable context) where

89 MaybeTable tag f <.> MaybeTable tag' a = MaybeTable (tag <> tag') (f <.> a)

95 MaybeTable tag f <.> MaybeTable tag' a = MaybeTable (tag <> tag') (f <.> a)

@@ -201,6 +207,11 @@ justTable :: a -> MaybeTable Expr a

201justTable = MaybeTable mempty . pure

207justTable = MaybeTable mempty . pure

202

208

203

209

210+-- | 'Data.Maybe.fromMaybe' for 'MaybeTable's.

211+fromMaybeTable :: Table Expr a => a -> MaybeTable Expr a -> a

212+fromMaybeTable fallback = maybeTable fallback id

213+

214+

204-- | Project a single expression out of a 'MaybeTable'. You can think of this

215-- | Project a single expression out of a 'MaybeTable'. You can think of this

205-- operator like the '$' operator, but it also has the ability to return

216-- operator like the '$' operator, but it also has the ability to return

206-- @null@.

217-- @null@.

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

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 ) )

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))

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))

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)

92renderLabels :: [String] -> NonEmpty String

78renderLabels :: [String] -> NonEmpty String

src/Rel8/Table/NonEmpty.hs+22−2

@@ -11,7 +11,9 @@

12module Rel8.Table.NonEmpty

13 ( NonEmptyTable(..)

14+ , ($+)

15+ , nonEmptyTable

14− , nonEmptyTable, nameNonEmptyTable

16+ , nameNonEmptyTable

15 )

17 )

16where

18where

@@ -26,7 +28,11 @@ import Rel8.Expr ( Expr )

26import Rel8.Expr.Array ( sappend1, snonEmptyOf )

28import Rel8.Expr.Array ( sappend1, snonEmptyOf )

27import Rel8.Schema.Dict ( Dict( Dict ) )

29import Rel8.Schema.Dict ( Dict( Dict ) )

28import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable )

30import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable )

29−import Rel8.Schema.HTable.Vectorize ( happend, hvectorize, hunvectorize )

31+import Rel8.Schema.HTable.Vectorize

32+ ( hvectorize, hunvectorize

33+ , happend

34+ , hproject, hcolumn

35+ )

30import qualified Rel8.Schema.Kind as K

36import qualified Rel8.Schema.Kind as K

31import Rel8.Schema.Name ( Name( Name ) )

37import Rel8.Schema.Name ( Name( Name ) )

32import Rel8.Schema.Null ( Nullity( Null, NotNull ) )

38import Rel8.Schema.Null ( Nullity( Null, NotNull ) )

@@ -40,6 +46,9 @@ import Rel8.Table

40import Rel8.Table.Alternative ( AltTable, (<|>:) )

46import Rel8.Table.Alternative ( AltTable, (<|>:) )

41import Rel8.Table.Eq ( EqTable, eqTable )

47import Rel8.Table.Eq ( EqTable, eqTable )

42import Rel8.Table.Ord ( OrdTable, ordTable )

48import Rel8.Table.Ord ( OrdTable, ordTable )

49+import Rel8.Table.Projection

50+ ( Projectable, Projecting, Projection, project, apply

51+ )

43import Rel8.Table.Serialize ( ToExprs )

52import Rel8.Table.Serialize ( ToExprs )

@@ -50,6 +59,10 @@ newtype NonEmptyTable context a =

50 NonEmptyTable (HNonEmptyTable (Columns a) (Context a))

59 NonEmptyTable (HNonEmptyTable (Columns a) (Context a))

62+instance Projectable (NonEmptyTable context) where

63+ project f (NonEmptyTable a) = NonEmptyTable (hproject (apply f) a)

64+

65+

53instance (Table context a, context ~ context') =>

66instance (Table context a, context ~ context') =>

54 Table context' (NonEmptyTable context a)

67 Table context' (NonEmptyTable context a)

55 where

68 where

@@ -101,6 +114,13 @@ instance (Table Expr a, context ~ Expr) => Semigroup (NonEmptyTable context a)

101 happend (const sappend1) as bs

114 happend (const sappend1) as bs

102

115

103

116

117+-- | Project a single expression out of a 'NonEmptyTable'.

118+($+) :: Projecting a (Expr b)

119+ => Projection a (Expr b) -> NonEmptyTable Expr a -> Expr (NonEmpty b)

120+f $+ NonEmptyTable a = hcolumn $ hproject (apply f) a

121+infixl 4 $+

122+

123+

104-- | Construct a @NonEmptyTable@ from a non-empty list of expressions.

124-- | Construct a @NonEmptyTable@ from a non-empty list of expressions.

105nonEmptyTable :: Table Expr a => NonEmpty a -> NonEmptyTable Expr a

125nonEmptyTable :: Table Expr a => NonEmpty a -> NonEmptyTable Expr a

106nonEmptyTable =

126nonEmptyTable =

src/Rel8/Table/Null.hsnew file+147

@@ -0,0 +1,147 @@

1+{-# language DataKinds #-}

2+{-# language FlexibleContexts #-}

3+{-# language FlexibleInstances #-}

4+{-# language MultiParamTypeClasses #-}

5+{-# language ScopedTypeVariables #-}

6+{-# language StandaloneKindSignatures #-}

7+{-# language TypeApplications #-}

8+{-# language TypeFamilies #-}

9+{-# language UndecidableInstances #-}

10+

11+module Rel8.Table.Null

12+ ( NullTable(..)

13+ , nullableTable, nullTable, nullifyTable, unsafeUnnullifyTable

14+ , isNullTable, isNonNullTable

15+ , nameNullTable

16+ , toMaybeTable, toNullTable

17+ )

18+where

19+

20+-- base

21+import Data.Kind ( Type )

22+import Prelude hiding ( null, undefined )

23+

24+-- comonad

25+import Control.Comonad ( extract )

26+

27+-- rel8

28+import Rel8.Expr ( Expr )

29+import Rel8.Expr.Bool ( not_ )

30+import Rel8.Kind.Context ( Reifiable )

31+import qualified Rel8.Schema.Kind as K

32+import Rel8.Schema.Name ( Name )

33+import Rel8.Table

34+ ( Table, Columns, Context, fromColumns, toColumns

35+ , FromExprs, fromResult, toResult

36+ , Transpose

37+ )

38+import Rel8.Table.Alternative

39+ ( AltTable, (<|>:)

40+ , AlternativeTable, emptyTable

41+ )

42+import Rel8.Table.Bool ( bool )

43+import Rel8.Table.Eq ( EqTable, eqTable )

44+import Rel8.Table.Maybe ( MaybeTable, justTable, maybeTable, nothingTable )

45+import Rel8.Table.Nullify ( Nullify, isNull )

46+import Rel8.Table.Ord ( OrdTable, ordTable )

47+import Rel8.Table.Projection ( Projectable, project )

48+import Rel8.Table.Serialize ( ToExprs )

49+import Rel8.Table.Undefined ( undefined )

50+

51+

52+-- | @NullTable t@ is the table @t@, but where all the columns in @t@ have the

53+-- possibility of being 'Rel8.null'. This is very similar to

54+-- 'Rel8.MaybeTable', except that it does not use an extra tag field, so it

55+-- cannot distinguish between @Nothing@ and @Just Nothing@ if nested. In other

56+-- words, if all of the columns of the @t@ passed to @NullTable@ are already

57+-- nullable, then @NullTable@ has no effect.

58+type NullTable :: K.Context -> Type -> Type

59+newtype NullTable context a = NullTable (Nullify context a)

60+

61+

62+instance Projectable (NullTable context) where

63+ project f (NullTable a) = NullTable (project f a)

64+

65+

66+instance context ~ Expr => AltTable (NullTable context) where

67+ ma <|>: mb = bool ma mb (isNullTable ma)

68+

69+

70+instance context ~ Expr => AlternativeTable (NullTable context) where

71+ emptyTable = nullTable

72+

73+

74+instance (Table context a, Reifiable context, context ~ context') =>

75+ Table context' (NullTable context a)

76+ where

77+ type Columns (NullTable context a) = Columns (Nullify context a)

78+ type Context (NullTable context a) = Context (Nullify context a)

79+ type FromExprs (NullTable context a) = FromExprs (Nullify context a)

80+ type Transpose to (NullTable context a) = NullTable to (Transpose to a)

81+

82+ toColumns (NullTable a) = toColumns a

83+ fromColumns = NullTable . fromColumns

84+

85+ toResult = toResult @_ @(Nullify context a)

86+ fromResult = fromResult @_ @(Nullify context a)

87+

88+

89+instance (EqTable a, context ~ Expr) => EqTable (NullTable context a) where

90+ eqTable = eqTable @(Nullify context a)

91+

92+

93+instance (OrdTable a, context ~ Expr) => OrdTable (NullTable context a) where

94+ ordTable = ordTable @(Nullify context a)

95+

96+

97+instance (ToExprs exprs a, context ~ Expr) =>

98+ ToExprs (NullTable context exprs) (Maybe a)

99+

100+

101+-- | Check if any of the non-nullable fields of @a@ are 'Rel8.null' under the

102+-- 'NullTable'. Returns 'Rel8.false' if @a@ has no non-nullable fields.

103+isNullTable :: Table Expr a => NullTable Expr a -> Expr Bool

104+isNullTable (NullTable a) = isNull a

105+

106+

107+-- | The inverse of 'isNullTable'.

108+isNonNullTable :: Table Expr a => NullTable Expr a -> Expr Bool

109+isNonNullTable = not_ . isNullTable

110+

111+

112+-- | Like 'Rel8.nullable'.

113+nullableTable :: (Table Expr a, Table Expr b)

114+ => b -> (a -> b) -> NullTable Expr a -> b

115+nullableTable b f ma@(NullTable a) = bool (f (extract a)) b (isNullTable ma)

116+

117+

118+-- | The null table. Like 'Rel8.null'.

119+nullTable :: Table Expr a => NullTable Expr a

120+nullTable = NullTable (pure undefined)

121+

122+

123+-- | Lift any table into 'NullTable'. Like 'Rel8.nullify'.

124+nullifyTable :: a -> NullTable Expr a

125+nullifyTable = NullTable . pure

126+

127+

128+unsafeUnnullifyTable :: NullTable Expr a -> a

129+unsafeUnnullifyTable (NullTable a) = extract a

130+

131+

132+-- | Construct a 'NullTable' in the 'Name' context. This can be useful if you

133+-- have a 'NullTable' that you are storing in a table and need to construct a

134+-- 'TableSchema'.

135+nameNullTable :: a -> NullTable Name a

136+nameNullTable = NullTable . pure

137+

138+

139+-- | Convert a 'NullTable' to a 'MaybeTable'.

140+toMaybeTable :: Table Expr a => NullTable Expr a -> MaybeTable Expr a

141+toMaybeTable = nullableTable nothingTable justTable

142+

143+

144+-- | Convert a 'MaybeTable' to a 'NullTable'. Note that if the underlying @a@

145+-- has no non-nullable fields, this is a lossy conversion.

146+toNullTable :: Table Expr a => MaybeTable Expr a -> NullTable Expr a

147+toNullTable = maybeTable nullTable nullifyTable

src/Rel8/Table/Nullify.hs+39−1

@@ -1,7 +1,9 @@

1{-# language DataKinds #-}

2+{-# language FlexibleContexts #-}

2{-# language FlexibleInstances #-}

3{-# language FlexibleInstances #-}

3{-# language LambdaCase #-}

4{-# language LambdaCase #-}

4{-# language MultiParamTypeClasses #-}

5{-# language MultiParamTypeClasses #-}

6+{-# language NamedFieldPuns #-}

5{-# language ScopedTypeVariables #-}

7{-# language ScopedTypeVariables #-}

6{-# language StandaloneKindSignatures #-}

8{-# language StandaloneKindSignatures #-}

7{-# language TypeApplications #-}

9{-# language TypeApplications #-}

@@ -12,11 +14,13 @@ module Rel8.Table.Nullify

12 ( Nullify

14 ( Nullify

13 , aggregateNullify

15 , aggregateNullify

14 , guard

16 , guard

17+ , isNull

15 )

18 )

16where

19where

18-- base

21-- base

19import Control.Applicative ( liftA2 )

22import Control.Applicative ( liftA2 )

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

20import Data.Functor.Identity ( runIdentity )

24import Data.Functor.Identity ( runIdentity )

21import Data.Kind ( Type )

25import Data.Kind ( Type )

22import Prelude

26import Prelude

@@ -27,6 +31,8 @@ import Control.Comonad ( Comonad, duplicate, extract, ComonadApply, (<@>) )

27-- rel8

31-- rel8

28import Rel8.Aggregate ( Aggregate )

32import Rel8.Aggregate ( Aggregate )

29import Rel8.Expr ( Expr )

33import Rel8.Expr ( Expr )

34+import Rel8.Expr.Bool ( (||.), false )

35+import qualified Rel8.Expr.Null as Expr

30import Rel8.Kind.Context ( Reifiable, contextSing )

36import Rel8.Kind.Context ( Reifiable, contextSing )

31import Rel8.Schema.Context.Nullify

37import Rel8.Schema.Context.Nullify

32 ( Nullifiability( NAggregate, NExpr )

38 ( Nullifiability( NAggregate, NExpr )

@@ -39,16 +45,23 @@ import Rel8.Schema.Context.Nullify

39 )

45 )

40import Rel8.Schema.Dict ( Dict( Dict ) )

46import Rel8.Schema.Dict ( Dict( Dict ) )

41import Rel8.Schema.HTable ( HTable )

47import Rel8.Schema.HTable ( HTable )

48+import Rel8.Schema.HTable.Nullify

42−import Rel8.Schema.HTable.Nullify ( HNullify, hnulls, hnullify, hunnullify, hguard )

49+ ( HNullify, hnulls, hnullify, hunnullify

50+ , hguard

51+ , hproject

52+ )

43import qualified Rel8.Schema.Kind as K

53import qualified Rel8.Schema.Kind as K

54+import Rel8.Schema.Null ( Nullity( NotNull, Null ) )

44import qualified Rel8.Schema.Result as R

55import qualified Rel8.Schema.Result as R

45import Rel8.Table

56import Rel8.Table

46 ( Table, Columns, Context, toColumns, fromColumns

57 ( Table, Columns, Context, toColumns, fromColumns

47 , FromExprs, fromResult, toResult

58 , FromExprs, fromResult, toResult

48 , Transpose

59 , Transpose

49 )

60 )

61+import Rel8.Schema.Spec ( Spec( Spec, nullity ) )

50import Rel8.Table.Eq ( EqTable, eqTable )

62import Rel8.Table.Eq ( EqTable, eqTable )

51import Rel8.Table.Ord ( OrdTable, ordTable )

63import Rel8.Table.Ord ( OrdTable, ordTable )

64+import Rel8.Table.Projection ( Projectable, apply, project )

53-- semigroupoids

66-- semigroupoids

54import Data.Functor.Apply ( Apply, (<.>), liftF2 )

67import Data.Functor.Apply ( Apply, (<.>), liftF2 )

@@ -62,6 +75,12 @@ data Nullify context a

62 | Fields (NonNullifiability context) (HNullify (Columns a) (Context a))

75 | Fields (NonNullifiability context) (HNullify (Columns a) (Context a))

78+instance Projectable (Nullify context) where

79+ project f = \case

80+ Table nullifiable a -> Table nullifiable (fromColumns (apply f (toColumns a)))

81+ Fields nonNullifiable a -> Fields nonNullifiable (hproject (apply f) a)

82+

83+

65instance Nullifiable context => Functor (Nullify context) where

84instance Nullifiable context => Functor (Nullify context) where

66 fmap f = \case

85 fmap f = \case

67 Table nullifiable a -> Table nullifiable (f a)

86 Table nullifiable a -> Table nullifiable (f a)

@@ -171,3 +190,22 @@ guard :: (Reifiable context, HTable t)

171 -> HNullify t context

190 -> HNullify t context

172guard tag isNonNull isNonNullExpr =

191guard tag isNonNull isNonNullExpr =

173 hguard (guarder contextSing tag isNonNull isNonNullExpr)

192 hguard (guarder contextSing tag isNonNull isNonNullExpr)

193+

194+

195+isNull :: forall a. Table Expr a => Nullify Expr a -> Expr Bool

196+isNull =

197+ maybe false getAny .

198+ getConst .

199+ hunnullify (\Spec {nullity} a -> Const $ case nullity of

200+ NotNull -> Just $ Any $ Expr.isNull a

201+ Null -> Nothing) .

202+ toColumns

203+

204+

205+newtype Any = Any

206+ { getAny :: Expr Bool

207+ }

208+

209+

210+instance Semigroup Any where

211+ Any a <> Any b = Any (a ||. b)

src/Rel8/Table/Opaleye.hs+65−49

@@ -2,36 +2,41 @@

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 #-}

9{-# language ViewPatterns #-}

8{-# language ViewPatterns #-}

10+{-# options_ghc -Wno-deprecations #-}

11+

11module Rel8.Table.Opaleye

12module Rel8.Table.Opaleye

12 ( aggregator

13 ( aggregator

14+ , attributes

13 , binaryspec

15 , binaryspec

14 , distinctspec

16 , distinctspec

17+ , exprs

18+ , exprsWithNames

15 , table

19 , table

16 , tableFields

20 , tableFields

17 , unpackspec

21 , unpackspec

18 , valuesspec

22 , valuesspec

23+ , view

19 , castTable

24 , castTable

20 )

25 )

21where

26where

23-- base

28-- base

24−import Prelude hiding ( undefined )

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

30+import Data.List.NonEmpty ( NonEmpty )

31+import Prelude

26-- opaleye

33-- opaleye

34+import qualified Opaleye.Adaptors as Opaleye

35+import qualified Opaleye.Field as Opaleye ( Field_ )

27import qualified Opaleye.Internal.Aggregate as Opaleye

36import qualified Opaleye.Internal.Aggregate as Opaleye

28−import qualified Opaleye.Internal.Binary as Opaleye

29−import qualified Opaleye.Internal.Distinct as Opaleye

30import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye

37import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye

31−import qualified Opaleye.Internal.PackMap as Opaleye

32−import qualified Opaleye.Internal.Unpackspec as Opaleye

33import qualified Opaleye.Internal.Values as Opaleye

38import qualified Opaleye.Internal.Values as Opaleye

34−import qualified Opaleye.Internal.Table as Opaleye

39+import qualified Opaleye.Table as Opaleye

36-- profunctors

41-- profunctors

37import Data.Profunctor ( dimap, lmap )

42import Data.Profunctor ( dimap, lmap )

@@ -41,52 +46,68 @@ import Rel8.Aggregate ( Aggregate( Aggregate ), Aggregates )

41import Rel8.Expr ( Expr )

46import Rel8.Expr ( Expr )

42import Rel8.Expr.Opaleye

47import Rel8.Expr.Opaleye

43 ( fromPrimExpr, toPrimExpr

48 ( fromPrimExpr, toPrimExpr

44− , traversePrimExpr

45− , fromColumn, toColumn

46− , scastExpr

49+ , scastExpr, traverseFieldP

47 )

50 )

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

51+import Rel8.Schema.HTable ( htabulateA, hfield, hspecs, htabulate,

52+ htraverseP, htraversePWithField )

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

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

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

54import Rel8.Schema.Spec ( Spec(..) )

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

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

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

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

53−import Rel8.Table.Undefined ( undefined )

57+import Rel8.Type.Information ( typeName )

55-- semigroupoids

59-- semigroupoids

56import Data.Functor.Apply ( WrappedApplicative(..) )

60import Data.Functor.Apply ( WrappedApplicative(..) )

61+import Data.Profunctor.Product ( ProductProfunctor )

59aggregator :: Aggregates aggregates exprs => Opaleye.Aggregator aggregates exprs

64aggregator :: Aggregates aggregates exprs => Opaleye.Aggregator aggregates exprs

60−aggregator = Opaleye.Aggregator $ Opaleye.PackMap $ \f aggregates ->

65+aggregator = dimap toColumns fromColumns $

61− fmap fromColumns $ unwrapApplicative $ htabulateA $ \field ->

66+ htraverseP $

67+ lmap (\(Aggregate a) -> (a, ())) Opaleye.aggregatorApply

68+

69+

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

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

62− WrapApplicative $ case hfield (toColumns aggregates) field of

72+ case hfield (toColumns columns) field of

63− Aggregate (Opaleye.Aggregator (Opaleye.PackMap inner)) ->

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

64− inner f ()

74+ Opaleye.OtherLit $

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

76+

77+

78+fromOpaleyespec :: (ProductProfunctor p, Table Expr a)

79+ => p (Opaleye.Field_ n x) (Opaleye.Field_ n x)

80+ -> p a a

81+fromOpaleyespec x =

82+ dimap toColumns fromColumns (htraverseP (traverseFieldP x))

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

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

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

86+binaryspec = fromOpaleyespec Opaleye.binaryspecField

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

70− WrapApplicative $

71− case (hfield (toColumns as) field, hfield (toColumns bs) field) of

72− (a, b) -> fromPrimExpr <$> f (toPrimExpr a, toPrimExpr b)

75distinctspec :: Table Expr a => Opaleye.Distinctspec a a

89distinctspec :: Table Expr a => Opaleye.Distinctspec a a

76−distinctspec =

90+distinctspec = fromOpaleyespec Opaleye.distinctspecField

77− Opaleye.Distinctspec $ Opaleye.Aggregator $ Opaleye.PackMap $ \f ->

91+

78− fmap fromColumns .

92+

79− unwrapApplicative .

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

80− htraverse

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

81− (\a -> WrapApplicative $ fromPrimExpr <$> f (Nothing, toPrimExpr a)) .

95+ case hfield as field of

82− toColumns

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

97+

98+

99+exprsWithNames :: Selects names exprs

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

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

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

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

104

105

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

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

86table (TableSchema name schema columns) =

107table (TableSchema name schema columns) =

87 case schema of

108 case schema of

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

109+ Nothing -> Opaleye.table name (tableFields columns)

89− Just schemaName -> Opaleye.TableWithSchema schemaName name (tableFields columns)

110+ Just schemaName -> Opaleye.tableWithSchema schemaName name (tableFields columns)

111

112

92tableFields :: Selects names exprs

113tableFields :: Selects names exprs

@@ -98,30 +119,25 @@ tableFields (toColumns -> names) = dimap toColumns fromColumns $

98 where

119 where

99 go :: Name a -> Opaleye.TableFields (Expr a) (Expr a)

120 go :: Name a -> Opaleye.TableFields (Expr a) (Expr a)

100 go (Name name) =

121 go (Name name) =

101− dimap (toColumn . toPrimExpr) (fromPrimExpr . fromColumn) $

122+ traverseFieldP $

102 Opaleye.requiredTableField name

123 Opaleye.requiredTableField name

103

124

104

125

105unpackspec :: Table Expr a => Opaleye.Unpackspec a a

126unpackspec :: Table Expr a => Opaleye.Unpackspec a a

106−unpackspec = Opaleye.Unpackspec $ Opaleye.PackMap $ \f ->

127+unpackspec = fromOpaleyespec Opaleye.unpackspecField

107− fmap fromColumns .

108− unwrapApplicative .

109− htraverse (WrapApplicative . traversePrimExpr f) .

110− toColumns

111{-# INLINABLE unpackspec #-}

128{-# INLINABLE unpackspec #-}

112

129

113

130

114−valuesspec :: Table Expr a => Opaleye.ValuesspecSafe a a

131+valuesspec :: Table Expr a => Opaleye.Valuesspec a a

115−valuesspec = Opaleye.ValuesspecSafe (toPackMap undefined) unpackspec

132+valuesspec = dimap toColumns fromColumns $

133+ htraversePWithField (traverseFieldP . Opaleye.valuesspecFieldType . typeName)

134+ where typeName = Rel8.Type.Information.typeName . info . hfield hspecs

116

135

117

136

118−toPackMap :: Table Expr a

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

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

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

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

121− fmap fromColumns $

122− unwrapApplicative .

123− htraverse (WrapApplicative . traversePrimExpr f) $

124− toColumns as

139+ case hfield (toColumns columns) field of

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

125

141

126

142

127-- | Transform a table by adding 'CAST' to all columns. This is most useful for

143-- | Transform a table by adding 'CAST' to all columns. This is most useful for

src/Rel8/Table/Ord.hs+2−2

@@ -146,9 +146,9 @@ infix 4 >=:

146

147-- | Given two 'Table's, return the table that sorts before the other.

148least :: OrdTable a => a -> a -> a

149−least a b = bool a b (a <: b)

149+least a b = bool b a (a <: b)

150

151

152-- | Given two 'Table's, return the table that sorts after the other.

153greatest :: OrdTable a => a -> a -> a

154−greatest a b = bool a b (a >: b)

154+greatest a b = bool b a (a >: b)

src/Rel8/Table/Projection.hsnew file+73

@@ -0,0 +1,73 @@

1+{-# language FlexibleContexts #-}

2+{-# language FlexibleInstances #-}

3+{-# language MonoLocalBinds #-}

4+{-# language MultiParamTypeClasses #-}

5+{-# language StandaloneKindSignatures #-}

6+{-# language UndecidableInstances #-}

8+module Rel8.Table.Projection

9+ ( Projection

10+ , Projectable( project )

11+ , Biprojectable( biproject )

12+ , Projecting

13+ , apply

14+ )

15+where

16+

17+-- base

18+import Data.Kind ( Constraint, Type )

19+import Prelude

20+

21+-- rel8

22+import Rel8.Schema.Field ( Field( Field ), fields )

23+import Rel8.Schema.HTable ( hfield, htabulate )

24+import Rel8.Table ( Columns, Context, Transpose, toColumns )

25+import Rel8.Table.Transpose ( Transposes )

26+

27+

28+-- | The constraint @'Projecting' a b@ ensures that @'Projection' a b@ is a

29+-- usable 'Projection'.

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

31+class

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

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

34+ )

35+ => Projecting a b

36+instance

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

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

39+ )

40+ => Projecting a b

41+

42+

43+-- | A @'Projection' a b@s is a special type of function @a -> b@ whereby the

44+-- resulting @b@ is guaranteed to be composed only from columns contained in

45+-- @a@.

46+type Projection :: Type -> Type -> Type

47+type Projection a b = Transpose (Field a) a -> Transpose (Field a) b

48+

49+

50+-- | @'Projectable' f@ means that @f@ is a kind of functor on 'Rel8.Table's

51+-- that allows the mapping of a 'Projection' over its underlying columns.

52+type Projectable :: (Type -> Type) -> Constraint

53+class Projectable f where

54+ -- | Map a 'Projection' over @f@.

55+ project :: Projecting a b

56+ => Projection a b -> f a -> f b

57+

58+

59+-- | @'Biprojectable' p@ means that @p@ is a kind of bifunctor on

60+-- 'Rel8.Table's that allows the mapping of a pair of 'Projection's over its

61+-- underlying columns.

62+type Biprojectable :: (Type -> Type -> Type) -> Constraint

63+class Biprojectable p where

64+ -- | Map a pair of 'Projection's over @p@.

65+ biproject :: (Projecting a b, Projecting c d)

66+ => Projection a b -> Projection c d -> p a c -> p b d

67+

68+

69+apply :: Projecting a b

70+ => Projection a b -> Columns a context -> Columns b context

71+apply f a = case toColumns (f fields) of

72+ bs -> htabulate $ \field -> case hfield bs field of

73+ Field field' -> hfield a field'

src/Rel8/Table/These.hs+23−3

@@ -20,6 +20,7 @@ module Rel8.Table.These

20 , isThisTable, isThatTable, isThoseTable

21 , hasHereTable, hasThereTable

22 , justHereTable, justThereTable

23+ , alignMaybeTable

23 , aggregateTheseTable

24 , aggregateTheseTable

24 , nameTheseTable

25 , nameTheseTable

25 )

26 )

@@ -29,13 +30,13 @@ where

29import Data.Bifunctor ( Bifunctor, bimap )

30import Data.Bifunctor ( Bifunctor, bimap )

30import Data.Kind ( Type )

31import Data.Kind ( Type )

31import Data.Maybe ( isJust )

32import Data.Maybe ( isJust )

32−import Prelude hiding ( undefined )

33+import Prelude hiding ( null, undefined )

34-- rel8

35-- rel8

35import Rel8.Aggregate ( Aggregate )

36import Rel8.Aggregate ( Aggregate )

36import Rel8.Expr ( Expr )

37import Rel8.Expr ( Expr )

37−import Rel8.Expr.Bool ( (&&.), not_ )

38+import Rel8.Expr.Bool ( (&&.), (||.), boolExpr, not_ )

38−import Rel8.Expr.Null ( isNonNull )

39+import Rel8.Expr.Null ( null, isNonNull )

39import Rel8.Kind.Context ( Reifiable )

40import Rel8.Kind.Context ( Reifiable )

40import Rel8.Schema.Context.Nullify ( Nullifiable )

41import Rel8.Schema.Context.Nullify ( Nullifiable )

41import Rel8.Schema.Dict ( Dict( Dict ) )

42import Rel8.Schema.Dict ( Dict( Dict ) )

@@ -60,6 +61,7 @@ import Rel8.Table.Maybe

60 )

61 )

61import Rel8.Table.Nullify ( Nullify, guard )

62import Rel8.Table.Nullify ( Nullify, guard )

62import Rel8.Table.Ord ( OrdTable, ordTable )

63import Rel8.Table.Ord ( OrdTable, ordTable )

64+import Rel8.Table.Projection ( Biprojectable, Projectable, biproject, project )

63import Rel8.Table.Serialize ( ToExprs )

65import Rel8.Table.Serialize ( ToExprs )

64import Rel8.Table.Undefined ( undefined )

66import Rel8.Table.Undefined ( undefined )

65import Rel8.Type.Tag ( MaybeTag )

67import Rel8.Type.Tag ( MaybeTag )

@@ -88,10 +90,18 @@ data TheseTable context a b = TheseTable

88 deriving stock Functor

90 deriving stock Functor

93+instance Biprojectable (TheseTable context) where

94+ biproject f g (TheseTable a b) = TheseTable (project f a) (project g b)

95+

96+

91instance Nullifiable context => Bifunctor (TheseTable context) where

97instance Nullifiable context => Bifunctor (TheseTable context) where

92 bimap f g (TheseTable a b) = TheseTable (fmap f a) (fmap g b)

98 bimap f g (TheseTable a b) = TheseTable (fmap f a) (fmap g b)

100

101+instance Projectable (TheseTable context a) where

102+ project f (TheseTable a b) = TheseTable a (project f b)

103+

104+

95instance (context ~ Expr, Table Expr a, Semigroup a) =>

105instance (context ~ Expr, Table Expr a, Semigroup a) =>

96 Apply (TheseTable context a)

106 Apply (TheseTable context a)

97 where

107 where

@@ -279,6 +289,16 @@ justThereTable :: TheseTable context a b -> MaybeTable context b

279justThereTable = there

289justThereTable = there

280

290

281

291

292+-- | Construct a @TheseTable@ from two 'MaybeTable's.

293+alignMaybeTable :: ()

294+ => MaybeTable Expr a

295+ -> MaybeTable Expr b

296+ -> MaybeTable Expr (TheseTable Expr a b)

297+alignMaybeTable a b = MaybeTable tag (pure (TheseTable a b))

298+ where

299+ tag = boolExpr null mempty (isJustTable a ||. isJustTable b)

300+

301+

282-- | Construct a @TheseTable@. Corresponds to 'This'.

302-- | Construct a @TheseTable@. Corresponds to 'This'.

283thisTable :: Table Expr b => a -> TheseTable Expr a b

303thisTable :: Table Expr b => a -> TheseTable Expr a b

284thisTable a = TheseTable (justTable a) nothingTable

304thisTable a = TheseTable (justTable a) nothingTable

src/Rel8/Table/Window.hsnew file+43

@@ -0,0 +1,43 @@

1+{-# language MonoLocalBinds #-}

3+module Rel8.Table.Window

4+ ( cumulative

5+ , cumulative_

6+ , currentRow

7+ )

8+where

10+-- base

11+import Prelude

12+

13+-- opaleye

14+import qualified Opaleye.Window as Opaleye

15+

16+-- rel8

17+import Rel8.Aggregate ( Aggregates )

18+import qualified Rel8.Expr.Window as Expr

19+import Rel8.Schema.HTable ( hfield, htabulateA )

20+import Rel8.Table ( fromColumns, toColumns )

21+import Rel8.Window ( Window( Window ) )

22+

23+

24+-- | 'cumulative' allows the use of aggregation functions in 'Window'

25+-- expressions. In particular, @'cumulative' 'Rel8.sum'@

26+-- (when combined with 'Rel8.Window.orderPartitionBy') gives a running total,

27+-- also known as a \"cumulative sum\", hence the name @cumulative@.

28+cumulative :: Aggregates aggregates exprs => (a -> aggregates) -> Window a exprs

29+cumulative f =

30+ fmap fromColumns $

31+ htabulateA $ \field ->

32+ Expr.cumulative ((`hfield` field) . toColumns . f)

33+

34+

35+-- | A version of 'cumulative' for use with nullary aggregators like

36+-- 'Rel8.Expr.Aggregate.countStar'.

37+cumulative_ :: Aggregates aggregates exprs => aggregates -> Window a exprs

38+cumulative_ = cumulative . const

39+

40+

41+-- | Return every column of the current row of a window query.

42+currentRow :: Window a a

43+currentRow = Window $ Opaleye.over (Opaleye.noWindowFunction id) mempty mempty

src/Rel8/Tabulate.hsnew file+640

@@ -0,0 +1,640 @@

1+{-# language FlexibleContexts #-}

2+{-# language MonoLocalBinds #-}

3+{-# language ScopedTypeVariables #-}

4+{-# language StandaloneKindSignatures #-}

5+{-# language TypeApplications #-}

6+{-# language TupleSections #-}

7+{-# language UndecidableInstances #-}

9+-- | "Rel8.Tabulate" provides an alternative API ('Tabulation') for writing

10+-- queries that complements the main "Rel8" API ('Query').

11+

12+module Rel8.Tabulate

13+ (

14+ Tabulation

15+

16+ -- * Interfacing with 'Query's

17+ , fromQuery

18+ , toQuery

19+ , liftQuery

20+ , through

21+ , lookup

22+

23+ -- * Aggregation and Ordering

24+ , aggregate

25+ , distinct

26+ , order

27+

28+ -- ** Magic 'Tabulation's

29+ -- $magic

30+ , count

31+ , optional

32+ , many

33+ , some

34+ , exists

35+ , present

36+ , absent

37+

38+ -- * Natural joins

39+ , align

40+ , alignWith

41+ , leftAlign

42+ , leftAlignWith

43+ , rightAlign

44+ , rightAlignWith

45+ , zip

46+ , zipWith

47+ , similarity

48+ , difference

49+ )

50+where

51+

52+-- base

53+import Control.Applicative ( (<|>), empty, liftA2 )

54+import Control.Monad ( liftM2 )

55+import Data.Bifunctor ( Bifunctor, bimap, first, second )

56+import Data.Foldable ( traverse_ )

57+import Data.Function ( on )

58+import Data.Functor.Contravariant ( Contravariant, (>$<), contramap )

59+import Data.Int ( Int64 )

60+import Data.Kind ( Type )

61+import Data.Maybe ( fromJust, fromMaybe )

62+import Prelude hiding ( lookup, zip, zipWith )

63+

64+-- bifunctors

65+import Data.Bifunctor.Clown ( Clown( Clown ), runClown )

66+

67+-- comonad

68+import Control.Comonad ( extract )

69+

70+-- opaleye

71+import qualified Opaleye.Aggregate as Opaleye

72+import qualified Opaleye.Order as Opaleye ( orderBy, distinctOnExplicit )

73+

74+-- profunctors

75+import Data.Profunctor ( dimap, lmap )

76+

77+-- product-profunctors

78+import Data.Profunctor.Product

79+ ( ProductProfunctor, (***!)

80+ , SumProfunctor, (+++!)

81+ )

82+import qualified Data.Profunctor.Product as PP

83+

84+-- rel8

85+import Rel8.Aggregate ( Aggregates )

86+import Rel8.Expr ( Expr )

87+import Rel8.Expr.Aggregate ( countStar )

88+import Rel8.Expr.Bool ( true )

89+import Rel8.Order ( Order( Order ) )

90+import Rel8.Query ( Query )

91+import qualified Rel8.Query.Exists as Q ( exists, present, absent )

92+import Rel8.Query.Filter ( where_ )

93+import Rel8.Query.List ( catNonEmptyTable )

94+import qualified Rel8.Query.Maybe as Q ( optional )

95+import Rel8.Query.Opaleye ( mapOpaleye, unsafePeekQuery )

96+import Rel8.Query.Rebind ( rebind )

97+import Rel8.Query.These ( alignBy )

98+import Rel8.Table ( Table, fromColumns, toColumns )

99+import Rel8.Table.Aggregate ( hgroupBy, listAgg, nonEmptyAgg )

100+import Rel8.Table.Alternative

101+ ( AltTable, (<|>:)

102+ , AlternativeTable, emptyTable

103+ )

104+import Rel8.Table.Cols ( fromCols, toCols )

105+import Rel8.Table.Eq ( EqTable, (==:), eqTable )

106+import Rel8.Table.List ( ListTable( ListTable ) )

107+import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), maybeTable )

108+import Rel8.Table.NonEmpty ( NonEmptyTable( NonEmptyTable ) )

109+import Rel8.Table.Opaleye ( aggregator, unpackspec )

110+import Rel8.Table.Ord ( OrdTable )

111+import Rel8.Table.Order ( ascTable )

112+import Rel8.Table.Projection

113+ ( Biprojectable, biproject

114+ , Projectable, project

115+ , apply

116+ )

117+import Rel8.Table.These ( TheseTable( TheseTable ), theseTable )

118+

119+-- semigroupoids

120+import Data.Functor.Apply ( Apply, liftF2 )

121+import Data.Functor.Bind ( Bind, (>>-) )

122+

123+

124+type Key :: Type -> Type

125+type Key = Maybe

126+

127+

128+cat :: Table Expr k => Key k -> Query k

129+cat = maybe emptyTable pure

130+

131+

132+key :: (ProductProfunctor p, SumProfunctor p)

133+ => p a b -> p (Key a) (Key b)

134+key a = dimap from to (PP.empty +++! a)

135+ where

136+ from = maybe (Left ()) Right

137+ to = either (const Nothing) Just

138+

139+

140+keyed :: (ProductProfunctor p, SumProfunctor p)

141+ => p k l -> p a b -> p (Key k, a) (Key l, b)

142+keyed k a = key k ***! a

143+

144+

145+type Predicate :: Type -> Type

146+newtype Predicate a = Predicate (Maybe (a -> Expr Bool))

147+

148+

149+instance Contravariant Predicate where

150+ contramap f (Predicate a) = Predicate (lmap f <$> a)

151+

152+

153+instance Semigroup (Predicate k) where

154+ Predicate ma <> Predicate mb = Predicate $ ma <|> mb

155+

156+

157+instance Monoid (Predicate k) where

158+ mempty = Predicate Nothing

159+

160+

161+match :: EqTable k => Key k -> Predicate k

162+match = Predicate . fmap (==:)

163+

164+

165+ensure :: Predicate k -> Key k -> Query ()

166+ensure (Predicate mp) = traverse_ (\k -> traverse_ (\p -> where_ (p k)) mp)

167+

168+

169+-- | A @'Tabulation' k a@ is like a @'Query' a@, except that each row also

170+-- has a key @k@ in addition to the value @a@. 'Tabulation's can be composed

171+-- monadically just like 'Query's, but the resulting join is more like a

172+-- @NATURAL JOIN@ (based on the common key column(s) @k@) than the

173+-- @CROSS JOIN@ given by 'Query'.

174+--

175+-- Another way to think of @'Tabulation' k a@ is as analogous to @Map k a@ in

176+-- the same way @'Query' a@ is analogous to @[a]@. However, there's nothing

177+-- stopping a 'Tabulation' from containing multiple rows with the same key, so

178+-- technically @Map k (NonEmpty a)@ is more accurate.

179+--

180+-- 'Tabulation's can be created from 'Query's with 'fromQuery' and 'liftQuery'

181+-- and converted back to 'Query's with 'lookup' and 'toQuery' (though note the

182+-- caveats that come with the latter).

183+type Tabulation :: Type -> Type -> Type

184+newtype Tabulation k a = Tabulation (Predicate k -> Query (Key k, a))

185+

186+

187+instance Biprojectable Tabulation where

188+ biproject f g =

189+ bimap

190+ (fromColumns . apply f . toColumns)

191+ (fromColumns . apply g . toColumns)

192+

193+

194+instance Bifunctor Tabulation where

195+ bimap f g (Tabulation a) = Tabulation $ \p ->

196+ bimap (fmap f) g <$> a (f >$< p)

197+

198+

199+instance Functor (Tabulation k) where

200+ fmap = second

201+

202+

203+instance Projectable (Tabulation k) where

204+ project f = fmap (fromColumns . apply f . toColumns)

205+

206+

207+-- | If @'Tabulation' k a@ is @Map k (NonEmpty a)@, then @(<.>)@ is

208+-- @intersectionWith (liftA2 (<*>))@

209+instance EqTable k => Apply (Tabulation k) where

210+ liftF2 = liftA2

211+

212+

213+-- | @pure = 'liftQuery' . pure@

214+instance EqTable k => Applicative (Tabulation k) where

215+ pure = liftQuery . pure

216+ liftA2 = liftM2

217+

218+

219+instance EqTable k => Bind (Tabulation k) where

220+ Tabulation as >>- f = Tabulation $ \p -> do

221+ (k, a) <- as p

222+ case f a of

223+ Tabulation bs -> do

224+ let p' = match k

225+ (k', b) <- bs (p' <> p)

226+ ensure p' k'

227+ pure (k' <|> k, b)

228+

229+

230+instance EqTable k => Monad (Tabulation k) where

231+ (>>=) = (>>-)

232+

233+

234+-- | If @'Tabulation' k a@ is @Map k (NonEmpty a)@, then @(<|>:)@ is

235+-- @unionWith (<>)@.

236+instance EqTable k => AltTable (Tabulation k) where

237+ tas <|>: tbs = do

238+ eas <- peek tas

239+ ebs <- peek tbs

240+ case (eas, ebs) of

241+ (Left as, Left bs) -> liftQuery $ as <|>: bs

242+ (Right as, Right bs) -> fromQuery $ as <|>: bs

243+ _ -> catNonEmptyTable `through` ((<>) `on` some) tas tbs

244+

245+

246+instance EqTable k => AlternativeTable (Tabulation k) where

247+ emptyTable = Tabulation $ const $ fmap (empty,) emptyTable

248+

249+

250+-- | If @'Tabulation' k a@ is @Map k (NonEmpty a)@, then @(<>)@ is

251+-- @unionWith (liftA2 (<>))@.

252+instance (EqTable k, Table Expr a, Semigroup a) => Semigroup (Tabulation k a)

253+ where

254+ (<>) = alignWith (theseTable id id (<>))

255+

256+

257+instance (EqTable k, Table Expr a, Semigroup a) => Monoid (Tabulation k a)

258+ where

259+ mempty = emptyTable

260+

261+

262+-- | Any 'Query' of key-value pairs @(k, a)@ can be a @'Tabulation' k a@.

263+fromQuery :: Query (k, a) -> Tabulation k a

264+fromQuery = Tabulation . const . fmap (first pure)

265+

266+

267+-- | Convert a @'Tabulation' k a@ back into a 'Query' of key-value pairs.

268+--

269+-- Note that the result of a 'toQuery' is undefined (will always return zero

270+-- rows) on 'Tabulation's constructed with 'liftQuery' or 'pure'. So while

271+-- @toQuery . fromQuery@ is always @id@, @fromQuery . toQuery@ is not.

272+--

273+-- A safer, more predictable alternative to 'toQuery' is to use 'lookup' with

274+-- an explicit set of keys:

275+--

276+-- @

277+-- do

278+-- k <- keys

279+-- a <- lookup k tabulation

280+-- pure (k, a)

281+-- @

282+--

283+-- Having said that, in practice, most legitimate uses of 'Tabulation' will

284+-- have a well-defined 'toQuery'. It would be possible in theory to encode

285+-- the necessary invariants at the type level using an indexed monad, but we

286+-- would lose the ability to use @do@-notation, which is the main benefit

287+-- of having 'Tabulation' as a monad in the first place.

288+--

289+-- In particular, @'toQuery' t@ is well-defined for any 'Tabulation' @t@

290+-- defined as @t = fromQuery _@. @'toQuery' t@ is also well-defined for any

291+-- 'Tabulation' @t@ defined as @t = t' >>= _@ or @t = t' *> _@ where

292+-- @'toQuery' t'@ is well-defined. There are other valid permutations too.

293+-- Generally, anything that uses 'fromQuery' at some point, unless wrapped in

294+-- a top-level 'present' or 'absent', will have a well-defined 'toQuery'.

295+toQuery :: Table Expr k => Tabulation k a -> Query (k, a)

296+toQuery (Tabulation f) = do

297+ (mk, a) <- f mempty

298+ k <- cat mk

299+ pure (k, a)

300+

301+

302+-- | A @'Query' a@ can be treated as a @'Tabulation' k a@ where the given @a@

303+-- values exist at every possible key @k@.

304+liftQuery :: Query a -> Tabulation k a

305+liftQuery = Tabulation . const . fmap (empty,)

306+

307+

308+-- | Run a Kleisli arrow in the the 'Query' monad \"through\" a 'Tabulation'.

309+-- Useful for 'Rel8.filter'ing a 'Tabulation'.

310+--

311+-- @

312+-- 'Rel8.filter' ((>=. 30) . userAge) `'through'` usersById

313+-- @

314+through :: (a -> Query b) -> Tabulation k a -> Tabulation k b

315+through f (Tabulation as) = Tabulation $ \p -> do

316+ (k, a) <- as p

317+ b <- f a

318+ pure (k, b)

319+infixr 1 `through`

320+

321+

322+-- | @'lookup' k t@ returns the value(s) at the key @k@ in the tabulation @t@.

323+lookup :: EqTable k => k -> Tabulation k a -> Query a

324+lookup k (Tabulation f) = do

325+ (k', a) <- f p

326+ ensure p k'

327+ pure a

328+ where

329+ p = match (pure k)

330+

331+

332+-- | 'aggregate' aggregates the values within each key of a

333+-- 'Tabulation'. There is an implicit @GROUP BY@ on all the key columns.

334+aggregate :: forall k aggregates exprs.

335+ ( EqTable k

336+ , Aggregates aggregates exprs

337+ )

338+ => Tabulation k aggregates -> Tabulation k exprs

339+aggregate (Tabulation f) = Tabulation $

340+ mapOpaleye (Opaleye.aggregate (keyed haggregator aggregator)) .

341+ fmap (first (fmap (hgroupBy (eqTable @k) . toColumns))) .

342+ f

343+ where

344+ haggregator = dimap fromColumns fromCols aggregator

345+

346+

347+-- | 'distinct' ensures a 'Tabulation' has at most one value for

348+-- each key, i.e., it drops duplicates. In general it keeps only the

349+-- \"first\" value it encounters for each key, but note that \"first\" is

350+-- undefined unless you first call 'order'.

351+distinct :: EqTable k => Tabulation k a -> Tabulation k a

352+distinct (Tabulation f) = Tabulation $

353+ mapOpaleye (Opaleye.distinctOnExplicit (key unpackspec) fst) . f

354+

355+

356+-- | 'order' orders the /values/ of a 'Tabulation' within their

357+-- respective keys. This specifies a defined order for 'distinct'.

358+-- It also defines the order of the lists produced by 'many' and

359+-- 'some'.

360+order :: OrdTable k => Order a -> Tabulation k a -> Tabulation k a

361+order ordering (Tabulation f) =

362+ Tabulation $ mapOpaleye (Opaleye.orderBy ordering') . f

363+ where

364+ Order ordering' = runClown (keyed (Clown ascTable) (Clown ordering))

365+

366+

367+-- $magic

368+--

369+-- Some of the following combinators produce \"magic\" 'Tabulation's. Let's

370+-- use 'count' as an example to demonstrate this concept. Consider

371+-- the following:

372+--

373+-- @

374+-- count $ fromQuery $ values

375+-- [ (lit 'a', lit True)

376+-- , (lit 'a', lit False)

377+-- , (lit 'b', lit True)

378+-- ]

379+-- @

380+--

381+-- You might expect this to be equivalent to the following 'Tabulation':

382+--

383+-- @

384+-- fromQuery $ values

385+-- [ (lit 'a', 2)

386+-- , (lit 'b', 1)

387+-- ]

388+-- @

389+--

390+-- However, it isn't quite. While the resulting 'Tabulation' does effectively

391+-- contain the above entries, it also behaves as though it contained the value

392+-- @0@ at every other possible key.

393+--

394+-- This means you can do:

395+--

396+-- @

397+-- do

398+-- user <- usersById

399+-- orderCount <- count ordersByUserId

400+-- @

401+--

402+-- To see how many orders a user has (getting @0@ if they have no orders).

403+

404+

405+-- | 'count' returns a count of how many entries are in the given

406+-- 'Tabulation' at each key.

407+--

408+-- The resulting 'Tabulation' is \"magic\" in that the value @0@ exists at

409+-- every possible key that wasn't in the given 'Tabulation'.

410+count :: EqTable k => Tabulation k a -> Tabulation k (Expr Int64)

411+count =

412+ fmap (maybeTable 0 id) .

413+ optional .

414+ aggregate .

415+ fmap (const countStar)

416+

417+

418+-- | 'optional' produces a \"magic\" 'Tabulation' whereby each

419+-- entry in the given 'Tabulation' is wrapped in 'Rel8.justTable', and every

420+-- other possible key contains a single 'Rel8.nothingTable'.

421+--

422+-- This is used to implement 'leftAlignWith'.

423+optional :: Tabulation k a -> Tabulation k (MaybeTable Expr a)

424+optional (Tabulation f) = Tabulation $ \p -> case p of

425+ Predicate Nothing -> fmap pure <$> f p

426+ _ -> fmap (\m -> (empty, snd <$> m)) $ Q.optional $ do

427+ (k, a) <- f p

428+ ensure p k

429+ pure (k, a)

430+

431+

432+-- | 'many' aggregates each entry with a particular key into a

433+-- single entry with all of the values contained in a 'ListTable'.

434+--

435+-- 'order' can be used to give this 'ListTable' a defined order.

436+--

437+-- The resulting 'Tabulation' is \"magic\" in that the value

438+-- @'Rel8.listTable []'@ exists at every possible key that wasn't in the given

439+-- 'Tabulation'.

440+many :: (EqTable k, Table Expr a)

441+ => Tabulation k a -> Tabulation k (ListTable Expr a)

442+many =

443+ fmap (maybeTable mempty (\(ListTable a) -> ListTable a)) .

444+ optional .

445+ aggregate .

446+ fmap (listAgg . toCols)

447+

448+

449+-- | 'some' aggregates each entry with a particular key into a

450+-- single entry with all of the values contained in a 'NonEmptyTable'.

451+--

452+-- 'order' can be used to give this 'NonEmptyTable' a defined order.

453+some :: (EqTable k, Table Expr a)

454+ => Tabulation k a -> Tabulation k (NonEmptyTable Expr a)

455+some =

456+ fmap (\(NonEmptyTable a) -> NonEmptyTable a) .

457+ aggregate .

458+ fmap (nonEmptyAgg . toCols)

459+

460+

461+-- | 'exists' produces a \"magic\" 'Tabulation' which contains the

462+-- value 'Rel8.true' at each key in the given 'Tabulation', and the value

463+-- 'Rel8.false' at every other possible key.

464+exists :: Tabulation k a -> Tabulation k (Expr Bool)

465+exists (Tabulation f) = Tabulation $ \p -> case p of

466+ Predicate Nothing -> (true <$) <$> f p

467+ _ -> fmap (empty,) $ Q.exists $ do

468+ (k, _) <- f p

469+ ensure p k

470+

471+

472+-- | 'present' produces a 'Tabulation' where a single @()@ row

473+-- exists for every key that was present in the given 'Tabulation'.

474+--

475+-- This is used to implement 'similarity'.

476+present :: Tabulation k a -> Tabulation k ()

477+present (Tabulation f) = Tabulation $ \p -> do

478+ Q.present $ do

479+ (k, _) <- f p

480+ ensure p k

481+ pure (empty, ())

482+

483+

484+-- | 'absent' produces a 'Tabulation' where a single @()@ row exists

485+-- at every possible key that absent from the given 'Tabulation'.

486+--

487+-- This is used to implement 'difference'.

488+absent :: Tabulation k a -> Tabulation k ()

489+absent (Tabulation f) = Tabulation $ \p -> do

490+ Q.absent $ do

491+ (k, _) <- f p

492+ ensure p k

493+ pure (empty, ())

494+

495+

496+-- | Performs a @NATURAL FULL OUTER JOIN@ based on the common key columns.

497+--

498+-- Analogous to 'Data.Semialign.align'.

499+align :: EqTable k

500+ => Tabulation k a -> Tabulation k b -> Tabulation k (TheseTable Expr a b)

501+align = alignWith id

502+

503+

504+-- | Performs a @NATURAL FULL OUTER JOIN@ based on the common key columns.

505+--

506+-- Analogous to 'Data.Semialign.alignWith'.

507+alignWith :: EqTable k

508+ => (TheseTable Expr a b -> c)

509+ -> Tabulation k a -> Tabulation k b -> Tabulation k c

510+alignWith f (Tabulation as) (Tabulation bs) = Tabulation $ \p -> do

511+ tkab <- liftF2 (alignBy condition) as bs p

512+ k <- traverse (rebind "key") $ recover $ bimap fst fst tkab

513+ let

514+ tab = bimap snd snd tkab

515+ pure (k, f tab)

516+ where

517+ condition (k, _) (k', _) = fromMaybe true (liftA2 (==:) k k')

518+ recover (TheseTable mma@(MaybeTable _ ma) mmb@(MaybeTable _ mb)) =

519+ case extract ma of

520+ Nothing -> extract mb

521+ Just a -> case extract mb of

522+ Nothing -> extract ma

523+ Just b -> case a <$ mma <|>: b <$ mmb of

524+ MaybeTable _ c -> pure (extract c)

525+

526+

527+-- | Performs a @NATURAL LEFT OUTER JOIN@ based on the common key columns.

528+--

529+-- Analogous to 'Data.Semialign.rpadZip'.

530+--

531+-- Note that you can achieve the same effect with 'optional' and the

532+-- 'Applicative' instance for 'Tabulation', i.e., this is just

533+-- @\left right -> liftA2 (,) left (optional right). You can also

534+-- use @do@-notation.

535+leftAlign :: EqTable k

536+ => Tabulation k a -> Tabulation k b -> Tabulation k (a, MaybeTable Expr b)

537+leftAlign = leftAlignWith (,)

538+

539+

540+-- | Performs a @NATURAL LEFT OUTER JOIN@ based on the common key columns.

541+--

542+-- Analogous to 'Data.Semialign.rpadZipWith'.

543+--

544+-- Note that you can achieve the same effect with 'optional' and the

545+-- 'Applicative' instance for 'Tabulation', i.e., this is just

546+-- @\f left right -> liftA2 f left (optional right). You can also

547+-- use @do@-notation.

548+leftAlignWith :: EqTable k

549+ => (a -> MaybeTable Expr b -> c)

550+ -> Tabulation k a -> Tabulation k b -> Tabulation k c

551+leftAlignWith f left right = liftA2 f left (optional right)

552+

553+

554+-- | Performs a @NATURAL RIGHT OUTER JOIN@ based on the common key columns.

555+--

556+-- Analogous to 'Data.Semialign.lpadZip'.

557+--

558+-- Note that you can achieve the same effect with 'optional' and the

559+-- 'Applicative' instance for 'Tabulation', i.e., this is just

560+-- @\left right -> liftA2 (flip (,)) right (optional left). You can

561+-- also use @do@-notation.

562+rightAlign :: EqTable k

563+ => Tabulation k a -> Tabulation k b -> Tabulation k (MaybeTable Expr a, b)

564+rightAlign = rightAlignWith (,)

565+

566+

567+-- | Performs a @NATURAL RIGHT OUTER JOIN@ based on the common key columns.

568+--

569+-- Analogous to 'Data.Semialign.lpadZipWith'.

570+--

571+-- Note that you can achieve the same effect with 'optional' and the

572+-- 'Applicative' instance for 'Tabulation', i.e., this is just

573+-- @\f left right -> liftA2 (flip f) right (optional left). You can

574+-- also use @do@-notation.

575+rightAlignWith :: EqTable k

576+ => (MaybeTable Expr a -> b -> c)

577+ -> Tabulation k a -> Tabulation k b -> Tabulation k c

578+rightAlignWith f left right = liftA2 (flip f) right (optional left)

579+

580+

581+-- | Performs a @NATURAL INNER JOIN@ based on the common key columns.

582+--

583+-- Analagous to 'Data.Semialign.zip'.

584+--

585+-- Note that you can achieve the same effect with the 'Applicative' instance

586+-- of 'Tabulation', i.e., this is just @'liftA2 (,)'@. You can also use

587+-- @do@-notation.

588+zip :: EqTable k

589+ => Tabulation k a -> Tabulation k b -> Tabulation k (a, b)

590+zip = zipWith (,)

591+

592+

593+-- | Performs a @NATURAL INNER JOIN@ based on the common key columns.

594+--

595+-- Analagous to 'Data.Semialign.zipWith'.

596+--

597+-- Note that you can achieve the same effect with the 'Applicative' instance

598+-- of 'Tabulation', i.e., this is just @'liftA2'@. You can also use

599+-- @do@-notation.

600+zipWith :: EqTable k

601+ => (a -> b -> c) -> Tabulation k a -> Tabulation k b -> Tabulation k c

602+zipWith = liftA2

603+

604+

605+-- | Performs a [@NATURAL SEMI JOIN@](https://en.wikipedia.org/wiki/Relational_algebra#Semijoin_%28%E2%8B%89%29%28%E2%8B%8A%29)

606+-- based on the common key columns.

607+--

608+-- The result is a subset of the left tabulation where only entries which have

609+-- a corresponding entry in the right tabulation are kept.

610+--

611+-- Note that you can achieve a similar effect with 'present' and the

612+-- 'Applicative' instance of 'Tabulation', i.e., this is just

613+-- @\left right -> left <* present right@. You can also use

614+-- @do@-notation.

615+similarity :: EqTable k => Tabulation k a -> Tabulation k b -> Tabulation k a

616+similarity a b = a <* present b

617+

618+

619+-- | Performs a [@NATURAL ANTI JOIN@](https://en.wikipedia.org/wiki/Relational_algebra#Antijoin_%28%E2%96%B7%29)

620+-- based on the common key columns.

621+--

622+-- The result is a subset of the left tabulation where only entries which do

623+-- not have a corresponding entry in the right tabulation are kept.

624+--

625+-- Note that you can achieve a similar effect with 'absent' and the

626+-- 'Applicative' instance of 'Tabulation', i.e., this is just

627+-- @\left right -> left <* absent right@. You can also use

628+-- @do@-notation.

629+difference :: EqTable k => Tabulation k a -> Tabulation k b -> Tabulation k a

630+difference a b = a <* absent b

631+

632+

633+-- | 'Tabulation's can be produced with either 'fromQuery' or 'liftQuery', and

634+-- in some cases we might want to treat these differently. 'peek' uses

635+-- 'unsafePeekQuery' to determine which type of 'Tabulation' we have.

636+peek :: Tabulation k a -> Tabulation k (Either (Query a) (Query (k, a)))

637+peek (Tabulation f) = Tabulation $ \p ->

638+ pure $ (empty,) $ case unsafePeekQuery (f p) of

639+ (Nothing, _) -> Left $ fmap snd (f p)

640+ (Just _, _) -> Right $ fmap (first fromJust) (f p)

src/Rel8/Type.hs+9−8

@@ -1,3 +1,4 @@

1+{-# language FlexibleContexts #-}

1{-# language FlexibleInstances #-}

2{-# language FlexibleInstances #-}

2{-# language MonoLocalBinds #-}

3{-# language MonoLocalBinds #-}

3{-# language MultiWayIf #-}

4{-# language MultiWayIf #-}

@@ -127,10 +128,10 @@ instance DBType Int64 where

127instance DBType Float where

128instance DBType Float where

128 typeInformation = TypeInformation

129 typeInformation = TypeInformation

129 { encode = \x -> Opaleye.ConstExpr

130 { encode = \x -> Opaleye.ConstExpr

130− if | x == (1 /0) -> Opaleye.OtherLit "'Infinity'"

131+ if | x == (1 / 0) -> Opaleye.OtherLit "'Infinity'"

131− | isNaN x -> Opaleye.OtherLit "'NaN'"

132+ | isNaN x -> Opaleye.OtherLit "'NaN'"

132− | x == (-1/0) -> Opaleye.OtherLit "'-Infinity'"

133+ | x == (-1 / 0) -> Opaleye.OtherLit "'-Infinity'"

133− | otherwise -> Opaleye.NumericLit $ realToFrac x

134+ | otherwise -> Opaleye.NumericLit $ realToFrac x

134 , decode = Hasql.float4

135 , decode = Hasql.float4

135 , typeName = "float4"

136 , typeName = "float4"

136 }

137 }

@@ -140,10 +141,10 @@ instance DBType Float where

140instance DBType Double where

141instance DBType Double where

141 typeInformation = TypeInformation

142 typeInformation = TypeInformation

142 { encode = \x -> Opaleye.ConstExpr

143 { encode = \x -> Opaleye.ConstExpr

143− if | x == (1 /0) -> Opaleye.OtherLit "'Infinity'"

144+ if | x == (1 / 0) -> Opaleye.OtherLit "'Infinity'"

144− | isNaN x -> Opaleye.OtherLit "'NaN'"

145+ | isNaN x -> Opaleye.OtherLit "'NaN'"

145− | x == (-1/0) -> Opaleye.OtherLit "'-Infinity'"

146+ | x == (-1 / 0) -> Opaleye.OtherLit "'-Infinity'"

146− | otherwise -> Opaleye.NumericLit $ realToFrac x

147+ | otherwise -> Opaleye.NumericLit $ realToFrac x

147 , decode = Hasql.float8

148 , decode = Hasql.float8

148 , typeName = "float8"

149 , typeName = "float8"

149 }

150 }

src/Rel8/Type/Enum.hs+1

@@ -106,6 +106,7 @@ class (DBType a, Enumable a) => DBEnum a where

106

107-- | Types that are sum types, where each constructor is unary (that is, has no

108-- fields).

109+type Enumable :: Type -> Constraint

109class (Generic a, GEnumable (Rep a)) => Enumable a

110class (Generic a, GEnumable (Rep a)) => Enumable a

110instance (Generic a, GEnumable (Rep a)) => Enumable a

111instance (Generic a, GEnumable (Rep a)) => Enumable a

111

112

src/Rel8/Type/JSONBEncoded.hs+4

@@ -1,3 +1,5 @@

1+{-# language StandaloneKindSignatures #-}

1module Rel8.Type.JSONBEncoded ( JSONBEncoded(..) ) where

3module Rel8.Type.JSONBEncoded ( JSONBEncoded(..) ) where

3-- aeson

5-- aeson

@@ -6,6 +8,7 @@ import Data.Aeson.Types ( parseEither )

7-- base

9-- base

8import Data.Bifunctor ( first )

10import Data.Bifunctor ( first )

11+import Data.Kind ( Type )

9import Prelude

12import Prelude

11-- hasql

14-- hasql

@@ -20,6 +23,7 @@ import Data.Text ( pack )

22-- | Like 'Rel8.JSONEncoded', but works for @jsonb@ columns.

25-- | Like 'Rel8.JSONEncoded', but works for @jsonb@ columns.

26+type JSONBEncoded :: Type -> Type

23newtype JSONBEncoded a = JSONBEncoded { fromJSONBEncoded :: a }

27newtype JSONBEncoded a = JSONBEncoded { fromJSONBEncoded :: a }

src/Rel8/Type/JSONEncoded.hs+4

@@ -1,3 +1,5 @@

1+{-# language StandaloneKindSignatures #-}

1module Rel8.Type.JSONEncoded ( JSONEncoded(..) ) where

3module Rel8.Type.JSONEncoded ( JSONEncoded(..) ) where

3-- aeson

5-- aeson

@@ -5,6 +7,7 @@ import Data.Aeson ( FromJSON, ToJSON, parseJSON, toJSON )

5import Data.Aeson.Types ( parseEither )

7import Data.Aeson.Types ( parseEither )

7-- base

9-- base

10+import Data.Kind ( Type )

8import Prelude

11import Prelude

10-- rel8

13-- rel8

@@ -15,6 +18,7 @@ import Rel8.Type.Information ( parseTypeInformation )

15-- | A deriving-via helper type for column types that store a Haskell value

18-- | A deriving-via helper type for column types that store a Haskell value

16-- using a JSON encoding described by @aeson@'s 'ToJSON' and 'FromJSON' type

19-- using a JSON encoding described by @aeson@'s 'ToJSON' and 'FromJSON' type

17-- classes.

20-- classes.

21+type JSONEncoded :: Type -> Type

18newtype JSONEncoded a = JSONEncoded { fromJSONEncoded :: a }

22newtype JSONEncoded a = JSONEncoded { fromJSONEncoded :: a }

src/Rel8/Type/Num.hs+4−1

@@ -18,6 +18,7 @@ import Prelude

19-- rel8

20import Rel8.Type ( DBType )

21+import Rel8.Type.Ord ( DBOrd )

22-- scientific

23-- scientific

23import Data.Scientific ( Scientific )

24import Data.Scientific ( Scientific )

@@ -39,13 +40,14 @@ instance DBNum Scientific

39-- expressions. This is a Rel8 concept, and allows us to provide

40-- expressions. This is a Rel8 concept, and allows us to provide

40-- 'fromIntegral'.

41-- 'fromIntegral'.

41type DBIntegral :: Type -> Constraint

42type DBIntegral :: Type -> Constraint

42−class DBNum a => DBIntegral a

43+class (DBNum a, DBOrd a) => DBIntegral a

43instance DBIntegral Int16

44instance DBIntegral Int16

44instance DBIntegral Int32

45instance DBIntegral Int32

45instance DBIntegral Int64

46instance DBIntegral Int64

48-- | The class of database types that support the @/@ operator.

49-- | The class of database types that support the @/@ operator.

50+type DBFractional :: Type -> Constraint

49class DBNum a => DBFractional a

51class DBNum a => DBFractional a

50instance DBFractional Float

52instance DBFractional Float

51instance DBFractional Double

53instance DBFractional Double

@@ -53,6 +55,7 @@ instance DBFractional Scientific

55-- | The class of database types that support the @/@ operator.

57-- | The class of database types that support the @/@ operator.

58+type DBFloating :: Type -> Constraint

56class DBFractional a => DBFloating a

59class DBFractional a => DBFloating a

57instance DBFloating Float

60instance DBFloating Float

58instance DBFloating Double

61instance DBFloating Double

src/Rel8/Type/Ord.hs−2

@@ -75,7 +75,6 @@ instance Sql DBOrd a => DBOrd (NonEmpty a)

75-- | The class of database types that support the @max@ aggregation function.

76type DBMax :: Type -> Constraint

77class DBOrd a => DBMax a

78−instance DBMax Bool

79instance DBMax Char

78instance DBMax Char

80instance DBMax Int16

79instance DBMax Int16

81instance DBMax Int32

80instance DBMax Int32

@@ -101,7 +100,6 @@ instance Sql DBMax a => DBMax (NonEmpty a)

101-- | The class of database types that support the @min@ aggregation function.

100-- | The class of database types that support the @min@ aggregation function.

102type DBMin :: Type -> Constraint

101type DBMin :: Type -> Constraint

103class DBOrd a => DBMin a

102class DBOrd a => DBMin a

104−instance DBMin Bool

105instance DBMin Char

103instance DBMin Char

106instance DBMin Int16

104instance DBMin Int16

107instance DBMin Int32

105instance DBMin Int32

src/Rel8/Type/ReadShow.hs+3

@@ -1,10 +1,12 @@

1{-# language ScopedTypeVariables #-}

2+{-# language StandaloneKindSignatures #-}

2{-# language TypeApplications #-}

3{-# language TypeApplications #-}

3{-# language ViewPatterns #-}

4{-# language ViewPatterns #-}

5module Rel8.Type.ReadShow ( ReadShow(..) ) where

6module Rel8.Type.ReadShow ( ReadShow(..) ) where

7-- base

8-- base

9+import Data.Kind ( Type )

8import Data.Proxy ( Proxy( Proxy ) )

10import Data.Proxy ( Proxy( Proxy ) )

9import Data.Typeable ( Typeable, typeRep )

11import Data.Typeable ( Typeable, typeRep )

10import Prelude

12import Prelude

@@ -20,6 +22,7 @@ import qualified Data.Text as Text

21-- | A deriving-via helper type for column types that store a Haskell value

23-- | A deriving-via helper type for column types that store a Haskell value

22-- using a Haskell's 'Read' and 'Show' type classes.

24-- using a Haskell's 'Read' and 'Show' type classes.

25+type ReadShow :: Type -> Type

23newtype ReadShow a = ReadShow { fromReadShow :: a }

26newtype ReadShow a = ReadShow { fromReadShow :: a }

src/Rel8/Type/Tag.hs+1

@@ -90,6 +90,7 @@ instance DBMonoid MaybeTag where

90 memptyExpr = litExpr mempty

93+type Tag :: Type

93newtype Tag = Tag Text

94newtype Tag = Tag Text

94 deriving newtype

95 deriving newtype

95 ( Eq, Ord, Read, Show

96 ( Eq, Ord, Read, Show

src/Rel8/Window.hsnew file+97

@@ -0,0 +1,97 @@

1+{-# language DerivingVia #-}

2+{-# language FlexibleContexts #-}

3+{-# language GeneralizedNewtypeDeriving #-}

4+{-# language ScopedTypeVariables #-}

5+{-# language StandaloneKindSignatures #-}

6+{-# language TypeApplications #-}

8+module Rel8.Window

9+ ( Window(..)

10+ , Partition

11+ , over

12+ , partitionBy

13+ , orderPartitionBy

14+ )

15+where

16+

17+-- base

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

19+import Data.Functor.Contravariant ( Contravariant, contramap )

20+import Data.Kind ( Type )

21+import Prelude

22+

23+-- opaleye

24+import qualified Opaleye.Internal.Window as Opaleye

25+import qualified Opaleye.Internal.PackMap as Opaleye

26+

27+-- profunctors

28+import Data.Profunctor ( Profunctor )

29+

30+-- product-profunctors

31+import Data.Profunctor.Product ( ProductProfunctor, (****), purePP )

32+

33+-- rel8

34+import Rel8.Expr.Opaleye ( toColumn, toPrimExpr )

35+import Rel8.Order( Order( Order ) )

36+import Rel8.Schema.HTable ( hfield, htabulateA )

37+import Rel8.Table ( Columns, toColumns )

38+import Rel8.Table.Eq ( EqTable )

39+

40+-- semigroupoids

41+import Data.Functor.Apply ( Apply, WrappedApplicative(..) )

42+

43+

44+-- | 'Window' is an applicative functor that represents expressions that

45+-- contain

46+-- [window functions](https://www.postgresql.org/docs/current/tutorial-window.html).

47+-- 'Rel8.Query.Window.window' can be used to

48+-- evaluate these expressions over a particular query.

49+type Window :: Type -> Type -> Type

50+newtype Window a b = Window (Opaleye.Windows a b)

51+ deriving newtype (Profunctor)

52+ deriving newtype (Functor, Applicative)

53+ deriving (Apply) via (WrappedApplicative (Window a))

54+

55+

56+instance ProductProfunctor Window where

57+ purePP = pure

58+ (****) = (<*>)

59+

60+

61+-- | In PostgreSQL, window functions must specify the \"window\" or

62+-- \"partition\" over which they operate. The syntax for this looks like:

63+-- @SUM(salary) OVER (PARTITION BY department)@. The Rel8 type 'Partition'

64+-- represents everything that comes after @OVER@.

65+--

66+-- 'Partition' is a 'Monoid', so 'Window's created with 'partitionBy' and

67+-- 'orderWindowBy' can be combined using '<>'.

68+type Partition :: Type -> Type

69+newtype Partition a = Partition (Opaleye.Window a)

70+ deriving newtype (Contravariant, Semigroup, Monoid)

71+

72+

73+-- | 'over' adds a 'Partition' to a 'Window' expression.

74+--

75+-- @@@

76+-- 'Rel8.Table.Window.cumulative' ('Rel8.Expr.Aggregate.sum' . salary) `over` 'partitionBy' department <> 'orderPartitionBy' (salary >$< 'Rel8.desc')

77+-- @@@

78+over :: Window a b -> Partition a -> Window a b

79+over (Window (Opaleye.Windows (Opaleye.PackMap w))) (Partition p) =

80+ Window $ Opaleye.Windows $ Opaleye.PackMap $ \f ->

81+ w (\(o, p') -> f (o, p' <> p))

82+infixl 1 `over`

83+

84+

85+-- | Restricts a window function to operate only the group of rows that share

86+-- the same value(s) for the given expression(s).

87+partitionBy :: forall b a. EqTable b => (a -> b) -> Partition a

88+partitionBy f =

89+ Partition $ contramap (toColumns . f) $ getConst $

90+ htabulateA @(Columns b) $ \field ->

91+ Const $ Opaleye.partitionBy (toColumn . toPrimExpr . (`hfield` field))

92+

93+

94+-- | Controls the order in which rows are processed by window functions. This

95+-- does not need to match the ordering of the overall query.

96+orderPartitionBy :: Order a -> Partition a

97+orderPartitionBy (Order ordering) = Partition $ Opaleye.orderPartitionBy ordering

tests/Main.hs+288−178

@@ -1,12 +1,11 @@

1+{-# language BangPatterns #-}

1{-# language BlockArguments #-}

2{-# language BlockArguments #-}

2−{-# language DataKinds #-}

3{-# language DeriveAnyClass #-}

4{-# language DeriveGeneric #-}

5{-# language DerivingStrategies #-}

6−{-# language DisambiguateRecordFields #-}

7{-# language FlexibleContexts #-}

6{-# language FlexibleContexts #-}

8{-# language FlexibleInstances #-}

7{-# language FlexibleInstances #-}

9−{-# language GADTs #-}

8+{-# language MonoLocalBinds #-}

10{-# language NamedFieldPuns #-}

9{-# language NamedFieldPuns #-}

11{-# language OverloadedStrings #-}

10{-# language OverloadedStrings #-}

12{-# language RecordWildCards #-}

11{-# language RecordWildCards #-}

@@ -14,17 +13,15 @@

14{-# language StandaloneDeriving #-}

13{-# language StandaloneDeriving #-}

15{-# language TypeApplications #-}

14{-# language TypeApplications #-}

17−{-# options_ghc -fno-warn-redundant-constraints #-}

18−

19module Main

16module Main

20 ( main

17 ( main

21 )

18 )

22where

19where

24-- base

21-- base

25−import Control.Applicative ( liftA2, liftA3 )

22+import Control.Applicative ( empty, liftA2, liftA3 )

26−import Control.Monad (void)

23+import Control.Exception ( bracket, throwIO )

27−import Control.Monad.IO.Class ( MonadIO, liftIO )

24+import Control.Monad ( (>=>), void )

28import Data.Bifunctor ( bimap )

25import Data.Bifunctor ( bimap )

29import Data.Foldable ( for_ )

26import Data.Foldable ( for_ )

30import Data.Int ( Int32, Int64 )

27import Data.Int ( Int32, Int64 )

@@ -38,25 +35,27 @@ import GHC.Generics ( Generic )

38import qualified Data.ByteString.Lazy

35import qualified Data.ByteString.Lazy

40-- case-insensitive

37-- case-insensitive

41−import Data.CaseInsensitive (mk)

38+import Data.CaseInsensitive ( mk )

43-- containers

40-- containers

41+import Data.Containers.ListUtils ( nubOrdOn )

44import qualified Data.Map.Strict as Map

42import qualified Data.Map.Strict as Map

46-- hasql

44-- hasql

47−import Hasql.Connection ( Connection, acquire, release )

45+import Hasql.Connection ( Connection, acquire, release )

48import Hasql.Session ( sql, run )

46import Hasql.Session ( sql, run )

48+-- hasql-transaction

49+import Hasql.Transaction ( Transaction, condemn, statement )

50+import qualified Hasql.Transaction.Sessions as Hasql

51+

50-- hedgehog

52-- hedgehog

51import Hedgehog ( property, (===), forAll, cover, diff, evalM, PropertyT, TestT, test, Gen )

53import Hedgehog ( property, (===), forAll, cover, diff, evalM, PropertyT, TestT, test, Gen )

52import qualified Hedgehog.Gen as Gen

54import qualified Hedgehog.Gen as Gen

53import qualified Hedgehog.Range as Range

55import qualified Hedgehog.Range as Range

55−-- lifted-base

57+-- mmorph

56−import Control.Exception.Lifted ( bracket, throwIO, bracket_ )

57−

58−-- monad-control

59−import Control.Monad.Trans.Control ( MonadBaseControl )

58+import Control.Monad.Morph ( hoist )

61-- rel8

60-- rel8

62import Rel8 ( Result )

61import Rel8 ( Result )

@@ -72,12 +71,16 @@ import Test.Tasty

72import Test.Tasty.Hedgehog ( testProperty )

71import Test.Tasty.Hedgehog ( testProperty )

74-- text

73-- text

75−import Data.Text (Text, pack)

74+import Data.Text ( Text, pack, unpack )

76import qualified Data.Text.Lazy

75import qualified Data.Text.Lazy

76+import Data.Text.Encoding ( decodeUtf8 )

78-- time

79import Data.Time

81+-- transformers

82+import Control.Monad.Trans.Class ( lift )

83+

81-- tmp-postgres

84-- tmp-postgres

82import qualified Database.Postgres.Temp as TmpPostgres

85import qualified Database.Postgres.Temp as TmpPostgres

@@ -113,11 +116,13 @@ tests =

113 , testCatMaybeTable getTestDatabase

116 , testCatMaybeTable getTestDatabase

114 , testCatMaybe getTestDatabase

117 , testCatMaybe getTestDatabase

115 , testMaybeTable getTestDatabase

118 , testMaybeTable getTestDatabase

119+ , testAggregateMaybeTable getTestDatabase

116 , testNestedTables getTestDatabase

120 , testNestedTables getTestDatabase

117 , testMaybeTableApplicative getTestDatabase

121 , testMaybeTableApplicative getTestDatabase

118 , testLogicalFixities getTestDatabase

122 , testLogicalFixities getTestDatabase

119 , testUpdate getTestDatabase

123 , testUpdate getTestDatabase

120 , testDelete getTestDatabase

124 , testDelete getTestDatabase

125+ , testUpsert getTestDatabase

121 , testSelectNestedPairs getTestDatabase

126 , testSelectNestedPairs getTestDatabase

122 , testSelectArray getTestDatabase

127 , testSelectArray getTestDatabase

123 , testNestedMaybeTable getTestDatabase

128 , testNestedMaybeTable getTestDatabase

@@ -133,6 +138,7 @@ tests =

133 flip run conn do

138 flip run conn do

134 sql "CREATE EXTENSION citext"

139 sql "CREATE EXTENSION citext"

135 sql "CREATE TABLE test_table ( column1 text not null, column2 bool not null )"

140 sql "CREATE TABLE test_table ( column1 text not null, column2 bool not null )"

141+ sql "CREATE TABLE unique_table ( \"key\" text not null unique, \"value\" text not null )"

136 sql "CREATE SEQUENCE test_seq"

142 sql "CREATE SEQUENCE test_seq"

137

143

138 return db

144 return db

@@ -140,19 +146,21 @@ tests =

140 stopTestDatabase = TmpPostgres.stop

146 stopTestDatabase = TmpPostgres.stop

141

147

142

148

149+connect :: TmpPostgres.DB -> IO Connection

150+connect = acquire . TmpPostgres.toConnectionString >=> either (maybe empty (fail . unpack . decodeUtf8)) pure

151+

152+

143databasePropertyTest

153databasePropertyTest

144 :: TestName

154 :: TestName

145− -> (((Connection -> TestT IO ()) -> PropertyT IO ()) -> PropertyT IO ())

155+ -> ((TestT Transaction () -> PropertyT IO ()) -> PropertyT IO ())

146 -> IO TmpPostgres.DB -> TestTree

156 -> IO TmpPostgres.DB -> TestTree

147databasePropertyTest testName f getTestDatabase =

157databasePropertyTest testName f getTestDatabase =

148− withResource connect release $ \c ->

158+ withResource (connect =<< getTestDatabase) release $ \c ->

149 testProperty testName $ property do

159 testProperty testName $ property do

150− connection <- liftIO c

160+ connection <- lift c

151− f \g -> test $ rollingBack connection $ g connection

161+ f $ test . hoist \m -> do

152−

162+ e <- run (Hasql.transaction Hasql.Serializable Hasql.Write (m <* condemn)) connection

153− where

163+ either throwIO pure e

154−

155− connect = either (error . show) return =<< acquire . TmpPostgres.toConnectionString =<< getTestDatabase

156

164

157

165

158data TestTable f = TestTable

166data TestTable f = TestTable

@@ -184,18 +192,17 @@ testSelectTestTable :: IO TmpPostgres.DB -> TestTree

184testSelectTestTable = databasePropertyTest "Can SELECT TestTable" \transaction -> do

192testSelectTestTable = databasePropertyTest "Can SELECT TestTable" \transaction -> do

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

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

186

194

187− transaction \connection -> do

195+ transaction do

188− void do

196+ selected <- lift do

189− liftIO $ Rel8.insert connection

190− Rel8.Insert

197+ statement () $ Rel8.insert Rel8.Insert

191− { into = testTableSchema

198+ { into = testTableSchema

192− , rows = map Rel8.lit rows

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

193− , onConflict = Rel8.DoNothing

200+ , onConflict = Rel8.DoNothing

194− , returning = Rel8.NumberOfRowsAffected

201+ , returning = pure ()

195− }

202+ }

196

203

197− selected <- liftIO $ Rel8.select connection do

204+ statement () $ Rel8.select do

198− Rel8.each testTableSchema

205+ Rel8.each testTableSchema

199

206

200 sort selected === sort rows

207 sort selected === sort rows

201

208

@@ -212,11 +219,12 @@ testWhere_ = databasePropertyTest "WHERE (Rel8.where_)" \transaction -> do

212

219

213 let expected = filter (\t -> testTableColumn2 t == magicBool) rows

220 let expected = filter (\t -> testTableColumn2 t == magicBool) rows

214

221

215− transaction \connection -> do

222+ transaction do

223+ selected <- lift do

216− selected <- liftIO $ Rel8.select connection do

224+ statement () $ Rel8.select do

217− t <- Rel8.values $ Rel8.lit <$> rows

225+ t <- Rel8.values $ Rel8.lit <$> rows

218− Rel8.where_ $ testTableColumn2 t Rel8.==. Rel8.lit magicBool

226+ Rel8.where_ $ testTableColumn2 t Rel8.==. Rel8.lit magicBool

219− return t

227+ return t

220

228

221 sort selected === sort expected

229 sort selected === sort expected

222

230

@@ -229,11 +237,12 @@ testFilter :: IO TmpPostgres.DB -> TestTree

229testFilter = databasePropertyTest "filter" \transaction -> do

237testFilter = databasePropertyTest "filter" \transaction -> do

230 rows <- forAll $ Gen.list (Range.linear 1 10) genTestTable

238 rows <- forAll $ Gen.list (Range.linear 1 10) genTestTable

231

239

232− transaction \connection -> do

240+ transaction do

233 let expected = filter testTableColumn2 rows

241 let expected = filter testTableColumn2 rows

234

242

235− selected <- liftIO $ Rel8.select connection

243+ selected <- lift do

244+ statement () $ Rel8.select do

236− $ Rel8.filter testTableColumn2 =<< Rel8.values (Rel8.lit <$> rows)

245+ Rel8.filter testTableColumn2 =<< Rel8.values (Rel8.lit <$> rows)

237

246

238 sort selected === sort expected

247 sort selected === sort expected

239

248

@@ -248,9 +257,10 @@ testLimit = databasePropertyTest "LIMIT (Rel8.limit)" \transaction -> do

248

257

249 n <- forAll $ Gen.integral (Range.linear 0 10)

258 n <- forAll $ Gen.integral (Range.linear 0 10)

250

259

251− transaction \connection -> do

260+ transaction do

261+ selected <- lift do

252− selected <- liftIO $ Rel8.select connection do

262+ statement () $ Rel8.select do

253− Rel8.limit n $ Rel8.values (Rel8.lit <$> rows)

263+ Rel8.limit n $ Rel8.values (Rel8.lit <$> rows)

254

264

255 diff (length selected) (<=) (fromIntegral n)

265 diff (length selected) (<=) (fromIntegral n)

256

266

@@ -268,9 +278,10 @@ testUnion = databasePropertyTest "UNION (Rel8.union)" \transaction -> evalM do

268 left <- forAll $ Gen.list (Range.linear 0 10) genTestTable

278 left <- forAll $ Gen.list (Range.linear 0 10) genTestTable

269 right <- forAll $ Gen.list (Range.linear 0 10) genTestTable

279 right <- forAll $ Gen.list (Range.linear 0 10) genTestTable

270

280

271− transaction \connection -> do

281+ transaction do

282+ selected <- lift do

272− selected <- liftIO $ Rel8.select connection do

283+ statement () $ Rel8.select do

273− Rel8.values (Rel8.lit <$> nub left) `Rel8.union` Rel8.values (Rel8.lit <$> nub right)

284+ Rel8.values (Rel8.lit <$> nub left) `Rel8.union` Rel8.values (Rel8.lit <$> nub right)

274

285

275 sort selected === sort (nub (left ++ right))

286 sort selected === sort (nub (left ++ right))

276

287

@@ -279,9 +290,11 @@ testDistinct :: IO TmpPostgres.DB -> TestTree

279testDistinct = databasePropertyTest "DISTINCT (Rel8.distinct)" \transaction -> do

290testDistinct = databasePropertyTest "DISTINCT (Rel8.distinct)" \transaction -> do

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

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

281

292

282− transaction \connection -> do

293+ transaction do

294+ selected <- lift do

295+ statement () $ Rel8.select do

283− selected <- liftIO $ Rel8.select connection $ Rel8.distinct do

296+ Rel8.distinct do

284− Rel8.values (Rel8.lit <$> rows)

297+ Rel8.values (Rel8.lit <$> rows)

285

298

286 sort selected === nub (sort rows)

299 sort selected === nub (sort rows)

287

300

@@ -294,8 +307,10 @@ testExists :: IO TmpPostgres.DB -> TestTree

294testExists = databasePropertyTest "EXISTS (Rel8.exists)" \transaction -> do

307testExists = databasePropertyTest "EXISTS (Rel8.exists)" \transaction -> do

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

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

296

309

297− transaction \connection -> do

310+ transaction do

311+ exists <- lift do

312+ statement () $ Rel8.select do

298− exists <- liftIO $ Rel8.select connection $ Rel8.exists $ Rel8.values $ Rel8.lit <$> rows

313+ Rel8.exists $ Rel8.values $ Rel8.lit <$> rows

299

314

300 case rows of

315 case rows of

301 [] -> exists === [False]

316 [] -> exists === [False]

@@ -306,9 +321,10 @@ testOptional :: IO TmpPostgres.DB -> TestTree

306testOptional = databasePropertyTest "Rel8.optional" \transaction -> do

321testOptional = databasePropertyTest "Rel8.optional" \transaction -> do

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

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

308

323

309− transaction \connection -> do

324+ transaction do

325+ selected <- lift do

310− selected <- liftIO $ Rel8.select connection do

326+ statement () $ Rel8.select do

311− Rel8.optional $ Rel8.values (Rel8.lit <$> rows)

327+ Rel8.optional $ Rel8.values (Rel8.lit <$> rows)

312

328

313 case rows of

329 case rows of

314 [] -> selected === [Nothing]

330 [] -> selected === [Nothing]

@@ -319,9 +335,10 @@ testAnd :: IO TmpPostgres.DB -> TestTree

319testAnd = databasePropertyTest "AND (&&.)" \transaction -> do

335testAnd = databasePropertyTest "AND (&&.)" \transaction -> do

320 (x, y) <- forAll $ liftA2 (,) Gen.bool Gen.bool

336 (x, y) <- forAll $ liftA2 (,) Gen.bool Gen.bool

321

337

322− transaction \connection -> do

338+ transaction do

323− [result] <- liftIO $ Rel8.select connection $ pure $

339+ [result] <- lift do

340+ statement () $ Rel8.select do

324− Rel8.lit x Rel8.&&. Rel8.lit y

341+ pure $ Rel8.lit x Rel8.&&. Rel8.lit y

325

342

326 result === (x && y)

343 result === (x && y)

327

344

@@ -330,9 +347,10 @@ testOr :: IO TmpPostgres.DB -> TestTree

330testOr = databasePropertyTest "OR (||.)" \transaction -> do

347testOr = databasePropertyTest "OR (||.)" \transaction -> do

331 (x, y) <- forAll $ liftA2 (,) Gen.bool Gen.bool

348 (x, y) <- forAll $ liftA2 (,) Gen.bool Gen.bool

332

349

333− transaction \connection -> do

350+ transaction do

351+ [result] <- lift do

334− [result] <- liftIO $ Rel8.select connection $ pure $

352+ statement () $ Rel8.select $ pure $

335− Rel8.lit x Rel8.||. Rel8.lit y

353+ Rel8.lit x Rel8.||. Rel8.lit y

336

354

337 result === (x || y)

355 result === (x || y)

338

356

@@ -341,9 +359,10 @@ testLogicalFixities :: IO TmpPostgres.DB -> TestTree

341testLogicalFixities = databasePropertyTest "Logical operator fixities" \transaction -> do

359testLogicalFixities = databasePropertyTest "Logical operator fixities" \transaction -> do

342 (u, v, w, x) <- forAll $ (,,,) <$> Gen.bool <*> Gen.bool <*> Gen.bool <*> Gen.bool

360 (u, v, w, x) <- forAll $ (,,,) <$> Gen.bool <*> Gen.bool <*> Gen.bool <*> Gen.bool

343

361

344− transaction \connection -> do

362+ transaction do

345− [result] <- liftIO $ Rel8.select connection $ pure $

363+ [result] <- lift do

364+ statement () $ Rel8.select do

346− Rel8.lit u Rel8.||. Rel8.lit v Rel8.&&. Rel8.lit w Rel8.==. Rel8.lit x

365+ pure $ Rel8.lit u Rel8.||. Rel8.lit v Rel8.&&. Rel8.lit w Rel8.==. Rel8.lit x

347

366

348 result === (u || v && w == x)

367 result === (u || v && w == x)

349

368

@@ -352,9 +371,10 @@ testNot :: IO TmpPostgres.DB -> TestTree

352testNot = databasePropertyTest "NOT (not_)" \transaction -> do

371testNot = databasePropertyTest "NOT (not_)" \transaction -> do

353 x <- forAll Gen.bool

372 x <- forAll Gen.bool

354

373

355− transaction \connection -> do

374+ transaction do

356− [result] <- liftIO $ Rel8.select connection $ pure $

375+ [result] <- lift do

376+ statement () $ Rel8.select do

357− Rel8.not_ $ Rel8.lit x

377+ pure $ Rel8.not_ $ Rel8.lit x

358

378

359 result === not x

379 result === not x

360

380

@@ -363,9 +383,10 @@ testBool :: IO TmpPostgres.DB -> TestTree

363testBool = databasePropertyTest "ifThenElse_" \transaction -> do

383testBool = databasePropertyTest "ifThenElse_" \transaction -> do

364 (x, y, z) <- forAll $ liftA3 (,,) Gen.bool Gen.bool Gen.bool

384 (x, y, z) <- forAll $ liftA3 (,,) Gen.bool Gen.bool Gen.bool

365

385

366− transaction \connection -> do

386+ transaction do

367− [result] <- liftIO $ Rel8.select connection $ pure $

387+ [result] <- lift do

388+ statement () $ Rel8.select do

368− Rel8.bool (Rel8.lit z) (Rel8.lit y) (Rel8.lit x)

389+ pure $ Rel8.bool (Rel8.lit z) (Rel8.lit y) (Rel8.lit x)

369

390

370 result === if x then y else z

391 result === if x then y else z

371

392

@@ -377,9 +398,10 @@ testAp = databasePropertyTest "Cartesian product (<*>)" \transaction -> do

377 (Gen.list (Range.linear 1 10) genTestTable)

398 (Gen.list (Range.linear 1 10) genTestTable)

378 (Gen.list (Range.linear 1 10) genTestTable)

399 (Gen.list (Range.linear 1 10) genTestTable)

379

400

380− transaction \connection -> do

401+ transaction do

402+ result <- lift do

381− result <- liftIO $ Rel8.select connection $ do

403+ statement () $ Rel8.select do

382− liftA2 (,) (Rel8.values (Rel8.lit <$> rows1)) (Rel8.values (Rel8.lit <$> rows2))

404+ liftA2 (,) (Rel8.values (Rel8.lit <$> rows1)) (Rel8.values (Rel8.lit <$> rows2))

383

405

384 sort result === sort (liftA2 (,) rows1 rows2)

406 sort result === sort (liftA2 (,) rows1 rows2)

385

407

@@ -408,21 +430,22 @@ testDBType getTestDatabase = testGroup "DBType instances"

408 where

430 where

409 dbTypeTest :: (Eq a, Show a, Rel8.DBType a) => TestName -> Gen a -> TestTree

431 dbTypeTest :: (Eq a, Show a, Rel8.DBType a) => TestName -> Gen a -> TestTree

410 dbTypeTest name generator = testGroup name

432 dbTypeTest name generator = testGroup name

411− [ databasePropertyTest name (t (==) generator) getTestDatabase

433+ [ databasePropertyTest name (t generator) getTestDatabase

412− , databasePropertyTest ("Maybe " <> name) (t (==) (Gen.maybe generator)) getTestDatabase

434+ , databasePropertyTest ("Maybe " <> name) (t (Gen.maybe generator)) getTestDatabase

413 ]

435 ]

414

436

415− t :: forall a b. (Show a, Rel8.Sql Rel8.DBType a)

437+ t :: forall a b. (Eq a, Show a, Rel8.Sql Rel8.DBType a)

416− => (a -> a -> Bool)

417− -> Gen a

438+ => Gen a

418− -> ((Connection -> TestT IO ()) -> PropertyT IO b)

439+ -> (TestT Transaction () -> PropertyT IO b)

419 -> PropertyT IO b

440 -> PropertyT IO b

420− t eq generator transaction = do

441+ t generator transaction = do

421 x <- forAll generator

442 x <- forAll generator

422

443

423− transaction \connection -> do

444+ transaction do

445+ [res] <- lift do

446+ statement () $ Rel8.select do

424− [res] <- liftIO $ Rel8.select connection $ pure (Rel8.litExpr x)

447+ pure (Rel8.litExpr x)

425− diff res eq x

448+ diff res (==) x

426

449

427 genDay :: Gen Day

450 genDay :: Gen Day

428 genDay = do

451 genDay = do

@@ -464,13 +487,15 @@ testDBEq getTestDatabase = testGroup "DBEq instances"

464

487

465 t :: forall a. (Eq a, Show a, Rel8.Sql Rel8.DBEq a)

488 t :: forall a. (Eq a, Show a, Rel8.Sql Rel8.DBEq a)

466 => Gen a

489 => Gen a

467− -> ((Connection -> TestT IO ()) -> PropertyT IO ())

490+ -> (TestT Transaction () -> PropertyT IO ())

468 -> PropertyT IO ()

491 -> PropertyT IO ()

469 t generator transaction = do

492 t generator transaction = do

470 (x, y) <- forAll (liftA2 (,) generator generator)

493 (x, y) <- forAll (liftA2 (,) generator generator)

471

494

472− transaction \connection -> do

495+ transaction do

496+ [res] <- lift do

497+ statement () $ Rel8.select do

473− [res] <- liftIO $ Rel8.select connection $ pure $ Rel8.litExpr x Rel8.==. Rel8.litExpr y

498+ pure $ Rel8.litExpr x Rel8.==. Rel8.litExpr y

474 res === (x == y)

499 res === (x == y)

475

500

476

501

@@ -478,9 +503,10 @@ testTableEquality :: IO TmpPostgres.DB -> TestTree

478testTableEquality = databasePropertyTest "TestTable equality" \transaction -> do

503testTableEquality = databasePropertyTest "TestTable equality" \transaction -> do

479 (x, y) <- forAll $ liftA2 (,) genTestTable genTestTable

504 (x, y) <- forAll $ liftA2 (,) genTestTable genTestTable

480

505

481− transaction \connection -> do

506+ transaction do

507+ [eq] <- lift do

482− [eq] <- liftIO $ Rel8.select connection do

508+ statement () $ Rel8.select do

483− pure $ Rel8.lit x Rel8.==: Rel8.lit y

509+ pure $ Rel8.lit x Rel8.==: Rel8.lit y

484

510

485 eq === (x == y)

511 eq === (x == y)

486

512

@@ -489,8 +515,10 @@ testFromString :: IO TmpPostgres.DB -> TestTree

489testFromString = databasePropertyTest "FromString" \transaction -> do

515testFromString = databasePropertyTest "FromString" \transaction -> do

490 str <- forAll $ Gen.list (Range.linear 0 10) Gen.unicode

516 str <- forAll $ Gen.list (Range.linear 0 10) Gen.unicode

491

517

492− transaction \connection -> do

518+ transaction do

519+ [result] <- lift do

520+ statement () $ Rel8.select do

493− [result] <- liftIO $ Rel8.select connection $ pure $ fromString str

521+ pure $ fromString str

494 result === pack str

522 result === pack str

495

523

496

524

@@ -498,10 +526,11 @@ testCatMaybeTable :: IO TmpPostgres.DB -> TestTree

498testCatMaybeTable = databasePropertyTest "catMaybeTable" \transaction -> do

526testCatMaybeTable = databasePropertyTest "catMaybeTable" \transaction -> do

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

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

500

528

501− transaction \connection -> do

529+ transaction do

530+ selected <- lift do

502− selected <- liftIO $ Rel8.select connection do

531+ statement () $ Rel8.select do

503− testTable <- Rel8.values $ Rel8.lit <$> rows

532+ testTable <- Rel8.values $ Rel8.lit <$> rows

504− Rel8.catMaybeTable $ Rel8.bool Rel8.nothingTable (pure testTable) (testTableColumn2 testTable)

533+ Rel8.catMaybeTable $ Rel8.bool Rel8.nothingTable (pure testTable) (testTableColumn2 testTable)

505

534

506 sort selected === sort (filter testTableColumn2 rows)

535 sort selected === sort (filter testTableColumn2 rows)

507

536

@@ -510,9 +539,10 @@ testCatMaybe :: IO TmpPostgres.DB -> TestTree

510testCatMaybe = databasePropertyTest "catMaybe" \transaction -> evalM do

539testCatMaybe = databasePropertyTest "catMaybe" \transaction -> evalM do

511 rows <- forAll $ Gen.list (Range.linear 0 10) $ Gen.maybe Gen.bool

540 rows <- forAll $ Gen.list (Range.linear 0 10) $ Gen.maybe Gen.bool

512

541

513− transaction \connection -> do

542+ transaction do

514− selected <- evalM $ liftIO $ Rel8.select connection do

543+ selected <- lift do

544+ statement () $ Rel8.select do

515− Rel8.catNull =<< Rel8.values (map Rel8.lit rows)

545+ Rel8.catNull =<< Rel8.values (map Rel8.lit rows)

516

546

517 sort selected === sort (catMaybes rows)

547 sort selected === sort (catMaybes rows)

518

548

@@ -521,15 +551,38 @@ testMaybeTable :: IO TmpPostgres.DB -> TestTree

521testMaybeTable = databasePropertyTest "maybeTable" \transaction -> evalM do

551testMaybeTable = databasePropertyTest "maybeTable" \transaction -> evalM do

522 (rows, def) <- forAll $ liftA2 (,) (Gen.list (Range.linear 0 10) genTestTable) genTestTable

552 (rows, def) <- forAll $ liftA2 (,) (Gen.list (Range.linear 0 10) genTestTable) genTestTable

523

553

524− transaction \connection -> do

554+ transaction do

525− selected <- liftIO $ Rel8.select connection $

555+ selected <- lift do

556+ statement () $ Rel8.select do

526− Rel8.maybeTable (Rel8.lit def) id <$> Rel8.optional (Rel8.values (Rel8.lit <$> rows))

557+ Rel8.maybeTable (Rel8.lit def) id <$> Rel8.optional (Rel8.values (Rel8.lit <$> rows))

527

558

528 case rows of

559 case rows of

529 [] -> selected === [def]

560 [] -> selected === [def]

530 _ -> sort selected === sort rows

561 _ -> sort selected === sort rows

531

562

532

563

564+testAggregateMaybeTable :: IO TmpPostgres.DB -> TestTree

565+testAggregateMaybeTable = databasePropertyTest "aggregateMaybeTable" \transaction -> evalM do

566+ rows <- forAll $ Gen.list (Range.linear 0 10) (Gen.maybe (Gen.int64 (Range.linear 0 10)))

567+

568+ let

569+ aggregate = go 0 False False

570+ where

571+ go !n nothing _ (Just a : as) = go (n + a) nothing True as

572+ go n _ just (Nothing : as) = go n True just as

573+ go _ False False [] = []

574+ go _ True False [] = [Nothing]

575+ go n False True [] = [Just n]

576+ go n True True [] = [Nothing, Just n]

577+

578+ transaction do

579+ selected <- lift do

580+ statement () $ Rel8.select do

581+ Rel8.aggregate $ Rel8.aggregateMaybeTable Rel8.sum <$> Rel8.values (Rel8.lit <$> rows)

582+

583+ sort selected === aggregate rows

584+

585+

533data TwoTestTables f =

586data TwoTestTables f =

534 TwoTestTables

587 TwoTestTables

535 { testTable1 :: TestTable f

588 { testTable1 :: TestTable f

@@ -550,9 +603,10 @@ testNestedTables = databasePropertyTest "Nested TestTables" \transaction -> eval

550 Gen.list (Range.linear 0 10) $

603 Gen.list (Range.linear 0 10) $

551 liftA2 TwoTestTables genTestTable genTestTable

604 liftA2 TwoTestTables genTestTable genTestTable

552

605

553− transaction \connection -> do

606+ transaction do

607+ selected <- lift do

554− selected <- liftIO $ Rel8.select connection do

608+ statement () $ Rel8.select do

555− Rel8.values (Rel8.lit <$> rows)

609+ Rel8.values (Rel8.lit <$> rows)

556

610

557 sort selected === sort rows

611 sort selected === sort rows

558

612

@@ -562,11 +616,12 @@ testMaybeTableApplicative = databasePropertyTest "MaybeTable (<*>)" \transaction

562 rows1 <- genRows

616 rows1 <- genRows

563 rows2 <- genRows

617 rows2 <- genRows

564

618

565− transaction \connection -> do

619+ transaction do

620+ selected <- lift do

566− selected <- liftIO $ Rel8.select connection do

621+ statement () $ Rel8.select do

567− as <- Rel8.optional (Rel8.values (Rel8.lit <$> rows1))

622+ as <- Rel8.optional (Rel8.values (Rel8.lit <$> rows1))

568− bs <- Rel8.optional (Rel8.values (Rel8.lit <$> rows2))

623+ bs <- Rel8.optional (Rel8.values (Rel8.lit <$> rows2))

569− pure $ liftA2 (,) as bs

624+ pure $ liftA2 (,) as bs

570

625

571 case (rows1, rows2) of

626 case (rows1, rows2) of

572 ([], []) -> selected === [Nothing]

627 ([], []) -> selected === [Nothing]

@@ -578,14 +633,6 @@ testMaybeTableApplicative = databasePropertyTest "MaybeTable (<*>)" \transaction

578 genRows = forAll do

633 genRows = forAll do

579 Gen.list (Range.linear 0 10) $ liftA2 TestTable (Gen.text (Range.linear 0 10) Gen.unicode) (pure True)

634 Gen.list (Range.linear 0 10) $ liftA2 TestTable (Gen.text (Range.linear 0 10) Gen.unicode) (pure True)

580

635

581−rollingBack

582− :: (MonadBaseControl IO m, MonadIO m)

583− => Connection -> m a -> m a

584−rollingBack connection =

585− bracket_

586− (liftIO (run (sql "BEGIN") connection))

587− (liftIO (run (sql "ROLLBACK") connection))

588−

589

636

590genTestTable :: Gen (TestTable Result)

637genTestTable :: Gen (TestTable Result)

591genTestTable = do

638genTestTable = do

@@ -598,19 +645,19 @@ testUpdate :: IO TmpPostgres.DB -> TestTree

598testUpdate = databasePropertyTest "Can UPDATE TestTable" \transaction -> do

645testUpdate = databasePropertyTest "Can UPDATE TestTable" \transaction -> do

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

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

600

647

601− transaction \connection -> do

648+ transaction do

602− void $ liftIO $ Rel8.insert connection

649+ selected <- lift do

603− Rel8.Insert

650+ statement () $ Rel8.insert Rel8.Insert

604 { into = testTableSchema

651 { into = testTableSchema

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

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

606 , onConflict = Rel8.DoNothing

653 , onConflict = Rel8.DoNothing

607− , returning = Rel8.NumberOfRowsAffected

654+ , returning = pure ()

608 }

655 }

609

656

610− void $ liftIO $ Rel8.update connection

611− Rel8.Update

657+ statement () $ Rel8.update Rel8.Update

612 { target = testTableSchema

658 { target = testTableSchema

659+ , from = pure ()

613− , set = \r ->

660+ , set = \_ r ->

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

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

615 in

662 in

616 foldl

663 foldl

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

624 )

671 )

625 r

672 r

626 updates

673 updates

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

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

628− , returning = Rel8.NumberOfRowsAffected

675+ , returning = pure ()

629 }

676 }

630

677

631− selected <- liftIO $ Rel8.select connection do

678+ statement () $ Rel8.select do

632− Rel8.each testTableSchema

679+ Rel8.each testTableSchema

633

680

634 sort selected === sort (Map.elems rows)

681 sort selected === sort (Map.elems rows)

635

682

@@ -642,29 +689,96 @@ testDelete :: IO TmpPostgres.DB -> TestTree

642testDelete = databasePropertyTest "Can DELETE TestTable" \transaction -> do

689testDelete = databasePropertyTest "Can DELETE TestTable" \transaction -> do

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

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

644

691

645− transaction \connection -> do

692+ transaction do

646− void $ liftIO $ Rel8.insert connection

693+ (deleted, selected) <- lift do

647− Rel8.Insert

694+ statement () $ Rel8.insert Rel8.Insert

648 { into = testTableSchema

695 { into = testTableSchema

649− , rows = map Rel8.lit rows

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

650 , onConflict = Rel8.DoNothing

697 , onConflict = Rel8.DoNothing

651− , returning = Rel8.NumberOfRowsAffected

698+ , returning = pure ()

652 }

699 }

653

700

654− deleted <-

655− liftIO $ Rel8.delete connection

656− Rel8.Delete

701+ deleted <- statement () $ Rel8.delete Rel8.Delete

657 { from = testTableSchema

702 { from = testTableSchema

703+ , using = pure ()

658− , deleteWhere = testTableColumn2

704+ , deleteWhere = const testTableColumn2

659 , returning = Rel8.Projection id

705 , returning = Rel8.Projection id

660 }

706 }

661

707

662− selected <- liftIO $ Rel8.select connection do

708+ selected <- statement () $ Rel8.select do

663− Rel8.each testTableSchema

709+ Rel8.each testTableSchema

710+

711+ pure (deleted, selected)

664

712

665 sort (deleted <> selected) === sort rows

713 sort (deleted <> selected) === sort rows

666

714

667

715

716+data UniqueTable f = UniqueTable

717+ { uniqueTableKey :: Rel8.Column f Text

718+ , uniqueTableValue :: Rel8.Column f Text

719+ }

720+ deriving stock Generic

721+ deriving anyclass Rel8.Rel8able

722+

723+

724+deriving stock instance Eq (UniqueTable Result)

725+deriving stock instance Ord (UniqueTable Result)

726+deriving stock instance Show (UniqueTable Result)

727+

728+

729+uniqueTableSchema :: Rel8.TableSchema (UniqueTable Rel8.Name)

730+uniqueTableSchema =

731+ Rel8.TableSchema

732+ { name = "unique_table"

733+ , schema = Nothing

734+ , columns = UniqueTable

735+ { uniqueTableKey = "key"

736+ , uniqueTableValue = "value"

737+ }

738+ }

739+

740+

741+genUniqueTable :: Gen (UniqueTable Result)

742+genUniqueTable = do

743+ uniqueTableKey <- Gen.text (Range.linear 0 5) Gen.alphaNum

744+ uniqueTableValue <- Gen.text (Range.linear 0 5) Gen.alphaNum

745+ pure UniqueTable {..}

746+

747+

748+testUpsert :: IO TmpPostgres.DB -> TestTree

749+testUpsert = databasePropertyTest "Can UPSERT UniqueTable" \transaction -> do

750+ as <- unique $ forAll $ Gen.list (Range.linear 0 20) genUniqueTable

751+ bs <- unique $ forAll $ Gen.list (Range.linear 0 20) genUniqueTable

752+

753+ transaction do

754+ selected <- lift do

755+ statement () $ Rel8.insert Rel8.Insert

756+ { into = uniqueTableSchema

757+ , rows = Rel8.values $ Rel8.lit <$> as

758+ , onConflict = Rel8.DoNothing

759+ , returning = pure ()

760+ }

761+

762+ statement () $ Rel8.insert Rel8.Insert

763+ { into = uniqueTableSchema

764+ , rows = Rel8.values $ Rel8.lit <$> bs

765+ , onConflict = Rel8.DoUpdate Rel8.Upsert

766+ { index = uniqueTableKey

767+ , set = \UniqueTable {uniqueTableValue} old -> old {uniqueTableValue}

768+ , updateWhere = \_ _ -> Rel8.true

769+ }

770+ , returning = pure ()

771+ }

772+

773+ statement () $ Rel8.select do

774+ Rel8.each uniqueTableSchema

775+

776+ fromUniqueTables selected === fromUniqueTables bs <> fromUniqueTables as

777+ where

778+ unique = fmap (nubOrdOn uniqueTableKey)

779+ fromUniqueTables = Map.fromList . map \(UniqueTable key value) -> (key, value)

780+

781+

668newtype HKNestedPair f = HKNestedPair { pairOne :: (TestTable f, TestTable f) }

782newtype HKNestedPair f = HKNestedPair { pairOne :: (TestTable f, TestTable f) }

669 deriving stock Generic

783 deriving stock Generic

670 deriving anyclass Rel8.Rel8able

784 deriving anyclass Rel8.Rel8able

@@ -678,9 +792,10 @@ testSelectNestedPairs :: IO TmpPostgres.DB -> TestTree

678testSelectNestedPairs = databasePropertyTest "Can SELECT nested pairs" \transaction -> do

792testSelectNestedPairs = databasePropertyTest "Can SELECT nested pairs" \transaction -> do

679 rows <- forAll $ Gen.list (Range.linear 0 10) $ HKNestedPair <$> liftA2 (,) genTestTable genTestTable

793 rows <- forAll $ Gen.list (Range.linear 0 10) $ HKNestedPair <$> liftA2 (,) genTestTable genTestTable

680

794

681− transaction \connection -> do

795+ transaction do

796+ selected <- lift do

682− selected <- liftIO $ Rel8.select connection do

797+ statement () $ Rel8.select do

683− Rel8.values $ map Rel8.lit rows

798+ Rel8.values $ map Rel8.lit rows

684

799

685 sort selected === sort rows

800 sort selected === sort rows

686

801

@@ -689,18 +804,20 @@ testSelectArray :: IO TmpPostgres.DB -> TestTree

689testSelectArray = databasePropertyTest "Can SELECT Arrays (with aggregation)" \transaction -> do

804testSelectArray = databasePropertyTest "Can SELECT Arrays (with aggregation)" \transaction -> do

690 rows <- forAll $ Gen.list (Range.linear 1 10) Gen.bool

805 rows <- forAll $ Gen.list (Range.linear 1 10) Gen.bool

691

806

692− transaction \connection -> do

807+ transaction do

808+ selected <- lift do

693− selected <- liftIO $ Rel8.select connection do

809+ statement () $ Rel8.select do

694− Rel8.many $ Rel8.values (map Rel8.lit rows)

810+ Rel8.many $ Rel8.values (map Rel8.lit rows)

695

811

696 selected === [foldMap pure rows]

812 selected === [foldMap pure rows]

697

813

814+ selected' <- lift do

698− selected' <- liftIO $ Rel8.select connection $ do

815+ statement () $ Rel8.select do

699− a <- Rel8.catListTable =<< do

816+ a <- Rel8.catListTable =<< do

700− Rel8.many $ Rel8.values (map Rel8.lit rows)

817+ Rel8.many $ Rel8.values (map Rel8.lit rows)

701− b <- Rel8.catListTable =<< do

818+ b <- Rel8.catListTable =<< do

702− Rel8.many $ Rel8.values (map Rel8.lit rows)

819+ Rel8.many $ Rel8.values (map Rel8.lit rows)

703− pure (a, b)

820+ pure (a, b)

704

821

705 selected' === liftA2 (,) rows rows

822 selected' === liftA2 (,) rows rows

706

823

@@ -722,10 +839,11 @@ testNestedMaybeTable :: IO TmpPostgres.DB -> TestTree

722testNestedMaybeTable = databasePropertyTest "Can nest MaybeTable within other tables" \transaction -> do

839testNestedMaybeTable = databasePropertyTest "Can nest MaybeTable within other tables" \transaction -> do

723 let example = NestedMaybeTable { nmt1 = True, nmt2 = Just (TestTable "Hi" True) }

840 let example = NestedMaybeTable { nmt1 = True, nmt2 = Just (TestTable "Hi" True) }

724

841

725− transaction \connection -> do

842+ transaction do

843+ selected <- lift do

726− selected <- liftIO $ Rel8.select connection do

844+ statement () $ Rel8.select do

727− x <- Rel8.values [Rel8.lit example]

845+ x <- Rel8.values [Rel8.lit example]

728− pure $ Rel8.maybeTable (Rel8.lit False) (\_ -> Rel8.lit True) (nmt2 x)

846+ pure $ Rel8.maybeTable (Rel8.lit False) (\_ -> Rel8.lit True) (nmt2 x)

729

847

730 selected === [True]

848 selected === [True]

731

849

@@ -733,11 +851,12 @@ testNestedMaybeTable = databasePropertyTest "Can nest MaybeTable within other ta

733testEvaluate :: IO TmpPostgres.DB -> TestTree

851testEvaluate :: IO TmpPostgres.DB -> TestTree

734testEvaluate = databasePropertyTest "evaluate has the evaluation order we expect" \transaction -> do

852testEvaluate = databasePropertyTest "evaluate has the evaluation order we expect" \transaction -> do

735

853

736− transaction \connection -> do

854+ transaction do

855+ selected <- lift do

737− selected <- liftIO $ Rel8.select connection do

856+ statement () $ Rel8.select do

738− x <- Rel8.values (Rel8.lit <$> ['a', 'b', 'c'])

857+ x <- Rel8.values (Rel8.lit <$> ['a', 'b', 'c'])

739− y <- Rel8.evaluate (Rel8.nextval "test_seq")

858+ y <- Rel8.evaluate (Rel8.nextval "test_seq")

740− pure (x, (y, y))

859+ pure (x, (y, y))

741

860

742 normalize selected ===

861 normalize selected ===

743 [ ('a', (0, 0))

862 [ ('a', (0, 0))

@@ -745,11 +864,12 @@ testEvaluate = databasePropertyTest "evaluate has the evaluation order we expect

745 , ('c', (2, 2))

864 , ('c', (2, 2))

746 ]

865 ]

747

866

867+ selected' <- lift do

748− selected' <- liftIO $ Rel8.select connection do

868+ statement () $ Rel8.select do

749− x <- Rel8.values (Rel8.lit <$> ['a', 'b', 'c'])

869+ x <- Rel8.values (Rel8.lit <$> ['a', 'b', 'c'])

750− y <- Rel8.values (Rel8.lit <$> ['d', 'e', 'f'])

870+ y <- Rel8.values (Rel8.lit <$> ['d', 'e', 'f'])

751− z <- Rel8.evaluate (Rel8.nextval "test_seq")

871+ z <- Rel8.evaluate (Rel8.nextval "test_seq")

752− pure ((x, y), (z, z))

872+ pure ((x, y), (z, z))

753

873

754 normalize selected' ===

874 normalize selected' ===

755 [ (('a', 'd'), (0, 0))

875 [ (('a', 'd'), (0, 0))

@@ -767,13 +887,3 @@ testEvaluate = databasePropertyTest "evaluate has the evaluation order we expect

767 normalize :: [(x, (Int64, Int64))] -> [(x, (Int64, Int64))]

887 normalize :: [(x, (Int64, Int64))] -> [(x, (Int64, Int64))]

768 normalize [] = []

888 normalize [] = []

769 normalize xs@((_, (i, _)) : _) = map (fmap (\(a, b) -> (a - i, b - i))) xs

889 normalize xs@((_, (i, _)) : _) = map (fmap (\(a, b) -> (a - i, b - i))) xs

770−

771−{-

772− selected <- liftIO $ Rel8.select connection do

773− x <- Rel8.values (Rel8.lit <$> ['a', 'b', 'c'])

774− x <- Rel8.values (Rel8.lit <$> ['d', 'e', 'f'])

775− y <- Rel8.evaluate (Rel8.nextval "test_seq")

776− pure (x, y, y)

777−

778− selected === [('a', 1, 1), ('b', 2, 2), ('c', 3, 3)]

779−-}

tests/Rel8/Generic/Rel8able/Test.hs+17

@@ -5,6 +5,7 @@

5{-# language DuplicateRecordFields #-}

6{-# language FlexibleInstances #-}

7{-# language MultiParamTypeClasses #-}

8+{-# language StandaloneKindSignatures #-}

8{-# language TypeFamilies #-}

9{-# language TypeFamilies #-}

9{-# language UndecidableInstances #-}

10{-# language UndecidableInstances #-}

@@ -169,3 +170,19 @@ data NestedTableTestB f = NestedTableTestB

169 }

170 }

170 deriving stock Generic

171 deriving stock Generic

171 deriving anyclass Rel8able

172 deriving anyclass Rel8able

173+

174+

175+newtype IdRecord a f = IdRecord { recordId :: Column f a }

176+ deriving stock Generic

177+

178+

179+instance DBType a => Rel8able (IdRecord a)

180+

181+

182+type Nest :: KRel8able -> KRel8able -> KRel8able

183+data Nest t u f = Nest

184+ { foo :: t f

185+ , bar :: u f

186+ }

187+ deriving stock Generic

188+ deriving anyclass Rel8able