master..5d2b9e4 · rel8

git.iko.soy/rel8

74 files changed+651−2475

unifiedsplit

.github/workflows/build.yaml+3−3 Changelog.md+10−112 cabal.project+5 cabal.project.haskell-nix+6 default.nix+2−2 docs/cookbook.rst+7−9 nix/sources.json+9−9 nix/sources.nix+1−21 rel8.cabal+8−22 shell.nix+1−1 src/Rel8.hs+8−277 src/Rel8/Aggregate.hs+43−19 src/Rel8/Column/Null.hs−26 src/Rel8/Expr.hs−1 src/Rel8/Expr/Aggregate.hs+64−25 src/Rel8/Expr/Num.hs+6−39 src/Rel8/Expr/Opaleye.hs+3−12 src/Rel8/Expr/Sequence.hs+1−2 src/Rel8/Expr/Text.hs+2−23 src/Rel8/Expr/Window.hs−121 src/Rel8/Generic/Construction/ADT.hs−1 src/Rel8/Generic/Record.hs−2 src/Rel8/Generic/Rel8able.hs+1−6 src/Rel8/Generic/Table/ADT.hs−1 src/Rel8/Order.hs+8−1 src/Rel8/Query.hs+9−28 src/Rel8/Query/Aggregate.hs−19 src/Rel8/Query/Distinct.hs+9−4 src/Rel8/Query/Evaluate.hs+22−3 src/Rel8/Query/Exists.hs+1−1 src/Rel8/Query/Indexed.hs−21 src/Rel8/Query/List.hs+7−9 src/Rel8/Query/Null.hs−15 src/Rel8/Query/Opaleye.hs+10−18 src/Rel8/Query/Rebind.hs−27 src/Rel8/Query/SQL.hs+1−1 src/Rel8/Query/Set.hs+6−6 src/Rel8/Query/These.hs+8−8 src/Rel8/Query/Window.hs−26 src/Rel8/Schema/Context/Nullify.hs+14−6 src/Rel8/Schema/HTable.hs+2−29 src/Rel8/Schema/HTable/Vectorize.hs+2−10 src/Rel8/Schema/Table.hs−3 src/Rel8/Statement/Delete.hs+27−20 src/Rel8/Statement/Insert.hs+28−18 src/Rel8/Statement/Returning.hs+7 src/Rel8/Statement/SQL.hs+3−3 src/Rel8/Statement/Select.hs+29−57 src/Rel8/Statement/Update.hs+26−18 src/Rel8/Statement/View.hs+17−32 src/Rel8/Table/Aggregate.hs−12 src/Rel8/Table/HKD.hs−1 src/Rel8/Table/List.hs+3−14 src/Rel8/Table/Maybe.hs−6 src/Rel8/Table/NonEmpty.hs+3−14 src/Rel8/Table/Null.hs−147 src/Rel8/Table/Nullify.hs−27 src/Rel8/Table/Opaleye.hs+47−31 src/Rel8/Table/Ord.hs+2−2 src/Rel8/Table/Projection.hs+1−1 src/Rel8/Table/These.hs+3−14 src/Rel8/Table/Window.hs−43 src/Rel8/Tabulate.hs−640 src/Rel8/Type.hs+8−9 src/Rel8/Type/Enum.hs−1 src/Rel8/Type/JSONBEncoded.hs−4 src/Rel8/Type/JSONEncoded.hs−4 src/Rel8/Type/Num.hs+1−4 src/Rel8/Type/Ord.hs+2 src/Rel8/Type/ReadShow.hs−3 src/Rel8/Type/Tag.hs−1 src/Rel8/Window.hs−97 tests/Main.hs+164−273 tests/Rel8/Generic/Rel8able/Test.hs+1−10

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

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

99 persist-credentials: false

1010 submodules: true

1111

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

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

1313 with:

1414 nix_path: nixpkgs=channel:nixos-unstable

1515 extra_nix_config: |

1616 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://cache.iog.io

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

1818

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

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

2020 with:

2121 name: rel8

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

Changelog.md+10−112

@@ -1,90 +1,20 @@

1−# 1.4.0.0 (2002-08-17)

1+# 1.1.0.0 (??)

33## Breaking changes

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

6−

7−## New features

8−

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

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

786

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

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

808

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

9+* The `Labelable` type class has been removed as it's no longer necessary. This class was mostly internal, though was visible in some public API functions. ([#76](https://github.com/circuithub/rel8/pull/76))

8210

83−## Breaking changes

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

8412

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

13+* 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.

8614

87−# 1.1.0.0 (2021-07-16)

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

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

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

8818

8919## New features

9020

@@ -96,45 +26,13 @@

9626 , myTableY :: f Text

9727 } deriving (Generic, Rel8able)

9828 ```

99−

29+

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

10131

10232 ```haskell

10333 x <- project myTableX <$> many ...

10434 ```

10535

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−

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

123−

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

125−

126−* The `Labelable` type class has been removed as it's no longer necessary. This class was mostly internal, though was visible in some public API functions. ([#76](https://github.com/circuithub/rel8/pull/76))

127−

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−

13836## Bug fixes

13937

14038* 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 +1,6 @@

11packages: .

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,3 +2,9 @@

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

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

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

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

11let

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

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

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

66 nixpkgsArgs = haskellNix.nixpkgsArgs;

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

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

1010 pkgs = import nixpkgsSrc nixpkgsArgs;

1111

docs/cookbook.rst+7−9

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

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

143143posts. We want our query to return:

144144

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

145+1. The latest 5 blog posts.

1461462. For each blog post, all tags.

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

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

148148

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

150150

151151 latestBlogPosts = do

152152 post <- each postSchema

153153

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

155− tags <- some $ do

154+ tags <- aggregate do

156155 tag <- each tagSchema

157156 where_ (tagPostId tag ==. postId post)

158− return (tagName tag)

157+ return (listAgg (tagName tag))

159158

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

161− latestComments <-

162− many $

163− limit 3 $

159+ latestComments <-

160+ many $

161+ limit 3 $

164162 orderBy (commentCreatedAt >$< desc) do

165163 comment <- each commentSchema

166164 where_ (commentPostId comment ==. postId post)

nix/sources.json+9−9

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

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

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

77 "repo": "haskell.nix",

8− "rev": "0837156c56cb5350dd9bd84eb424187e00aa1e8a",

9− "sha256": "1djmv5a0vfj78csw2cad6nicrs8iqrp928b9b3v4h7lwwhhzliwl",

8+ "rev": "3856d2d24dca0ecc71fcfc314253a2a2d07a3c4f",

9+ "sha256": "0s69nasqhkv8n0qmdv075k83p3z584ja9vkzdnp2291mymghvx87",

1010 "type": "tarball",

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

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

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

1313 },

1414 "niv": {

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

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

1818 "owner": "nmattia",

1919 "repo": "niv",

20− "rev": "acdb1726783637852c01e0ad639ac9cbec28d8c8",

21− "sha256": "1wszl8q70z6wfgkh2dvgmhhry6qp9nar421qq2ifd17hq2jj9ck3",

20+ "rev": "e0ca65c81a2d7a4d82a189f1e23a48d59ad42070",

21+ "sha256": "1pq9nh1d8nn3xvbdny8fafzw87mj7gsmp6pxkdl65w2g18rmcmzx",

2222 "type": "tarball",

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

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

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

2525 },

2626 "nixpkgs": {

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

2929 "homepage": null,

3030 "owner": "nixos",

3131 "repo": "nixpkgs",

32− "rev": "1c1f5649bb9c1b0d98637c8c365228f57126f361",

33− "sha256": "0f2nvdijyxfgl5kwyb4465pppd5vkhqxddx6v40k2s0z9jfhj0xl",

32+ "rev": "59b8d9cf24e9fcf10341a0923c9bdca088dca8c8",

33+ "sha256": "08f38v4b2kcxnbapdwrb54bglka92cxj9qlnqlk5px206jyq9v4c",

3434 "type": "tarball",

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

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

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

3737 }

3838}

nix/sources.nix+1−21

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

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

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

3333 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;

5334 in

54− builtins.fetchGit

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

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

5636

5737 fetch_local = spec: spec.path;

5838

rel8.cabal+8−22

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

11cabal-version: 2.0

22name: rel8

3−version: 1.4.0.0

3+version: 1.0.0.1

44synopsis: Hey! Hey! Can u rel8?

55license: BSD3

66license-file: LICENSE

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

2020library

2121 build-depends:

2222 aeson

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

24− , bifunctors

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

2524 , bytestring

2625 , case-insensitive

2726 , comonad

2827 , contravariant

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

30− , opaleye ^>= 0.9.6.1

28+ , hasql ^>= 1.4.5.1

29+ , opaleye ^>= 0.7.3.0

3130 , pretty

3231 , profunctors

33− , product-profunctors

3432 , scientific

3533 , semialign

3634 , semigroupoids

3735 , text

3836 , these

3937 , time

38+ , transformers

4039 , uuid

4140 default-language:

4241 Haskell2010

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

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

4746 -Wno-monomorphism-restriction

4847 -Wno-missing-local-signatures

49− -Wno-missing-kind-signatures

5048 hs-source-dirs:

5149 src

5250 exposed-modules:

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

5452 Rel8.Expr.Num

5553 Rel8.Expr.Text

5654 Rel8.Expr.Time

57− Rel8.Tabulate

5855

5956 other-modules:

6057 Rel8.Aggregate

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

6663 Rel8.Column.List

6764 Rel8.Column.Maybe

6865 Rel8.Column.NonEmpty

69− Rel8.Column.Null

7066 Rel8.Column.These

7167

7268 Rel8.Expr

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

8278 Rel8.Expr.Order

8379 Rel8.Expr.Sequence

8480 Rel8.Expr.Serialize

85− Rel8.Expr.Window

8681

8782 Rel8.FCF

8883

@@ -109,19 +104,16 @@ library

109104 Rel8.Query.Evaluate

110105 Rel8.Query.Exists

111106 Rel8.Query.Filter

112− Rel8.Query.Indexed

113107 Rel8.Query.Limit

114108 Rel8.Query.List

115109 Rel8.Query.Maybe

116110 Rel8.Query.Null

117111 Rel8.Query.Opaleye

118112 Rel8.Query.Order

119− Rel8.Query.Rebind

120113 Rel8.Query.Set

121114 Rel8.Query.SQL

122115 Rel8.Query.These

123116 Rel8.Query.Values

124− Rel8.Query.Window

125117

126118 Rel8.Schema.Context.Nullify

127119 Rel8.Schema.Dict

@@ -170,7 +162,6 @@ library

170162 Rel8.Table.Maybe

171163 Rel8.Table.Name

172164 Rel8.Table.NonEmpty

173− Rel8.Table.Null

174165 Rel8.Table.Nullify

175166 Rel8.Table.Opaleye

176167 Rel8.Table.Ord

@@ -181,7 +172,6 @@ library

181172 Rel8.Table.These

182173 Rel8.Table.Transpose

183174 Rel8.Table.Undefined

184− Rel8.Table.Window

185175

186176 Rel8.Type

187177 Rel8.Type.Array

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

200190 Rel8.Type.Sum

201191 Rel8.Type.Tag

202192

203− Rel8.Window

204−

205−

206193test-suite tests

207194 type: exitcode-stdio-1.0

208195 build-depends:

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

211198 , case-insensitive

212199 , containers

213200 , hasql

214− , hasql-transaction

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

216− , mmorph

201+ , hedgehog ^>=1.0.2

202+ , lifted-base ^>=0.2.3.12

203+ , monad-control ^>=1.0.2.3

217204 , rel8

218205 , scientific

219206 , tasty

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

221208 , text

222209 , time

223210 , tmp-postgres ^>=1.34.1.0

224− , transformers

225211 , uuid

226212

227213 other-modules:

shell.nix+1−1

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

11let

22 sources = import ./nix/sources.nix;

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

3+ pkgs = import sources.nixpkgs {};

44 hsPkgs = import ./default.nix;

55in

66 hsPkgs.shellFor {

src/Rel8.hs+8−277

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

3838 , HMaybe

3939 , HList

4040 , HNonEmpty

41− , HNull

4241 , HThese

4342 , Lift

4443

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

4746 , Transposes

4847 , AltTable((<|>:))

4948 , AlternativeTable( emptyTable )

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

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

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

50+ , OrdTable, ascTable, descTable

5251 , lit

5352 , bool

5453 , case_

55− , castTable

5654

5755 -- ** @MaybeTable@

5856 , MaybeTable

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

6058 , isNothingTable, isJustTable

61− , fromMaybeTable

6259 , optional

6360 , catMaybeTable

6461 , traverseMaybeTable

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

8178 , isThisTable, isThatTable, isThoseTable

8279 , hasHereTable, hasThereTable

8380 , justHereTable, justThereTable

84− , alignMaybeTable

8581 , alignBy

8682 , keepHereTable, loseHereTable

8783 , keepThereTable, loseThereTable

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

9490

9591 -- ** @ListTable@

9692 , ListTable

97− , listTable, ($*)

93+ , listTable

9894 , nameListTable

9995 , many

10096 , manyExpr

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

10399

104100 -- ** @NonEmptyTable@

105101 , NonEmptyTable

106− , nonEmptyTable, ($+)

102+ , nonEmptyTable

107103 , nameNonEmptyTable

108104 , some

109105 , someExpr

110106 , catNonEmptyTable

111107 , catNonEmpty

112108

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

109+ -- ** @ADT@

127110 , ADT, ADTable

128−

129− -- *** Deconstruction of ADTs

130− -- $deconstruction

131− , DeconstructADT, deconstructADT

132−

133− -- *** Construction of ADTs

134− -- $construction

135111 , BuildADT, buildADT

136112 , ConstructADT, constructADT

137−

138− -- *** Other ADT operations

113+ , DeconstructADT, deconstructADT

114+ , NameADT, nameADT

139115 , AggregateADT, aggregateADT

140116

141− -- *** Miscellaneous notes

142− -- $misc-notes

143−

144117 -- ** @HKD@

145118 , HKD, HKDable

146119 , BuildHKD, buildHKD

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

165138 -- ** @null@

166139 , NotNull

167140 , Nullable

168− , Homonullable

169141 , null

170142 , nullify

171143 , nullable

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

184156 , (==.), (/=.), (==?), (/=?)

185157 , in_

186158 , boolExpr, caseExpr

187− , like, ilike

188159

189160 -- ** Ordering

190161 , DBOrd

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

253224 , countRows

254225 , groupBy

255226 , listAgg, listAggExpr

256− , mode

257227 , nonEmptyAgg, nonEmptyAggExpr

258228 , DBMax, max

259229 , DBMin, min

260− , DBSum, sum, sumWhere, avg

230+ , DBSum, sum, sumWhere

261231 , DBString, stringAgg

262232 , count

263233 , countStar

@@ -274,29 +244,6 @@ module Rel8

274244 , nullsFirst

275245 , nullsLast

276246

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−

300247 -- ** Bindings

301248 , rebind

302249

@@ -334,7 +281,6 @@ module Rel8

334281

335282 -- ** @CREATE VIEW@

336283 , createView

337− , createOrReplaceView

338284

339285 -- ** Sequences

340286 , nextval

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

353299import Rel8.Column.List

354300import Rel8.Column.Maybe

355301import Rel8.Column.NonEmpty

356−import Rel8.Column.Null

357302import Rel8.Column.These

358303import Rel8.Expr

359304import Rel8.Expr.Aggregate

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

367312import Rel8.Expr.Order

368313import Rel8.Expr.Serialize

369314import Rel8.Expr.Sequence

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

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

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

373316import Rel8.Order

374317import Rel8.Query

@@ -379,18 +322,15 @@ import Rel8.Query.Either

379322import Rel8.Query.Evaluate

380323import Rel8.Query.Exists

381324import Rel8.Query.Filter

382−import Rel8.Query.Indexed

383325import Rel8.Query.Limit

384326import Rel8.Query.List

385327import Rel8.Query.Maybe

386328import Rel8.Query.Null

387329import Rel8.Query.Order

388−import Rel8.Query.Rebind

389330import Rel8.Query.SQL (showQuery)

390331import Rel8.Query.Set

391332import Rel8.Query.These

392333import Rel8.Query.Values

393−import Rel8.Query.Window

394334import Rel8.Schema.Field

395335import Rel8.Schema.HTable

396336import Rel8.Schema.Name

@@ -417,8 +357,6 @@ import Rel8.Table.List

417357import Rel8.Table.Maybe

418358import Rel8.Table.Name

419359import Rel8.Table.NonEmpty

420−import Rel8.Table.Null

421−import Rel8.Table.Opaleye ( castTable )

422360import Rel8.Table.Ord

423361import Rel8.Table.Order

424362import Rel8.Table.Projection

@@ -426,7 +364,6 @@ import Rel8.Table.Rel8able ()

426364import Rel8.Table.Serialize

427365import Rel8.Table.These

428366import Rel8.Table.Transpose

429−import Rel8.Table.Window

430367import Rel8.Type

431368import Rel8.Type.Composite

432369import Rel8.Type.Eq

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

441378import Rel8.Type.Semigroup

442379import Rel8.Type.String

443380import Rel8.Type.Sum

444−import Rel8.Window

445381

446382

447383-- $running

@@ -449,208 +385,3 @@ import Rel8.Window

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

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

451387-- `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+43−19

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

22{-# language FlexibleContexts #-}

33{-# language FlexibleInstances #-}

44{-# language MultiParamTypeClasses #-}

5+{-# language NamedFieldPuns #-}

56{-# language RankNTypes #-}

67{-# language StandaloneKindSignatures #-}

78{-# language TypeFamilies #-}

89{-# language UndecidableInstances #-}

910

1011module Rel8.Aggregate

11− ( Aggregate(..), zipOutputs

12− , unsafeMakeAggregate

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

13+ , Aggregator(..), unsafeMakeAggregate

1314 , Aggregates

1415 )

1516where

1617

1718-- base

18−import Control.Applicative ( liftA2 )

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

1920import Data.Functor.Identity ( Identity( Identity ) )

2021import Data.Kind ( Constraint, Type )

2122import Prelude

2223

23−-- profunctors

24−import Data.Profunctor ( dimap )

25−

2624-- opaleye

27−import qualified Opaleye.Aggregate as Opaleye

25+import qualified Opaleye.Internal.Aggregate as Opaleye

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

29−import qualified Opaleye.Internal.Column as Opaleye

27+import qualified Opaleye.Internal.PackMap as Opaleye

3028

3129-- rel8

3230import Rel8.Expr ( Expr )

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

4240import Rel8.Type ( DBType )

4341

4442

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

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

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.

4648type Aggregate :: K.Context

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

4850

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

5961 fromResult (HIdentity (Identity a)) = a

6062

6163

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

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

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

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

6466type Aggregates :: Type -> Type -> Constraint

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

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

6769

6870

69−zipOutputs :: ()

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

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

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

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

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

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+ }

7294

7395

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

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

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

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

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

99+ -> Maybe Aggregator

78100 -> Expr input

79101 -> Aggregate output

80102unsafeMakeAggregate input output aggregator expr =

81− Aggregate $ dimap in_ out aggregator

82− where out = output . Opaleye.unColumn

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

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

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

105+ where

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

107+ (operation, ordering, distinction)

src/Rel8/Column/Null.hsdeleted−26

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

1−{-# language DataKinds #-}

2−{-# language StandaloneKindSignatures #-}

3−{-# language TypeFamilyDependencies #-}

4−

5−module Rel8.Column.Null

6− ( HNull

7− )

8−where

9−

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/Expr.hs−1

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

11{-# language DataKinds #-}

22{-# language DerivingStrategies #-}

3−{-# language FlexibleContexts #-}

43{-# language FlexibleInstances #-}

54{-# language MultiParamTypeClasses #-}

65{-# language ScopedTypeVariables #-}

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

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

1010 , and, or

1111 , min, max

1212 , sum, sumWhere

13− , avg

1413 , stringAgg

1514 , groupByExpr

1615 , listAggExpr, nonEmptyAggExpr

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

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

2524

2625-- opaleye

27−import qualified Opaleye.Internal.Aggregate as Opaleye

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

29−import qualified Opaleye.Aggregate as Opaleye

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

3027

3128-- rel8

32−import Rel8.Aggregate ( Aggregate, unsafeMakeAggregate )

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

3330import Rel8.Expr ( Expr )

3431import Rel8.Expr.Bool ( caseExpr )

3532import Rel8.Expr.Opaleye

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

5350

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

5552count :: Expr a -> Aggregate Int64

56−count = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.count

53+count = unsafeMakeAggregate toPrimExpr fromPrimExpr $

54+ Just Aggregator

55+ { operation = Opaleye.AggrCount

56+ , ordering = []

57+ , distinction = Opaleye.AggrAll

58+ }

59+

5760

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

5962-- @COUNT(DISTINCT a)@

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

6164countDistinct = unsafeMakeAggregate toPrimExpr fromPrimExpr $

62− Opaleye.distinctAggregator Opaleye.count

65+ Just Aggregator

66+ { operation = Opaleye.AggrCount

67+ , ordering = []

68+ , distinction = Opaleye.AggrDistinct

69+ }

6370

6471

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

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

7481

7582-- | Corresponds to @bool_and@.

7683and :: Expr Bool -> Aggregate Bool

77−and = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.boolAnd

84+and = unsafeMakeAggregate toPrimExpr fromPrimExpr $

85+ Just Aggregator

86+ { operation = Opaleye.AggrBoolAnd

87+ , ordering = []

88+ , distinction = Opaleye.AggrAll

89+ }

7890

7991

8092-- | Corresponds to @bool_or@.

8193or :: Expr Bool -> Aggregate Bool

82−or = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.boolOr

94+or = unsafeMakeAggregate toPrimExpr fromPrimExpr $

95+ Just Aggregator

96+ { operation = Opaleye.AggrBoolOr

97+ , ordering = []

98+ , distinction = Opaleye.AggrAll

99+ }

83100

84101

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

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

87−max = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.unsafeMax

104+max = unsafeMakeAggregate toPrimExpr fromPrimExpr $

105+ Just Aggregator

106+ { operation = Opaleye.AggrMax

107+ , ordering = []

108+ , distinction = Opaleye.AggrAll

109+ }

88110

89111

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

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

92−min = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.unsafeMin

114+min = unsafeMakeAggregate toPrimExpr fromPrimExpr $

115+ Just Aggregator

116+ { operation = Opaleye.AggrMin

117+ , ordering = []

118+ , distinction = Opaleye.AggrAll

119+ }

93120

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

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

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

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

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

98125-- your input.

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

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

101−

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

128+ Just Aggregator

129+ { operation = Opaleye.AggrSum

130+ , ordering = []

131+ , distinction = Opaleye.AggrAll

132+ }

102133

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

110134

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

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

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

118142stringAgg :: Sql DBString a

119143 => Expr db -> Expr a -> Aggregate a

120144stringAgg delimiter =

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

145+ unsafeMakeAggregate toPrimExpr (castExpr . fromPrimExpr) $

146+ Just Aggregator

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

148+ , ordering = []

149+ , distinction = Opaleye.AggrAll

150+ }

122151

123152

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

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

126−groupByExpr = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.groupBy

155+groupByExpr = unsafeMakeAggregate toPrimExpr fromPrimExpr Nothing

127156

128157

129158-- | Collect expressions values as a list.

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

138167

139168slistAggExpr :: ()

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

141−slistAggExpr info = unsafeMakeAggregate to fromPrimExpr Opaleye.arrayAgg

170+slistAggExpr info = unsafeMakeAggregate to fromPrimExpr $ Just

171+ Aggregator

172+ { operation = Opaleye.AggrArr

173+ , ordering = []

174+ , distinction = Opaleye.AggrAll

175+ }

142176 where

143177 to = encodeArrayElement info . toPrimExpr

144178

145179

146180snonEmptyAggExpr :: ()

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

148−snonEmptyAggExpr info = unsafeMakeAggregate to fromPrimExpr Opaleye.arrayAgg

182+snonEmptyAggExpr info = unsafeMakeAggregate to fromPrimExpr $ Just

183+ Aggregator

184+ { operation = Opaleye.AggrArr

185+ , ordering = []

186+ , distinction = Opaleye.AggrAll

187+ }

149188 where

150189 to = encodeArrayElement info . toPrimExpr

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

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

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

66module Rel8.Expr.Num

7− ( fromIntegral

8− , realToFrac

9− , div, mod, divMod

10− , quot, rem, quotRem

11− , ceiling, floor, round, truncate

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

128 )

139where

1410

1511-- base

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

12+import Prelude ()

1713

1814-- rel

1915import Rel8.Expr ( Expr( Expr ) )

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

2116import Rel8.Expr.Function ( function )

2217import Rel8.Expr.Opaleye ( castExpr )

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

24−import Rel8.Table.Bool ( bool )

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

2620

2721

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

4842ceiling = function "ceiling"

4943

5044

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

52−-- PostgreSQL.

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

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

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

47+div = function "div"

5548

5649

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

58−-- PostgreSQL.

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

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

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)

52+mod = function "mod"

8653

8754

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

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

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

1010 , scastExpr, sunsafeCastExpr

1111 , unsafeLiteral

1212 , fromPrimExpr, toPrimExpr, mapPrimExpr, zipPrimExprsWith, traversePrimExpr

13− , toColumn, fromColumn, traverseFieldP

13+ , toColumn, fromColumn

1414 )

1515where

1616

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

2727import Rel8.Type ( DBType, typeInformation )

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

2929

30−-- profunctors

31−import Data.Profunctor ( Profunctor, dimap )

32−

3330

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

3532castExpr = scastExpr typeInformation

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

8380traversePrimExpr f = fmap fromPrimExpr . f . toPrimExpr

8481

8582

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−

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

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

9384toColumn = Opaleye.Column

9485

9586

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

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

9788fromColumn (Opaleye.Column a) = a

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

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

1111import Rel8.Expr ( Expr )

1212import Rel8.Expr.Function ( function )

1313import Rel8.Expr.Serialize ( litExpr )

14−import Rel8.Expr.Text ( quoteIdent )

1514

1615-- text

1716import Data.Text ( pack )

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

1918

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

2120nextval :: String -> Expr Int64

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

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

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

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

1717 , pgClientEncoding, quoteIdent, quoteLiteral, quoteNullable, regexpReplace

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

1919 , splitPart, strpos, substr, translate

20−

21− -- * @LIKE@ and @ILIKE@

22− , like, ilike

2320 )

2421where

2522

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

2724import Data.Bool ( Bool )

2825import Data.Int ( Int32 )

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

30−import Prelude ( flip )

27+import Prelude ()

3128

3229-- bytestring

3330import Data.ByteString ( ByteString )

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

5249

5350

5451-- | Matches regular expression, case sensitive

55−--

52+--

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

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

5855(~.) = binaryOperator "~."

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

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

277274translate :: Expr Text -> Expr Text -> Expr Text -> Expr Text

278275translate = 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.hsdeleted−121

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

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,7 +1,6 @@

11{-# language AllowAmbiguousTypes #-}

22{-# language BlockArguments #-}

33{-# language DataKinds #-}

4−{-# language FlexibleContexts #-}

54{-# language FlexibleInstances #-}

65{-# language MultiParamTypeClasses #-}

76{-# language RankNTypes #-}

src/Rel8/Generic/Record.hs−2

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

11{-# language AllowAmbiguousTypes #-}

22{-# language DataKinds #-}

3−{-# language FlexibleContexts #-}

43{-# language FlexibleInstances #-}

54{-# language MultiParamTypeClasses #-}

65{-# language PolyKinds #-}

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

142141 uncount = id

143142

144143

145−type Record :: Type -> Type

146144newtype Record a = Record

147145 { unrecord :: a

148146 }

src/Rel8/Generic/Rel8able.hs+1−6

@@ -63,11 +63,6 @@ type KRel8able = K.Rel8able

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

6464type (==) :: k -> k -> Bool

6565type 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−

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

7267 -- which occurs when we have polymorphic Rel8ables

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

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

146141-- [Supplying @Rel8able@ instances]

147142--

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

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

144+-- project. To do this, enable the @DeriveAnyType@ and @DeriveGeneric@ language

150145-- extensions:

151146--

152147-- @

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

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

11{-# language AllowAmbiguousTypes #-}

22{-# language DataKinds #-}

3−{-# language FlexibleContexts #-}

43{-# language FlexibleInstances #-}

54{-# language LambdaCase #-}

65{-# language MultiParamTypeClasses #-}

src/Rel8/Order.hs+8−1

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

55module Rel8.Order

66 ( Order(..)

7+ , toOrderExprs

78 )

89where

910

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

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

1718

1819-- opaleye

19−import qualified Opaleye.Order as Opaleye

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

21+import qualified Opaleye.Internal.Order as Opaleye

2022

2123

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

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

2830type Order :: Type -> Type

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

3032 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+9−28

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

1−{-# language FlexibleContexts #-}

21{-# language StandaloneKindSignatures #-}

3−{-# language UndecidableInstances #-}

53module Rel8.Query

64 ( Query( Query )

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

1715-- opaleye

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

1917import qualified Opaleye.Internal.PackMap as Opaleye

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

18+import qualified Opaleye.Internal.PrimQuery as Opaleye

2119import qualified Opaleye.Internal.QueryArr as Opaleye

2220import qualified Opaleye.Internal.Tag as Opaleye

2321

2422-- rel8

25−import Rel8.Expr ( Expr )

2623import Rel8.Query.Set ( unionAll )

2724import Rel8.Query.Opaleye ( fromOpaleye )

2825import Rel8.Query.Values ( values )

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

3026import Rel8.Table.Alternative

3127 ( AltTable, (<|>:)

3228 , AlternativeTable, emptyTable

3329 )

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

3530

3631-- semigroupoids

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

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

156151 )

157152

158153

159−instance Projectable Query where

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

161−

162−

163154instance Functor Query where

164155 fmap f (Query a) = Query (fmap (fmap (fmap f)) a)

165156

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

178169

179170

180171instance Monad Query where

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

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

182173 let

183− qa = q dummies

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

174+ Opaleye.QueryArr qa = q dummies

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

185176 Query q' = f a

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

187178 ( dummy : dummies

188− , query <> Opaleye.aRebind bindings

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

189180 , Opaleye.next tag'

190181 )

191182 where

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

193184 where

194185 random = Opaleye.FunExpr "random" []

195186 name = Opaleye.extractAttr "dummy" tag'

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

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

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

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

198189 query'''

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

200− | otherwise = query <> query''

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

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

201192 m'' = m <> m'

202193 in

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

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

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

212203instance AlternativeTable Query where

213204 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,17 +1,13 @@

11{-# language FlexibleContexts #-}

22{-# language MonoLocalBinds #-}

3−{-# language ScopedTypeVariables #-}

4−{-# language TypeApplications #-}

64module Rel8.Query.Aggregate

75 ( aggregate

86 , countRows

9− , mode

107 )

118where

129

1310-- base

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

1511import Data.Int ( Int64 )

1612import Prelude

1713

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

2218import Rel8.Aggregate ( Aggregates )

2319import Rel8.Expr ( Expr )

2420import Rel8.Expr.Aggregate ( countStar )

25−import Rel8.Expr.Order ( desc )

2621import Rel8.Query ( Query )

27−import Rel8.Query.Limit ( limit )

2822import Rel8.Query.Maybe ( optional )

2923import 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 )

3524import Rel8.Table.Opaleye ( aggregator )

3625import Rel8.Table.Maybe ( maybeTable )

3726

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

4635-- will return @0@.

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

4837countRows = 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+9−4

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

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

13module Rel8.Query.Distinct

24 ( distinct

35 , distinctOn

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

68where

810-- base

9−import Prelude ()

11+import Prelude

1012

1113-- opaleye

1214import qualified Opaleye.Distinct as Opaleye

13−import qualified Opaleye.Order as Opaleye

15+import qualified Opaleye.Internal.Order as Opaleye

16+import qualified Opaleye.Internal.QueryArr as Opaleye

1417

1518-- rel8

1619import Rel8.Order ( Order( Order ) )

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

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

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

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

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

36+distinctOn proj =

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

3438

3539

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

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

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

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

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

44+distinctOnBy proj (Order order) =

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

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

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

44module Rel8.Query.Evaluate

55 ( evaluate

6+ , rebind

67 )

78where

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

1516

1617-- opaleye

1718import 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

1824

1925-- rel8

2026import Rel8.Expr ( Expr )

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

2228import Rel8.Expr.Opaleye ( fromPrimExpr )

2329import Rel8.Query ( Query( Query ) )

24−import Rel8.Query.Rebind ( rebind )

2530import Rel8.Table ( Table )

2631import Rel8.Table.Bool ( case_ )

27−import Rel8.Table.Undefined ( undefined )

32+import Rel8.Table.Opaleye ( unpackspec )

33+import Rel8.Table.Undefined

2834

2935

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

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

3238-- effects and can safely be reused.

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

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

40+evaluate = laterally >=> rebind

3541

3642

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

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

4551 go = fromPrimExpr . Opaleye.UnExpr Opaleye.OpIsNotNull

4652

4753

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+

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

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

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

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

1212

1313-- opaleye

1414import qualified Opaleye.Exists as Opaleye

15−import qualified Opaleye.Operators as Opaleye

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

1616

1717-- rel8

1818import Rel8.Expr ( Expr )

src/Rel8/Query/Indexed.hsdeleted−21

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

1−module Rel8.Query.Indexed

2− ( indexed

3− )

4−where

5−

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+7−9

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

2424import Rel8.Expr.Opaleye ( mapPrimExpr )

2525import Rel8.Query ( Query )

2626import Rel8.Query.Aggregate ( aggregate )

27+import Rel8.Query.Evaluate ( rebind )

2728import Rel8.Query.Maybe ( optional )

28−import Rel8.Query.Rebind ( rebind )

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

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

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

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

8585--

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

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

88−catListTable (ListTable as) =

89− rebind "unnest" $ fromColumns $ runIdentity $

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

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

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

9190

9291

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

@@ -95,9 +94,8 @@ catListTable (ListTable as) =

9594--

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

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

98−catNonEmptyTable (NonEmptyTable as) =

99− rebind "unnest" $ fromColumns $ runIdentity $

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

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

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

10199

102100

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

@@ -105,7 +103,7 @@ catNonEmptyTable (NonEmptyTable as) =

105103--

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

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

108−catList = rebind "unnest" . sunnest typeInformation

106+catList = rebind . sunnest typeInformation

109107

110108

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

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

113111--

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

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

116−catNonEmpty = rebind "unnest" . sunnest typeInformation

114+catNonEmpty = rebind . sunnest typeInformation

117115

118116

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

src/Rel8/Query/Null.hs−15

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

1−{-# language FlexibleContexts #-}

2−

31module Rel8.Query.Null

42 ( catNull

5− , catNullTable

63 )

74where

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

129-- rel8

1310import Rel8.Expr ( Expr )

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

15−import Rel8.Table ( Table )

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

1712import Rel8.Query ( Query )

1813import Rel8.Query.Filter ( where_ )

1914

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

2621catNull a = do

2722 where_ $ isNonNull a

2823 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+10−18

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

55 , toOpaleye

66 , mapOpaleye

77 , zipOpaleyeWith

8− , unsafePeekQuery

98 )

109where

1110

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

1514

1615-- opaleye

1716import qualified Opaleye.Internal.QueryArr as Opaleye

18−import qualified Opaleye.Internal.Tag as Opaleye

1917

2018-- rel8

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

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

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

4038

4139

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−

4840mapping :: ()

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

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

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

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

5244 let

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

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

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

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

5547 in

56− Opaleye.runStateQueryArr q' () tag

48+ qa' ((), tag)

5749

5850

5951zipping :: Semigroup m

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

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

62−zipping f q q' =

63− Opaleye.stateQueryArr $ \_ tag ->

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

55+ Opaleye.QueryArr $ \(_, tag) ->

6456 let

65− ((m, _), _, _) = Opaleye.runStateQueryArr q () tag

66− ((m', _), _, _) = Opaleye.runStateQueryArr q' () tag

57+ ((m, _), _, _) = qa ((), tag)

58+ ((m', _), _, _) = qa' ((), tag)

6759 m'' = m <> m'

68− q'' = (m'',) <$> f (snd <$> q) (snd <$> q')

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

6961 in

70− Opaleye.runStateQueryArr q'' () tag

62+ qa'' ((), tag)

src/Rel8/Query/Rebind.hsdeleted−27

@@ -1,27 +0,0 @@

1−{-# language FlexibleContexts #-}

2−

3−module Rel8.Query.Rebind

4− ( rebind

5− )

6−where

7−

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+1−1

@@ -18,4 +18,4 @@ import Rel8.Table ( Table )

1818

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

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

21−showQuery = show . ppSelect

21+showQuery = foldMap show . ppSelect

src/Rel8/Query/Set.hs+6−6

@@ -23,36 +23,36 @@ import Rel8.Table.Opaleye ( binaryspec )

2323

2424

2525-- | Combine the results of two queries of the same type, collapsing

26−-- duplicates. @union a b@ is the same as the SQL statement @a UNION b@.

26+-- duplicates. @union a b@ is the same as the SQL statement @x UNION b@.

2727union :: EqTable a => Query a -> Query a -> Query a

2828union = zipOpaleyeWith (Opaleye.unionExplicit binaryspec)

2929

3030

3131-- | Combine the results of two queries of the same type, retaining duplicates.

32−-- @unionAll a b@ is the same as the SQL statement @a UNION ALL b@.

32+-- @unionAll a b@ is the same as the SQL statement @x UNION ALL b@.

3333unionAll :: Table Expr a => Query a -> Query a -> Query a

3434unionAll = zipOpaleyeWith (Opaleye.unionAllExplicit binaryspec)

3535

3636

3737-- | Find the intersection of two queries, collapsing duplicates. @intersect a

38−-- b@ is the same as the SQL statement @a INTERSECT b@.

38+-- b@ is the same as the SQL statement @x INTERSECT b@.

3939intersect :: EqTable a => Query a -> Query a -> Query a

4040intersect = zipOpaleyeWith (Opaleye.intersectExplicit binaryspec)

4141

4242

4343-- | Find the intersection of two queries, retaining duplicates. @intersectAll

44−-- a b@ is the same as the SQL statement @a INTERSECT ALL b@.

44+-- a b@ is the same as the SQL statement @x INTERSECT ALL b@.

4545intersectAll :: EqTable a => Query a -> Query a -> Query a

4646intersectAll = zipOpaleyeWith (Opaleye.intersectAllExplicit binaryspec)

4747

4848

4949-- | Find the difference of two queries, collapsing duplicates @except a b@ is

50−-- the same as the SQL statement @a EXCEPT b@.

50+-- the same as the SQL statement @x INTERSECT b@.

5151except :: EqTable a => Query a -> Query a -> Query a

5252except = zipOpaleyeWith (Opaleye.exceptExplicit binaryspec)

5353

5454

5555-- | Find the difference of two queries, retaining duplicates. @exceptAll a b@

56−-- is the same as the SQL statement @a EXCEPT ALL b@.

56+-- is the same as the SQL statement @x EXCEPT ALL b@.

5757exceptAll :: EqTable a => Query a -> Query a -> Query a

5858exceptAll = zipOpaleyeWith (Opaleye.exceptAllExplicit binaryspec)

src/Rel8/Query/These.hs+8−8

@@ -48,11 +48,11 @@ import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ) )

4848alignBy :: ()

4949 => (a -> b -> Expr Bool)

5050 -> Query a -> Query b -> Query (TheseTable Expr a b)

51−alignBy condition = zipOpaleyeWith $ \left right -> Opaleye.stateQueryArr $ \_ t -> case t of

52− tag -> (tab, join', tag''')

51+alignBy condition = zipOpaleyeWith $ \left right -> Opaleye.QueryArr $ \i -> case i of

52+ (_, tag) -> (tab, join', tag''')

5353 where

54− (ma, left', tag') = Opaleye.runStateQueryArr (pure <$> left) () tag

55− (mb, right', tag'') = Opaleye.runStateQueryArr (pure <$> right) () tag'

54+ (ma, left', tag') = Opaleye.runSimpleQueryArr (pure <$> left) ((), tag)

55+ (mb, right', tag'') = Opaleye.runSimpleQueryArr (pure <$> right) ((), tag')

5656 MaybeTable hasHere a = ma

5757 MaybeTable hasThere b = mb

5858 (hasHere', lbindings) = Opaleye.run $ do

@@ -60,15 +60,15 @@ alignBy condition = zipOpaleyeWith $ \left right -> Opaleye.stateQueryArr $ \_ t

6060 (hasThere', rbindings) = Opaleye.run $ do

6161 traversePrimExpr (Opaleye.extractAttr "hasThere" tag'') hasThere

6262 tag''' = Opaleye.next tag''

63− join = Opaleye.Join Opaleye.FullJoin on left'' right''

63+ join lateral = Opaleye.Join Opaleye.FullJoin on left'' right''

6464 where

6565 on = toPrimExpr $ condition (extract a) (extract b)

66− left'' = (Opaleye.NonLateral, Opaleye.toPrimQuery (left' <> Opaleye.aRebind lbindings))

67− right'' = (Opaleye.NonLateral, Opaleye.toPrimQuery (right' <> Opaleye.aRebind rbindings))

66+ left'' = (lateral, Opaleye.Rebind True lbindings left')

67+ right'' = (lateral, Opaleye.Rebind True rbindings right')

6868 ma' = MaybeTable hasHere' a

6969 mb' = MaybeTable hasThere' b

7070 tab = TheseTable {here = ma', there = mb'}

71− join' = Opaleye.aProduct join

71+ join' lateral input = Opaleye.times lateral input (join lateral)

7272

7373

7474keepHereTable :: TheseTable Expr a b -> Query (a, MaybeTable Expr b)

src/Rel8/Query/Window.hsdeleted−26

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

1−module Rel8.Query.Window

2− ( window

3− )

4−where

5−

6−-- base

7−import Prelude ()

8−

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+14−6

@@ -18,17 +18,18 @@ where

1818import Data.Bool ( bool )

1919import Data.Functor.Identity ( Identity( Identity ) )

2020import Data.Kind ( Constraint, Type )

21+import Data.Monoid ( getFirst )

2122import Prelude hiding ( null )

2223

2324-- opaleye

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

2526

2627-- rel8

27−import Rel8.Aggregate ( Aggregate(..), zipOutputs )

28+import Rel8.Aggregate ( Aggregate( Aggregate ), foldInputs, mapInputs )

2829import Rel8.Expr ( Expr )

2930import Rel8.Expr.Bool ( boolExpr )

3031import Rel8.Expr.Null ( nullify, unsafeUnnullify )

31−import Rel8.Expr.Opaleye ( fromPrimExpr )

32+import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr )

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

3334import Rel8.Schema.Field ( Field )

3435import qualified Rel8.Schema.Kind as K

@@ -94,10 +95,17 @@ guarder :: ()

9495 -> context (Maybe a)

9596 -> context (Maybe a)

9697guarder = \case

97− SAggregate -> \tag _ isNonNull -> zipOutputs (sguard . isNonNull) tag

98− SExpr -> \tag _ isNonNull -> sguard (isNonNull tag)

99− SField -> \_ _ _ -> id

100− SName -> \_ _ _ -> id

98+ SAggregate -> \tag _ isNonNull (Aggregate a) ->

99+ let

100+ mtag = foldInputs (\_ -> pure . fromPrimExpr) tag

101+ run = maybe id (sguard . isNonNull) (getFirst mtag)

102+ in

103+ mapInputs (toPrimExpr . run . fromPrimExpr) $

104+ Aggregate $

105+ run <$> a

106+ SExpr -> \tag _ isNonNull a -> sguard (isNonNull tag) a

107+ SField -> \_ _ _ field -> field

108+ SName -> \_ _ _ name -> name

101109 SResult -> \(Identity tag) isNonNull _ (Identity a) ->

102110 Identity (bool Nothing a (isNonNull tag))

103111

src/Rel8/Schema/HTable.hs+2−29

@@ -16,12 +16,11 @@

1616module Rel8.Schema.HTable

1717 ( HTable (HField, HConstrainTable)

1818 , hfield, htabulate, htraverse, hdicts, hspecs

19− , hfoldMap, hmap, htabulateA, htraverseP, htraversePWithField

19+ , hmap, htabulateA

2020 )

2121where

2222

2323-- base

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

2524import Data.Kind ( Constraint, Type )

2625import Data.Functor.Compose ( Compose( Compose ), getCompose )

2726import Data.Proxy ( Proxy )

@@ -33,12 +32,6 @@ import GHC.Generics

3332 )

3433import Prelude

3534

36−-- profunctors

37−import Data.Profunctor ( rmap, Profunctor (lmap) )

38−

39−-- product-profunctors

40−import Data.Profunctor.Product ( ProductProfunctor ((****)) )

41−

4235-- rel8

4336import Rel8.Schema.Dict ( Dict )

4437import Rel8.Schema.Spec ( Spec )

@@ -48,6 +41,7 @@ import qualified Rel8.Schema.Kind as K

4841-- semigroupoids

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

5043

44+

5145-- | A @HTable@ is a functor-indexed/higher-kinded data type that is

5246-- representable ('htabulate'/'hfield'), constrainable ('hdicts'), and

5347-- specified ('hspecs').

@@ -120,11 +114,6 @@ class HTable t where

120114 {-# INLINABLE hspecs #-}

121115

122116

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−

128117hmap :: HTable t

129118 => (forall a. context a -> context' a) -> t context -> t context'

130119hmap f a = htabulate $ \field -> f (hfield a field)

@@ -135,22 +124,6 @@ htabulateA :: (HTable t, Apply m)

135124htabulateA f = htraverse getCompose $ htabulate $ Compose . f

136125{-# INLINABLE htabulateA #-}

137126

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)

154127

155128type GHField :: K.HTable -> Type -> Type

156129newtype GHField t a = GHField (HField (GHColumns (Rep (t Proxy))) a)

src/Rel8/Schema/HTable/Vectorize.hs+2−10

@@ -22,12 +22,11 @@ module Rel8.Schema.HTable.Vectorize

2222 , hvectorize, hunvectorize

2323 , happend, hempty

2424 , hproject

25− , hcolumn

2625 )

2726where

2827

2928-- base

30−import Data.Kind ( Constraint, Type )

29+import Data.Kind ( Type )

3130import Data.List.NonEmpty ( NonEmpty )

3231import GHC.Generics (Generic)

3332import Prelude

@@ -37,11 +36,9 @@ import Rel8.FCF ( Eval, Exp )

3736import Rel8.Schema.Dict ( Dict( Dict ) )

3837import qualified Rel8.Schema.Kind as K

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

40−import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )

4139import Rel8.Schema.HTable.MapTable

42− ( HMapTable( HMapTable ), HMapTableField( HMapTableField )

40+ ( HMapTable, HMapTableField( HMapTableField )

4341 , MapSpec, mapInfo

44− , Precompose( Precompose )

4542 )

4643import qualified Rel8.Schema.HTable.MapTable as HMapTable ( hproject )

4744import Rel8.Schema.Null ( Unnullify, NotNull, Nullity( NotNull ) )

@@ -53,7 +50,6 @@ import Rel8.Type.Information ( TypeInformation )

5350import Data.Zip ( Unzip, Zip, Zippy(..) )

5451

5552

56−type Vector :: (Type -> Type) -> Constraint

5753class Vector list where

5854 listNotNull :: proxy a -> Dict NotNull (list a)

5955 vectorTypeInformation :: ()

@@ -137,7 +133,3 @@ hproject :: ()

137133 => (forall ctx. t ctx -> t' ctx)

138134 -> HVectorize list t context -> HVectorize list t' context

139135hproject 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/Table.hs−3

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

22{-# language DerivingStrategies #-}

33{-# language DisambiguateRecordFields #-}

44{-# language NamedFieldPuns #-}

5−{-# language StandaloneKindSignatures #-}

76module Rel8.Schema.Table

87 ( TableSchema(..)

@@ -11,7 +10,6 @@ module Rel8.Schema.Table

1110where

1211

1312-- base

14−import Data.Kind ( Type )

1513import Prelude

1614

1715-- opaleye

@@ -28,7 +26,6 @@ import Text.PrettyPrint ( Doc )

2826--

2927-- For each selectable table in your database, you should provide a

3028-- @TableSchema@ in order to interact with the table via Rel8.

31−type TableSchema :: Type -> Type

3229data TableSchema names = TableSchema

3330 { name :: String

3431 -- ^ The name of the table.

src/Rel8/Statement/Delete.hs+27−20

@@ -14,11 +14,14 @@ module Rel8.Statement.Delete

1414where

1515

1616-- base

17+import Control.Exception ( throwIO )

1718import Data.Kind ( Type )

1819import Prelude

1920

2021-- hasql

22+import Hasql.Connection ( Connection )

2123import qualified Hasql.Encoders as Hasql

24+import qualified Hasql.Session as Hasql

2225import qualified Hasql.Statement as Hasql

2326

2427-- pretty

@@ -29,7 +32,10 @@ import Rel8.Expr ( Expr )

2932import Rel8.Query ( Query )

3033import Rel8.Schema.Name ( Selects )

3134import Rel8.Schema.Table ( TableSchema, ppTable )

32−import Rel8.Statement.Returning ( Returning, decodeReturning, ppReturning )

35+import Rel8.Statement.Returning

36+ ( Returning

37+ , decodeReturning, emptyReturning, ppReturning

38+ )

3339import Rel8.Statement.Using ( ppUsing )

3440import Rel8.Statement.Where ( ppWhere )

3541

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

5561 -> Delete a

5662

5763

58−ppDelete :: Delete a -> Doc

59−ppDelete Delete {..} = case ppUsing using of

60− Nothing ->

61− text "DELETE FROM" <+> ppTable from $$

62− text "WHERE false"

63− Just (usingDoc, i) ->

64− text "DELETE FROM" <+> ppTable from $$

65− usingDoc $$

66− ppWhere from (deleteWhere i) $$

67− ppReturning from returning

64+ppDelete :: Delete a -> Maybe Doc

65+ppDelete Delete {..} = do

66+ (usingDoc, i) <- ppUsing using

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

68+ $$ usingDoc

69+ $$ ppWhere from (deleteWhere i)

70+ $$ ppReturning from returning

6871

6972

7073-- | Run a 'Delete' statement.

71−delete :: Delete a -> Hasql.Statement () a

72−delete d@Delete {returning} = Hasql.Statement bytes params decode prepare

73− where

74− bytes = encodeUtf8 $ Text.pack sql

75− params = Hasql.noParams

76− decode = decodeReturning returning

77− prepare = False

78− sql = show doc

79− doc = ppDelete d

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

75+delete connection d@Delete {returning} =

76+ case show <$> ppDelete d of

77+ Nothing -> pure (emptyReturning returning)

78+ Just sql ->

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

80+ where

81+ session = Hasql.statement () statement

82+ statement = Hasql.Statement bytes params decode prepare

83+ bytes = encodeUtf8 $ Text.pack sql

84+ params = Hasql.noParams

85+ decode = decodeReturning returning

86+ prepare = False

src/Rel8/Statement/Insert.hs+28−18

@@ -15,12 +15,15 @@ module Rel8.Statement.Insert

1515where

1616

1717-- base

18+import Control.Exception ( throwIO )

1819import Data.Foldable ( toList )

1920import Data.Kind ( Type )

2021import Prelude

2122

2223-- hasql

24+import Hasql.Connection ( Connection )

2325import qualified Hasql.Encoders as Hasql

26+import qualified Hasql.Session as Hasql

2427import qualified Hasql.Statement as Hasql

2528

2629-- opaleye

@@ -34,8 +37,11 @@ import Rel8.Query ( Query )

3437import Rel8.Schema.Name ( Name, Selects, ppColumn )

3538import Rel8.Schema.Table ( TableSchema(..), ppTable )

3639import Rel8.Statement.OnConflict ( OnConflict, ppOnConflict )

37−import Rel8.Statement.Returning ( Returning, decodeReturning, ppReturning )

38−import Rel8.Statement.Select ( ppRows )

40+import Rel8.Statement.Returning

41+ ( Returning

42+ , decodeReturning, emptyReturning, ppReturning

43+ )

44+import Rel8.Statement.Select ( ppSelect )

3945import Rel8.Table ( Table )

4046import Rel8.Table.Name ( showNames )

4147

@@ -62,13 +68,13 @@ data Insert a where

6268 -> Insert a

6369

6470

65−ppInsert :: Insert a -> Doc

66−ppInsert Insert {..} =

67− text "INSERT INTO" <+>

68− ppInto into $$

69− ppRows rows $$

70− ppOnConflict into onConflict $$

71− ppReturning into returning

71+ppInsert :: Insert a -> Maybe Doc

72+ppInsert Insert {..} = do

73+ rows' <- ppSelect rows

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

75+ $$ rows'

76+ $$ ppOnConflict into onConflict

77+ $$ ppReturning into returning

7278

7379

7480ppInto :: Table Name a => TableSchema a -> Doc

@@ -78,12 +84,16 @@ ppInto table@TableSchema {columns} =

7884

7985

8086-- | Run an 'Insert' statement.

81−insert :: Insert a -> Hasql.Statement () 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

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

88+insert connection i@Insert {returning} =

89+ case show <$> ppInsert i of

90+ Nothing -> pure (emptyReturning returning)

91+ Just sql ->

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

93+ where

94+ session = Hasql.statement () statement

95+ statement = Hasql.Statement bytes params decode prepare

96+ bytes = encodeUtf8 $ Text.pack sql

97+ params = Hasql.noParams

98+ decode = decodeReturning returning

99+ prepare = False

src/Rel8/Statement/Returning.hs+7

@@ -9,7 +9,9 @@

1010module Rel8.Statement.Returning

1111 ( Returning( NumberOfRowsAffected, Projection )

12+

1213 , decodeReturning

14+ , emptyReturning

1315 , ppReturning

1416 )

1517where

@@ -124,6 +126,11 @@ decodeReturning = runReturning

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

125127

126128

129+emptyReturning :: Returning names a -> a

130+emptyReturning =

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

132+

133+

127134ppReturning :: TableSchema names -> Returning names a -> Doc

128135ppReturning schema returning = case projections schema returning of

129136 Nothing -> mempty

src/Rel8/Statement/SQL.hs+3−3

@@ -16,14 +16,14 @@ import Rel8.Statement.Update ( Update, ppUpdate )

1616

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

1818showDelete :: Delete a -> String

19−showDelete = show . ppDelete

19+showDelete = foldMap show . ppDelete

2020

2121

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

2323showInsert :: Insert a -> String

24−showInsert = show . ppInsert

24+showInsert = foldMap show . ppInsert

2525

2626

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

2828showUpdate :: Update a -> String

29−showUpdate = show . ppUpdate

29+showUpdate = foldMap show . ppUpdate

src/Rel8/Statement/Select.hs+29−57

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

33{-# language FlexibleContexts #-}

44{-# language MonoLocalBinds #-}

55{-# language ScopedTypeVariables #-}

6−{-# language StandaloneKindSignatures #-}

76{-# language TypeApplications #-}

98module Rel8.Statement.Select

@@ -12,39 +11,34 @@ module Rel8.Statement.Select

1211

1312 , Optimized(..)

1413 , ppPrimSelect

15− , ppRows

1614 )

1715where

1816

1917-- base

20−import Data.Foldable ( toList )

21−import Data.Kind ( Type )

18+import Control.Exception ( throwIO )

2219import Data.Void ( Void )

23−import Prelude hiding ( undefined )

20+import Prelude

2421

2522-- hasql

23+import Hasql.Connection ( Connection )

2624import qualified Hasql.Decoders as Hasql

2725import qualified Hasql.Encoders as Hasql

26+import qualified Hasql.Session as Hasql

2827import qualified Hasql.Statement as Hasql

2928

3029-- opaleye

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

3230import qualified Opaleye.Internal.HaskellDB.Sql as Opaleye

33−import qualified Opaleye.Internal.HaskellDB.Sql.Print as Opaleye

3431import qualified Opaleye.Internal.PrimQuery as Opaleye

3532import qualified Opaleye.Internal.Print as Opaleye

3633import qualified Opaleye.Internal.Optimize as Opaleye

3734import 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

35+import qualified Opaleye.Internal.Sql as Opaleye

4036

4137-- pretty

4238import Text.PrettyPrint ( Doc )

4339

4440-- rel8

4541import Rel8.Expr ( Expr )

46−import Rel8.Expr.Bool ( false )

47−import Rel8.Expr.Opaleye ( toPrimExpr )

4842import Rel8.Query ( Query )

4943import Rel8.Query.Opaleye ( toOpaleye )

5044import Rel8.Schema.Name ( Selects )

@@ -52,9 +46,7 @@ import Rel8.Table ( Table )

5246import Rel8.Table.Cols ( toCols )

5347import Rel8.Table.Name ( namesFromLabels )

5448import Rel8.Table.Opaleye ( castTable, exprsWithNames )

55−import qualified Rel8.Table.Opaleye as T

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

57−import Rel8.Table.Undefined ( undefined )

5850

5951-- text

6052import qualified Data.Text as Text

@@ -63,63 +55,43 @@ import Data.Text.Encoding ( encodeUtf8 )

6355

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

6557select :: forall exprs a. Serializable exprs a

66− => Query exprs -> Hasql.Statement () [a]

67−select query = Hasql.Statement bytes params decode prepare

68− where

69− bytes = encodeUtf8 (Text.pack sql)

70− params = Hasql.noParams

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

72− prepare = False

73− sql = show doc

74− doc = ppSelect query

75−

76−

77−ppSelect :: Table Expr a => Query a -> Doc

78−ppSelect query =

79− Opaleye.ppSql $ primSelectWith names (toCols exprs') primQuery'

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

59+select c query = case ppSelect query of

60+ Nothing -> pure []

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

62+ where

63+ session = Hasql.statement () statement

64+ statement = Hasql.Statement bytes params decode prepare

65+ bytes = encodeUtf8 (Text.pack sql)

66+ params = Hasql.noParams

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

68+ prepare = False

69+ sql = show doc

70+

71+

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

73+ppSelect query = do

74+ primQuery' <- case optimize primQuery of

75+ Empty -> Nothing

76+ Unit -> Just Opaleye.Unit

77+ Optimized primQuery' -> Just primQuery'

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

8079 where

8180 names = namesFromLabels

8281 (exprs, primQuery, _) =

8382 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'

11183

11284

11385ppPrimSelect :: Query a -> (Optimized Doc, a)

11486ppPrimSelect query =

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

11688 where

117− (a, primQuery, _) = Opaleye.runSimpleQueryArrStart (toOpaleye query) ()

89+ (a, primQuery, _) =

90+ Opaleye.runSimpleQueryArrStart (toOpaleye query) ()

11891

11992

120−type Optimized :: Type -> Type

12193data Optimized a = Empty | Unit | Optimized a

122− deriving stock (Functor, Foldable, Traversable, Show)

94+ deriving stock (Functor, Foldable, Traversable)

12395

12496

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

src/Rel8/Statement/Update.hs+26−18

@@ -13,11 +13,14 @@ module Rel8.Statement.Update

1313where

1414

1515-- base

16+import Control.Exception ( throwIO )

1617import Data.Kind ( Type )

1718import Prelude

1819

1920-- hasql

21+import Hasql.Connection ( Connection )

2022import qualified Hasql.Encoders as Hasql

23+import qualified Hasql.Session as Hasql

2124import qualified Hasql.Statement as Hasql

2225

2326-- pretty

@@ -28,7 +31,10 @@ import Rel8.Expr ( Expr )

2831import Rel8.Query ( Query )

2932import Rel8.Schema.Name ( Selects )

3033import Rel8.Schema.Table ( TableSchema(..), ppTable )

31−import Rel8.Statement.Returning ( Returning, decodeReturning, ppReturning )

34+import Rel8.Statement.Returning

35+ ( Returning

36+ , decodeReturning, emptyReturning, ppReturning

37+ )

3238import Rel8.Statement.Set ( ppSet )

3339import Rel8.Statement.Using ( ppFrom )

3440import Rel8.Statement.Where ( ppWhere )

@@ -57,14 +63,12 @@ data Update a where

5763 -> Update a

5864

5965

60−ppUpdate :: Update a -> Doc

61−ppUpdate Update {..} = case ppFrom from of

62− Nothing ->

63− text "UPDATE" <+> ppTable target $$

64− ppSet target id $$

65− text "WHERE false"

66− Just (fromDoc, i) ->

67− text "UPDATE" <+> ppTable target $$

66+ppUpdate :: Update a -> Maybe Doc

67+ppUpdate Update {..} = do

68+ (fromDoc, i) <- ppFrom from

69+ pure $

70+ text "UPDATE" <+>

71+ ppTable target $$

6872 ppSet target (set i) $$

6973 fromDoc $$

7074 ppWhere target (updateWhere i) $$

@@ -72,12 +76,16 @@ ppUpdate Update {..} = case ppFrom from of

7276

7377

7478-- | Run an @UPDATE@ statement.

75−update :: Update a -> Hasql.Statement () a

76−update u@Update {returning} = Hasql.Statement bytes params decode prepare

77− where

78− bytes = encodeUtf8 $ Text.pack sql

79− params = Hasql.noParams

80− decode = decodeReturning returning

81− prepare = False

82− sql = show doc

83− doc = ppUpdate u

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

80+update connection u@Update {returning} =

81+ case show <$> ppUpdate u of

82+ Nothing -> pure (emptyReturning returning)

83+ Just sql ->

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

85+ where

86+ session = Hasql.statement () statement

87+ statement = Hasql.Statement bytes params decode prepare

88+ bytes = encodeUtf8 $ Text.pack sql

89+ params = Hasql.noParams

90+ decode = decodeReturning returning

91+ prepare = False

src/Rel8/Statement/View.hs+17−32

@@ -3,16 +3,20 @@

44module Rel8.Statement.View

55 ( createView

6− , createOrReplaceView

76 )

87where

109-- base

10+import Control.Exception ( throwIO )

11+import Data.Foldable ( fold )

12+import Data.Maybe ( fromMaybe )

1113import Prelude

1214

1315-- hasql

16+import Hasql.Connection ( Connection )

1417import qualified Hasql.Decoders as Hasql

1518import qualified Hasql.Encoders as Hasql

19+import qualified Hasql.Session as Hasql

1620import qualified Hasql.Statement as Hasql

1721

1822-- rel8

@@ -21,6 +25,7 @@ import Rel8.Schema.Name ( Selects )

2125import Rel8.Schema.Table ( TableSchema )

2226import Rel8.Statement.Insert ( ppInto )

2327import Rel8.Statement.Select ( ppSelect )

28+import Rel8.Table.Alternative ( emptyTable )

2429

2530-- pretty

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

@@ -30,49 +35,29 @@ import qualified Data.Text as Text

3035import Data.Text.Encoding ( encodeUtf8 )

3136

3237

33−data CreateView = Create | CreateOrReplace

34−

35−

3638-- | Given a 'TableSchema' and 'Query', @createView@ runs a @CREATE VIEW@

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

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

3941createView :: Selects names exprs

40− => TableSchema names -> Query exprs -> Hasql.Statement () ()

41−createView =

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+ => Connection -> TableSchema names -> Query exprs -> IO ()

43+createView connection schema query =

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

6045 where

46+ session = Hasql.statement () statement

47+ statement = Hasql.Statement bytes params decode prepare

6148 bytes = encodeUtf8 (Text.pack sql)

6249 params = Hasql.noParams

6350 decode = Hasql.noResult

6451 prepare = False

65− sql = show doc

66− doc = ppCreateView schema query replace

52+ sql = show (ppCreateView schema query)

6753

6854

6955ppCreateView :: Selects names exprs

70− => TableSchema names -> Query exprs -> CreateView -> Doc

71−ppCreateView schema query replace =

72− createOrReplace replace <+>

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

57+ppCreateView schema query =

58+ text "CREATE VIEW" <+>

7359 ppInto schema $$

7460 text "AS" <+>

75− ppSelect query

61+ fromMaybe fallback (ppSelect query)

7662 where

77− createOrReplace Create = text "CREATE VIEW"

78− createOrReplace CreateOrReplace = text "CREATE OR REPLACE VIEW"

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

src/Rel8/Table/Aggregate.hs−12

@@ -37,18 +37,6 @@ import Rel8.Type.Eq ( DBEq )

3737

3838-- | Group equal tables together. This works by aggregating each column in the

3939-- 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−-- @

5240groupBy :: forall exprs aggregates. (EqTable exprs, Aggregates aggregates exprs)

5341 => exprs -> aggregates

5442groupBy = fromColumns . hgroupBy (eqTable @exprs) . toColumns

src/Rel8/Table/HKD.hs−1

@@ -157,7 +157,6 @@ instance

157157 => HKDable a

158158

159159

160−type Top_ :: Constraint

161160class Top_

162161instance Top_

163162

src/Rel8/Table/List.hs+3−14

@@ -11,9 +11,7 @@

1111

1212module Rel8.Table.List

1313 ( ListTable(..)

14− , ($*)

15− , listTable

16− , nameListTable

14+ , listTable, nameListTable

1715 )

1816where

1917

@@ -30,7 +28,7 @@ import Rel8.Schema.HTable.List ( HListTable )

3028import Rel8.Schema.HTable.Vectorize

3129 ( hvectorize, hunvectorize

3230 , happend, hempty

33− , hproject, hcolumn

31+ , hproject

3432 )

3533import qualified Rel8.Schema.Kind as K

3634import Rel8.Schema.Name ( Name( Name ) )

@@ -48,9 +46,7 @@ import Rel8.Table.Alternative

4846 )

4947import Rel8.Table.Eq ( EqTable, eqTable )

5048import Rel8.Table.Ord ( OrdTable, ordTable )

51−import Rel8.Table.Projection

52− ( Projectable, Projecting, Projection, project, apply

53− )

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

5450import Rel8.Table.Serialize ( ToExprs )

5551

5652

@@ -120,13 +116,6 @@ instance (context ~ Expr, Table Expr a) =>

120116 mempty = ListTable $ hempty $ \Spec {info} -> sempty info

121117

122118

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−

130119-- | Construct a @ListTable@ from a list of expressions.

131120listTable :: Table Expr a => [a] -> ListTable Expr a

132121listTable =

src/Rel8/Table/Maybe.hs−6

@@ -15,7 +15,6 @@ module Rel8.Table.Maybe

1515 ( MaybeTable(..)

1616 , maybeTable, nothingTable, justTable

1717 , isNothingTable, isJustTable

18− , fromMaybeTable

1918 , ($?)

2019 , aggregateMaybeTable

2120 , nameMaybeTable

@@ -207,11 +206,6 @@ justTable :: a -> MaybeTable Expr a

207206justTable = MaybeTable mempty . pure

208207

209208

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−

215209-- | Project a single expression out of a 'MaybeTable'. You can think of this

216210-- operator like the '$' operator, but it also has the ability to return

217211-- @null@.

src/Rel8/Table/NonEmpty.hs+3−14

@@ -11,9 +11,7 @@

1111

1212module Rel8.Table.NonEmpty

1313 ( NonEmptyTable(..)

14− , ($+)

15− , nonEmptyTable

16− , nameNonEmptyTable

14+ , nonEmptyTable, nameNonEmptyTable

1715 )

1816where

1917

@@ -31,7 +29,7 @@ import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable )

3129import Rel8.Schema.HTable.Vectorize

3230 ( hvectorize, hunvectorize

3331 , happend

34− , hproject, hcolumn

32+ , hproject

3533 )

3634import qualified Rel8.Schema.Kind as K

3735import Rel8.Schema.Name ( Name( Name ) )

@@ -46,9 +44,7 @@ import Rel8.Table

4644import Rel8.Table.Alternative ( AltTable, (<|>:) )

4745import Rel8.Table.Eq ( EqTable, eqTable )

4846import Rel8.Table.Ord ( OrdTable, ordTable )

49−import Rel8.Table.Projection

50− ( Projectable, Projecting, Projection, project, apply

51− )

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

5248import Rel8.Table.Serialize ( ToExprs )

5349

5450

@@ -114,13 +110,6 @@ instance (Table Expr a, context ~ Expr) => Semigroup (NonEmptyTable context a)

114110 happend (const sappend1) as bs

115111

116112

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−

124113-- | Construct a @NonEmptyTable@ from a non-empty list of expressions.

125114nonEmptyTable :: Table Expr a => NonEmpty a -> NonEmptyTable Expr a

126115nonEmptyTable =

src/Rel8/Table/Null.hsdeleted−147

@@ -1,147 +0,0 @@

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−27

@@ -1,9 +1,7 @@

11{-# language DataKinds #-}

2−{-# language FlexibleContexts #-}

32{-# language FlexibleInstances #-}

43{-# language LambdaCase #-}

54{-# language MultiParamTypeClasses #-}

6−{-# language NamedFieldPuns #-}

75{-# language ScopedTypeVariables #-}

86{-# language StandaloneKindSignatures #-}

97{-# language TypeApplications #-}

@@ -14,13 +12,11 @@ module Rel8.Table.Nullify

1412 ( Nullify

1513 , aggregateNullify

1614 , guard

17− , isNull

1815 )

1916where

2017

2118-- base

2219import Control.Applicative ( liftA2 )

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

2420import Data.Functor.Identity ( runIdentity )

2521import Data.Kind ( Type )

2622import Prelude

@@ -31,8 +27,6 @@ import Control.Comonad ( Comonad, duplicate, extract, ComonadApply, (<@>) )

3127-- rel8

3228import Rel8.Aggregate ( Aggregate )

3329import Rel8.Expr ( Expr )

34−import Rel8.Expr.Bool ( (||.), false )

35−import qualified Rel8.Expr.Null as Expr

3630import Rel8.Kind.Context ( Reifiable, contextSing )

3731import Rel8.Schema.Context.Nullify

3832 ( Nullifiability( NAggregate, NExpr )

@@ -51,14 +45,12 @@ import Rel8.Schema.HTable.Nullify

5145 , hproject

5246 )

5347import qualified Rel8.Schema.Kind as K

54−import Rel8.Schema.Null ( Nullity( NotNull, Null ) )

5548import qualified Rel8.Schema.Result as R

5649import Rel8.Table

5750 ( Table, Columns, Context, toColumns, fromColumns

5851 , FromExprs, fromResult, toResult

5952 , Transpose

6053 )

61−import Rel8.Schema.Spec ( Spec( Spec, nullity ) )

6254import Rel8.Table.Eq ( EqTable, eqTable )

6355import Rel8.Table.Ord ( OrdTable, ordTable )

6456import Rel8.Table.Projection ( Projectable, apply, project )

@@ -190,22 +182,3 @@ guard :: (Reifiable context, HTable t)

190182 -> HNullify t context

191183guard tag isNonNull isNonNullExpr =

192184 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+47−31

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

77{-# language TypeFamilies #-}

88{-# language ViewPatterns #-}

10−{-# options_ghc -Wno-deprecations #-}

11−

1210module Rel8.Table.Opaleye

1311 ( aggregator

1412 , attributes

@@ -28,15 +26,17 @@ where

2826-- base

2927import Data.Functor.Const ( Const( Const ), getConst )

3028import Data.List.NonEmpty ( NonEmpty )

31−import Prelude

29+import Prelude hiding ( undefined )

3230

3331-- opaleye

34−import qualified Opaleye.Adaptors as Opaleye

35−import qualified Opaleye.Field as Opaleye ( Field_ )

3632import qualified Opaleye.Internal.Aggregate as Opaleye

33+import qualified Opaleye.Internal.Binary as Opaleye

34+import qualified Opaleye.Internal.Distinct as Opaleye

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

36+import qualified Opaleye.Internal.PackMap as Opaleye

37+import qualified Opaleye.Internal.Unpackspec as Opaleye

3838import qualified Opaleye.Internal.Values as Opaleye

39−import qualified Opaleye.Table as Opaleye

39+import qualified Opaleye.Internal.Table as Opaleye

4040

4141-- profunctors

4242import Data.Profunctor ( dimap, lmap )

@@ -46,25 +46,27 @@ import Rel8.Aggregate ( Aggregate( Aggregate ), Aggregates )

4646import Rel8.Expr ( Expr )

4747import Rel8.Expr.Opaleye

4848 ( fromPrimExpr, toPrimExpr

49− , scastExpr, traverseFieldP

49+ , traversePrimExpr

50+ , fromColumn, toColumn

51+ , scastExpr

5052 )

51−import Rel8.Schema.HTable ( htabulateA, hfield, hspecs, htabulate,

52− htraverseP, htraversePWithField )

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

5354import Rel8.Schema.Name ( Name( Name ), Selects, ppColumn )

5455import Rel8.Schema.Spec ( Spec(..) )

5556import Rel8.Schema.Table ( TableSchema(..), ppTable )

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

57−import Rel8.Type.Information ( typeName )

58+import Rel8.Table.Undefined ( undefined )

5859

5960-- semigroupoids

6061import Data.Functor.Apply ( WrappedApplicative(..) )

61−import Data.Profunctor.Product ( ProductProfunctor )

6262

6363

6464aggregator :: Aggregates aggregates exprs => Opaleye.Aggregator aggregates exprs

65−aggregator = dimap toColumns fromColumns $

66− htraverseP $

67− lmap (\(Aggregate a) -> (a, ())) Opaleye.aggregatorApply

65+aggregator = Opaleye.Aggregator $ Opaleye.PackMap $ \f aggregates ->

66+ fmap fromColumns $ unwrapApplicative $ htabulateA $ \field ->

67+ WrapApplicative $ case hfield (toColumns aggregates) field of

68+ Aggregate (Opaleye.Aggregator (Opaleye.PackMap inner)) ->

69+ inner f ()

6870

6971

7072attributes :: Selects names exprs => TableSchema names -> exprs

@@ -75,19 +77,22 @@ attributes schema@TableSchema {columns} = fromColumns $ htabulate $ \field ->

7577 show (ppTable schema) <> "." <> show (ppColumn column)

7678

7779

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

83−

84−

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

86−binaryspec = fromOpaleyespec Opaleye.binaryspecField

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

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

83+ WrapApplicative $

84+ case (hfield (toColumns as) field, hfield (toColumns bs) field) of

85+ (a, b) -> fromPrimExpr <$> f (toPrimExpr a, toPrimExpr b)

8786

8887

8988distinctspec :: Table Expr a => Opaleye.Distinctspec a a

90−distinctspec = fromOpaleyespec Opaleye.distinctspecField

89+distinctspec =

90+ Opaleye.Distinctspec $ Opaleye.Aggregator $ Opaleye.PackMap $ \f ->

91+ fmap fromColumns .

92+ unwrapApplicative .

93+ htraverse

94+ (\a -> WrapApplicative $ fromPrimExpr <$> f (Nothing, toPrimExpr a)) .

95+ toColumns

9196

9297

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

@@ -106,8 +111,8 @@ exprsWithNames names as = getConst $ htabulateA $ \field ->

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

107112table (TableSchema name schema columns) =

108113 case schema of

109− Nothing -> Opaleye.table name (tableFields columns)

110− Just schemaName -> Opaleye.tableWithSchema schemaName name (tableFields columns)

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

115+ Just schemaName -> Opaleye.TableWithSchema schemaName name (tableFields columns)

111116

112117

113118tableFields :: Selects names exprs

@@ -119,19 +124,21 @@ tableFields (toColumns -> names) = dimap toColumns fromColumns $

119124 where

120125 go :: Name a -> Opaleye.TableFields (Expr a) (Expr a)

121126 go (Name name) =

122− traverseFieldP $

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

123128 Opaleye.requiredTableField name

124129

125130

126131unpackspec :: Table Expr a => Opaleye.Unpackspec a a

127−unpackspec = fromOpaleyespec Opaleye.unpackspecField

132+unpackspec = Opaleye.Unpackspec $ Opaleye.PackMap $ \f ->

133+ fmap fromColumns .

134+ unwrapApplicative .

135+ htraverse (WrapApplicative . traversePrimExpr f) .

136+ toColumns

128137{-# INLINABLE unpackspec #-}

129138

130139

131−valuesspec :: Table Expr a => Opaleye.Valuesspec a a

132−valuesspec = dimap toColumns fromColumns $

133− htraversePWithField (traverseFieldP . Opaleye.valuesspecFieldType . typeName)

134− where typeName = Rel8.Type.Information.typeName . info . hfield hspecs

140+valuesspec :: Table Expr a => Opaleye.ValuesspecSafe a a

141+valuesspec = Opaleye.ValuesspecSafe (toPackMap undefined) unpackspec

135142

136143

137144view :: Selects names exprs => names -> exprs

@@ -140,6 +147,15 @@ view columns = fromColumns $ htabulate $ \field ->

140147 Name column -> fromPrimExpr $ Opaleye.BaseTableAttrExpr column

141148

142149

150+toPackMap :: Table Expr a

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

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

153+ fmap fromColumns $

154+ unwrapApplicative .

155+ htraverse (WrapApplicative . traversePrimExpr f) $

156+ toColumns as

157+

158+

143159-- | Transform a table by adding 'CAST' to all columns. This is most useful for

144160-- finalising a SELECT or RETURNING statement, guaranteed that the output

145161-- matches what is encoded in each columns TypeInformation.

src/Rel8/Table/Ord.hs+2−2

@@ -146,9 +146,9 @@ infix 4 >=:

146146

147147-- | Given two 'Table's, return the table that sorts before the other.

148148least :: OrdTable a => a -> a -> a

149−least a b = bool b a (a <: b)

149+least a b = bool a b (a <: b)

150150

151151

152152-- | Given two 'Table's, return the table that sorts after the other.

153153greatest :: OrdTable a => a -> a -> a

154−greatest a b = bool b a (a >: b)

154+greatest a b = bool a b (a >: b)

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

@@ -35,7 +35,7 @@ class

3535 => Projecting a b

3636instance

3737 ( Transposes (Context a) (Field a) a (Transpose (Field a) a)

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

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

3939 )

4040 => Projecting a b

4141

src/Rel8/Table/These.hs+3−14

@@ -20,7 +20,6 @@ module Rel8.Table.These

2020 , isThisTable, isThatTable, isThoseTable

2121 , hasHereTable, hasThereTable

2222 , justHereTable, justThereTable

23− , alignMaybeTable

2423 , aggregateTheseTable

2524 , nameTheseTable

2625 )

@@ -30,13 +29,13 @@ where

3029import Data.Bifunctor ( Bifunctor, bimap )

3130import Data.Kind ( Type )

3231import Data.Maybe ( isJust )

33−import Prelude hiding ( null, undefined )

32+import Prelude hiding ( undefined )

3433

3534-- rel8

3635import Rel8.Aggregate ( Aggregate )

3736import Rel8.Expr ( Expr )

38−import Rel8.Expr.Bool ( (&&.), (||.), boolExpr, not_ )

39−import Rel8.Expr.Null ( null, isNonNull )

37+import Rel8.Expr.Bool ( (&&.), not_ )

38+import Rel8.Expr.Null ( isNonNull )

4039import Rel8.Kind.Context ( Reifiable )

4140import Rel8.Schema.Context.Nullify ( Nullifiable )

4241import Rel8.Schema.Dict ( Dict( Dict ) )

@@ -289,16 +288,6 @@ justThereTable :: TheseTable context a b -> MaybeTable context b

289288justThereTable = there

290289

291290

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−

302291-- | Construct a @TheseTable@. Corresponds to 'This'.

303292thisTable :: Table Expr b => a -> TheseTable Expr a b

304293thisTable a = TheseTable (justTable a) nothingTable

src/Rel8/Table/Window.hsdeleted−43

@@ -1,43 +0,0 @@

1−{-# language MonoLocalBinds #-}

2−

3−module Rel8.Table.Window

4− ( cumulative

5− , cumulative_

6− , currentRow

7− )

8−where

9−

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.hsdeleted−640

@@ -1,640 +0,0 @@

1−{-# language FlexibleContexts #-}

2−{-# language MonoLocalBinds #-}

3−{-# language ScopedTypeVariables #-}

4−{-# language StandaloneKindSignatures #-}

5−{-# language TypeApplications #-}

6−{-# language TupleSections #-}

7−{-# language UndecidableInstances #-}

8−

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+8−9

@@ -1,4 +1,3 @@

1−{-# language FlexibleContexts #-}

21{-# language FlexibleInstances #-}

32{-# language MonoLocalBinds #-}

43{-# language MultiWayIf #-}

@@ -128,10 +127,10 @@ instance DBType Int64 where

128127instance DBType Float where

129128 typeInformation = TypeInformation

130129 { encode = \x -> Opaleye.ConstExpr

131− if | x == (1 / 0) -> Opaleye.OtherLit "'Infinity'"

132− | isNaN x -> Opaleye.OtherLit "'NaN'"

133− | x == (-1 / 0) -> Opaleye.OtherLit "'-Infinity'"

134− | otherwise -> Opaleye.NumericLit $ realToFrac x

130+ if | x == (1 /0) -> Opaleye.OtherLit "'Infinity'"

131+ | isNaN x -> Opaleye.OtherLit "'NaN'"

132+ | x == (-1/0) -> Opaleye.OtherLit "'-Infinity'"

133+ | otherwise -> Opaleye.NumericLit $ realToFrac x

135134 , decode = Hasql.float4

136135 , typeName = "float4"

137136 }

@@ -141,10 +140,10 @@ instance DBType Float where

141140instance DBType Double where

142141 typeInformation = TypeInformation

143142 { encode = \x -> Opaleye.ConstExpr

144− if | x == (1 / 0) -> Opaleye.OtherLit "'Infinity'"

145− | isNaN x -> Opaleye.OtherLit "'NaN'"

146− | x == (-1 / 0) -> Opaleye.OtherLit "'-Infinity'"

147− | otherwise -> Opaleye.NumericLit $ realToFrac x

143+ if | x == (1 /0) -> Opaleye.OtherLit "'Infinity'"

144+ | isNaN x -> Opaleye.OtherLit "'NaN'"

145+ | x == (-1/0) -> Opaleye.OtherLit "'-Infinity'"

146+ | otherwise -> Opaleye.NumericLit $ realToFrac x

148147 , decode = Hasql.float8

149148 , typeName = "float8"

150149 }

src/Rel8/Type/Enum.hs−1

@@ -106,7 +106,6 @@ class (DBType a, Enumable a) => DBEnum a where

106106

107107-- | Types that are sum types, where each constructor is unary (that is, has no

108108-- fields).

109−type Enumable :: Type -> Constraint

110109class (Generic a, GEnumable (Rep a)) => Enumable a

111110instance (Generic a, GEnumable (Rep a)) => Enumable a

112111

src/Rel8/Type/JSONBEncoded.hs−4

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

1−{-# language StandaloneKindSignatures #-}

2−

31module Rel8.Type.JSONBEncoded ( JSONBEncoded(..) ) where

53-- aeson

@@ -8,7 +6,6 @@ import Data.Aeson.Types ( parseEither )

97-- base

108import Data.Bifunctor ( first )

11−import Data.Kind ( Type )

129import Prelude

1310

1411-- hasql

@@ -23,7 +20,6 @@ import Data.Text ( pack )

2320

2421

2522-- | Like 'Rel8.JSONEncoded', but works for @jsonb@ columns.

26−type JSONBEncoded :: Type -> Type

2723newtype JSONBEncoded a = JSONBEncoded { fromJSONBEncoded :: a }

2824

2925

src/Rel8/Type/JSONEncoded.hs−4

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

1−{-# language StandaloneKindSignatures #-}

2−

31module Rel8.Type.JSONEncoded ( JSONEncoded(..) ) where

53-- aeson

@@ -7,7 +5,6 @@ import Data.Aeson ( FromJSON, ToJSON, parseJSON, toJSON )

75import Data.Aeson.Types ( parseEither )

97-- base

10−import Data.Kind ( Type )

118import Prelude

129

1310-- rel8

@@ -18,7 +15,6 @@ import Rel8.Type.Information ( parseTypeInformation )

1815-- | A deriving-via helper type for column types that store a Haskell value

1916-- using a JSON encoding described by @aeson@'s 'ToJSON' and 'FromJSON' type

2017-- classes.

21−type JSONEncoded :: Type -> Type

2218newtype JSONEncoded a = JSONEncoded { fromJSONEncoded :: a }

2319

2420

src/Rel8/Type/Num.hs+1−4

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

1818

1919-- rel8

2020import Rel8.Type ( DBType )

21−import Rel8.Type.Ord ( DBOrd )

2221

2322-- scientific

2423import Data.Scientific ( Scientific )

@@ -40,14 +39,13 @@ instance DBNum Scientific

4039-- expressions. This is a Rel8 concept, and allows us to provide

4140-- 'fromIntegral'.

4241type DBIntegral :: Type -> Constraint

43−class (DBNum a, DBOrd a) => DBIntegral a

42+class DBNum a => DBIntegral a

4443instance DBIntegral Int16

4544instance DBIntegral Int32

4645instance DBIntegral Int64

4746

4847

4948-- | The class of database types that support the @/@ operator.

50−type DBFractional :: Type -> Constraint

5149class DBNum a => DBFractional a

5250instance DBFractional Float

5351instance DBFractional Double

@@ -55,7 +53,6 @@ instance DBFractional Scientific

5553

5654

5755-- | The class of database types that support the @/@ operator.

58−type DBFloating :: Type -> Constraint

5956class DBFractional a => DBFloating a

6057instance DBFloating Float

6158instance DBFloating Double

src/Rel8/Type/Ord.hs+2

@@ -75,6 +75,7 @@ instance Sql DBOrd a => DBOrd (NonEmpty a)

7575-- | The class of database types that support the @max@ aggregation function.

7676type DBMax :: Type -> Constraint

7777class DBOrd a => DBMax a

78+instance DBMax Bool

7879instance DBMax Char

7980instance DBMax Int16

8081instance DBMax Int32

@@ -100,6 +101,7 @@ instance Sql DBMax a => DBMax (NonEmpty a)

100101-- | The class of database types that support the @min@ aggregation function.

101102type DBMin :: Type -> Constraint

102103class DBOrd a => DBMin a

104+instance DBMin Bool

103105instance DBMin Char

104106instance DBMin Int16

105107instance DBMin Int32

src/Rel8/Type/ReadShow.hs−3

@@ -1,12 +1,10 @@

11{-# language ScopedTypeVariables #-}

2−{-# language StandaloneKindSignatures #-}

32{-# language TypeApplications #-}

43{-# language ViewPatterns #-}

65module Rel8.Type.ReadShow ( ReadShow(..) ) where

87-- base

9−import Data.Kind ( Type )

108import Data.Proxy ( Proxy( Proxy ) )

119import Data.Typeable ( Typeable, typeRep )

1210import Prelude

@@ -22,7 +20,6 @@ import qualified Data.Text as Text

2220

2321-- | A deriving-via helper type for column types that store a Haskell value

2422-- using a Haskell's 'Read' and 'Show' type classes.

25−type ReadShow :: Type -> Type

2623newtype ReadShow a = ReadShow { fromReadShow :: a }

2724

2825

src/Rel8/Type/Tag.hs−1

@@ -90,7 +90,6 @@ instance DBMonoid MaybeTag where

9090 memptyExpr = litExpr mempty

9191

9292

93−type Tag :: Type

9493newtype Tag = Tag Text

9594 deriving newtype

9695 ( Eq, Ord, Read, Show

src/Rel8/Window.hsdeleted−97

@@ -1,97 +0,0 @@

1−{-# language DerivingVia #-}

2−{-# language FlexibleContexts #-}

3−{-# language GeneralizedNewtypeDeriving #-}

4−{-# language ScopedTypeVariables #-}

5−{-# language StandaloneKindSignatures #-}

6−{-# language TypeApplications #-}

7−

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+164−273

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

1−{-# language BangPatterns #-}

21{-# language BlockArguments #-}

2+{-# language DataKinds #-}

33{-# language DeriveAnyClass #-}

44{-# language DeriveGeneric #-}

55{-# language DerivingStrategies #-}

6+{-# language DisambiguateRecordFields #-}

67{-# language FlexibleContexts #-}

78{-# language FlexibleInstances #-}

8−{-# language MonoLocalBinds #-}

9+{-# language GADTs #-}

910{-# language NamedFieldPuns #-}

1011{-# language OverloadedStrings #-}

1112{-# language RecordWildCards #-}

@@ -13,15 +14,17 @@

1314{-# language StandaloneDeriving #-}

1415{-# language TypeApplications #-}

1516

17+{-# options_ghc -fno-warn-redundant-constraints #-}

18+

1619module Main

1720 ( main

1821 )

1922where

2023

2124-- base

22−import Control.Applicative ( empty, liftA2, liftA3 )

23−import Control.Exception ( bracket, throwIO )

24−import Control.Monad ( (>=>), void )

25+import Control.Applicative ( liftA2, liftA3 )

26+import Control.Monad (void)

27+import Control.Monad.IO.Class ( MonadIO, liftIO )

2528import Data.Bifunctor ( bimap )

2629import Data.Foldable ( for_ )

2730import Data.Int ( Int32, Int64 )

@@ -35,27 +38,25 @@ import GHC.Generics ( Generic )

3538import qualified Data.ByteString.Lazy

3639

3740-- case-insensitive

38−import Data.CaseInsensitive ( mk )

41+import Data.CaseInsensitive (mk)

3942

4043-- containers

41−import Data.Containers.ListUtils ( nubOrdOn )

4244import qualified Data.Map.Strict as Map

4345

4446-- hasql

45−import Hasql.Connection ( Connection, acquire, release )

47+import Hasql.Connection ( Connection, acquire, release )

4648import Hasql.Session ( sql, run )

4749

48−-- hasql-transaction

49−import Hasql.Transaction ( Transaction, condemn, statement )

50−import qualified Hasql.Transaction.Sessions as Hasql

51−

5250-- hedgehog

5351import Hedgehog ( property, (===), forAll, cover, diff, evalM, PropertyT, TestT, test, Gen )

5452import qualified Hedgehog.Gen as Gen

5553import qualified Hedgehog.Range as Range

5654

57−-- mmorph

58−import Control.Monad.Morph ( hoist )

55+-- lifted-base

56+import Control.Exception.Lifted ( bracket, throwIO, bracket_ )

57+

58+-- monad-control

59+import Control.Monad.Trans.Control ( MonadBaseControl )

5960

6061-- rel8

6162import Rel8 ( Result )

@@ -71,16 +72,12 @@ import Test.Tasty

7172import Test.Tasty.Hedgehog ( testProperty )

7273

7374-- text

74−import Data.Text ( Text, pack, unpack )

75+import Data.Text (Text, pack)

7576import qualified Data.Text.Lazy

76−import Data.Text.Encoding ( decodeUtf8 )

7777

7878-- time

7979import Data.Time

8080

81−-- transformers

82−import Control.Monad.Trans.Class ( lift )

83−

8481-- tmp-postgres

8582import qualified Database.Postgres.Temp as TmpPostgres

8683

@@ -116,13 +113,11 @@ tests =

116113 , testCatMaybeTable getTestDatabase

117114 , testCatMaybe getTestDatabase

118115 , testMaybeTable getTestDatabase

119− , testAggregateMaybeTable getTestDatabase

120116 , testNestedTables getTestDatabase

121117 , testMaybeTableApplicative getTestDatabase

122118 , testLogicalFixities getTestDatabase

123119 , testUpdate getTestDatabase

124120 , testDelete getTestDatabase

125− , testUpsert getTestDatabase

126121 , testSelectNestedPairs getTestDatabase

127122 , testSelectArray getTestDatabase

128123 , testNestedMaybeTable getTestDatabase

@@ -138,7 +133,6 @@ tests =

138133 flip run conn do

139134 sql "CREATE EXTENSION citext"

140135 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 )"

142136 sql "CREATE SEQUENCE test_seq"

143137

144138 return db

@@ -146,21 +140,19 @@ tests =

146140 stopTestDatabase = TmpPostgres.stop

147141

148142

149−connect :: TmpPostgres.DB -> IO Connection

150−connect = acquire . TmpPostgres.toConnectionString >=> either (maybe empty (fail . unpack . decodeUtf8)) pure

151−

152−

153143databasePropertyTest

154144 :: TestName

155− -> ((TestT Transaction () -> PropertyT IO ()) -> PropertyT IO ())

145+ -> (((Connection -> TestT IO ()) -> PropertyT IO ()) -> PropertyT IO ())

156146 -> IO TmpPostgres.DB -> TestTree

157147databasePropertyTest testName f getTestDatabase =

158− withResource (connect =<< getTestDatabase) release $ \c ->

148+ withResource connect release $ \c ->

159149 testProperty testName $ property do

160− connection <- lift c

161− f $ test . hoist \m -> do

162− e <- run (Hasql.transaction Hasql.Serializable Hasql.Write (m <* condemn)) connection

163− either throwIO pure e

150+ connection <- liftIO c

151+ f \g -> test $ rollingBack connection $ g connection

152+

153+ where

154+

155+ connect = either (error . show) return =<< acquire . TmpPostgres.toConnectionString =<< getTestDatabase

164156

165157

166158data TestTable f = TestTable

@@ -192,17 +184,17 @@ testSelectTestTable :: IO TmpPostgres.DB -> TestTree

192184testSelectTestTable = databasePropertyTest "Can SELECT TestTable" \transaction -> do

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

194186

195− transaction do

196− selected <- lift do

197− statement () $ Rel8.insert Rel8.Insert

187+ transaction \connection -> do

188+ liftIO $ Rel8.insert connection

189+ Rel8.Insert

198190 { into = testTableSchema

199191 , rows = Rel8.values $ map Rel8.lit rows

200192 , onConflict = Rel8.DoNothing

201193 , returning = pure ()

202194 }

203195

204− statement () $ Rel8.select do

205− Rel8.each testTableSchema

196+ selected <- liftIO $ Rel8.select connection do

197+ Rel8.each testTableSchema

206198

207199 sort selected === sort rows

208200

@@ -219,12 +211,11 @@ testWhere_ = databasePropertyTest "WHERE (Rel8.where_)" \transaction -> do

219211

220212 let expected = filter (\t -> testTableColumn2 t == magicBool) rows

221213

222− transaction do

223− selected <- lift do

224− statement () $ Rel8.select do

225− t <- Rel8.values $ Rel8.lit <$> rows

226− Rel8.where_ $ testTableColumn2 t Rel8.==. Rel8.lit magicBool

227− return t

214+ transaction \connection -> do

215+ selected <- liftIO $ Rel8.select connection do

216+ t <- Rel8.values $ Rel8.lit <$> rows

217+ Rel8.where_ $ testTableColumn2 t Rel8.==. Rel8.lit magicBool

218+ return t

228219

229220 sort selected === sort expected

230221

@@ -237,12 +228,11 @@ testFilter :: IO TmpPostgres.DB -> TestTree

237228testFilter = databasePropertyTest "filter" \transaction -> do

238229 rows <- forAll $ Gen.list (Range.linear 1 10) genTestTable

239230

240− transaction do

231+ transaction \connection -> do

241232 let expected = filter testTableColumn2 rows

242233

243− selected <- lift do

244− statement () $ Rel8.select do

245− Rel8.filter testTableColumn2 =<< Rel8.values (Rel8.lit <$> rows)

234+ selected <- liftIO $ Rel8.select connection

235+ $ Rel8.filter testTableColumn2 =<< Rel8.values (Rel8.lit <$> rows)

246236

247237 sort selected === sort expected

248238

@@ -257,10 +247,9 @@ testLimit = databasePropertyTest "LIMIT (Rel8.limit)" \transaction -> do

257247

258248 n <- forAll $ Gen.integral (Range.linear 0 10)

259249

260− transaction do

261− selected <- lift do

262− statement () $ Rel8.select do

263− Rel8.limit n $ Rel8.values (Rel8.lit <$> rows)

250+ transaction \connection -> do

251+ selected <- liftIO $ Rel8.select connection do

252+ Rel8.limit n $ Rel8.values (Rel8.lit <$> rows)

264253

265254 diff (length selected) (<=) (fromIntegral n)

266255

@@ -278,10 +267,9 @@ testUnion = databasePropertyTest "UNION (Rel8.union)" \transaction -> evalM do

278267 left <- forAll $ Gen.list (Range.linear 0 10) genTestTable

279268 right <- forAll $ Gen.list (Range.linear 0 10) genTestTable

280269

281− transaction do

282− selected <- lift do

283− statement () $ Rel8.select do

284− Rel8.values (Rel8.lit <$> nub left) `Rel8.union` Rel8.values (Rel8.lit <$> nub right)

270+ transaction \connection -> do

271+ selected <- liftIO $ Rel8.select connection do

272+ Rel8.values (Rel8.lit <$> nub left) `Rel8.union` Rel8.values (Rel8.lit <$> nub right)

285273

286274 sort selected === sort (nub (left ++ right))

287275

@@ -290,11 +278,9 @@ testDistinct :: IO TmpPostgres.DB -> TestTree

290278testDistinct = databasePropertyTest "DISTINCT (Rel8.distinct)" \transaction -> do

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

292280

293− transaction do

294− selected <- lift do

295− statement () $ Rel8.select do

296− Rel8.distinct do

297− Rel8.values (Rel8.lit <$> rows)

281+ transaction \connection -> do

282+ selected <- liftIO $ Rel8.select connection $ Rel8.distinct do

283+ Rel8.values (Rel8.lit <$> rows)

298284

299285 sort selected === nub (sort rows)

300286

@@ -307,10 +293,8 @@ testExists :: IO TmpPostgres.DB -> TestTree

307293testExists = databasePropertyTest "EXISTS (Rel8.exists)" \transaction -> do

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

309295

310− transaction do

311− exists <- lift do

312− statement () $ Rel8.select do

313− Rel8.exists $ Rel8.values $ Rel8.lit <$> rows

296+ transaction \connection -> do

297+ exists <- liftIO $ Rel8.select connection $ Rel8.exists $ Rel8.values $ Rel8.lit <$> rows

314298

315299 case rows of

316300 [] -> exists === [False]

@@ -321,10 +305,9 @@ testOptional :: IO TmpPostgres.DB -> TestTree

321305testOptional = databasePropertyTest "Rel8.optional" \transaction -> do

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

323307

324− transaction do

325− selected <- lift do

326− statement () $ Rel8.select do

327− Rel8.optional $ Rel8.values (Rel8.lit <$> rows)

308+ transaction \connection -> do

309+ selected <- liftIO $ Rel8.select connection do

310+ Rel8.optional $ Rel8.values (Rel8.lit <$> rows)

328311

329312 case rows of

330313 [] -> selected === [Nothing]

@@ -335,10 +318,9 @@ testAnd :: IO TmpPostgres.DB -> TestTree

335318testAnd = databasePropertyTest "AND (&&.)" \transaction -> do

336319 (x, y) <- forAll $ liftA2 (,) Gen.bool Gen.bool

337320

338− transaction do

339− [result] <- lift do

340− statement () $ Rel8.select do

341− pure $ Rel8.lit x Rel8.&&. Rel8.lit y

321+ transaction \connection -> do

322+ [result] <- liftIO $ Rel8.select connection $ pure $

323+ Rel8.lit x Rel8.&&. Rel8.lit y

342324

343325 result === (x && y)

344326

@@ -347,10 +329,9 @@ testOr :: IO TmpPostgres.DB -> TestTree

347329testOr = databasePropertyTest "OR (||.)" \transaction -> do

348330 (x, y) <- forAll $ liftA2 (,) Gen.bool Gen.bool

349331

350− transaction do

351− [result] <- lift do

352− statement () $ Rel8.select $ pure $

353− Rel8.lit x Rel8.||. Rel8.lit y

332+ transaction \connection -> do

333+ [result] <- liftIO $ Rel8.select connection $ pure $

334+ Rel8.lit x Rel8.||. Rel8.lit y

354335

355336 result === (x || y)

356337

@@ -359,10 +340,9 @@ testLogicalFixities :: IO TmpPostgres.DB -> TestTree

359340testLogicalFixities = databasePropertyTest "Logical operator fixities" \transaction -> do

360341 (u, v, w, x) <- forAll $ (,,,) <$> Gen.bool <*> Gen.bool <*> Gen.bool <*> Gen.bool

361342

362− transaction do

363− [result] <- lift do

364− statement () $ Rel8.select do

365− pure $ Rel8.lit u Rel8.||. Rel8.lit v Rel8.&&. Rel8.lit w Rel8.==. Rel8.lit x

343+ transaction \connection -> do

344+ [result] <- liftIO $ Rel8.select connection $ pure $

345+ Rel8.lit u Rel8.||. Rel8.lit v Rel8.&&. Rel8.lit w Rel8.==. Rel8.lit x

366346

367347 result === (u || v && w == x)

368348

@@ -371,10 +351,9 @@ testNot :: IO TmpPostgres.DB -> TestTree

371351testNot = databasePropertyTest "NOT (not_)" \transaction -> do

372352 x <- forAll Gen.bool

373353

374− transaction do

375− [result] <- lift do

376− statement () $ Rel8.select do

377− pure $ Rel8.not_ $ Rel8.lit x

354+ transaction \connection -> do

355+ [result] <- liftIO $ Rel8.select connection $ pure $

356+ Rel8.not_ $ Rel8.lit x

378357

379358 result === not x

380359

@@ -383,10 +362,9 @@ testBool :: IO TmpPostgres.DB -> TestTree

383362testBool = databasePropertyTest "ifThenElse_" \transaction -> do

384363 (x, y, z) <- forAll $ liftA3 (,,) Gen.bool Gen.bool Gen.bool

385364

386− transaction do

387− [result] <- lift do

388− statement () $ Rel8.select do

389− pure $ Rel8.bool (Rel8.lit z) (Rel8.lit y) (Rel8.lit x)

365+ transaction \connection -> do

366+ [result] <- liftIO $ Rel8.select connection $ pure $

367+ Rel8.bool (Rel8.lit z) (Rel8.lit y) (Rel8.lit x)

390368

391369 result === if x then y else z

392370

@@ -398,10 +376,9 @@ testAp = databasePropertyTest "Cartesian product (<*>)" \transaction -> do

398376 (Gen.list (Range.linear 1 10) genTestTable)

399377 (Gen.list (Range.linear 1 10) genTestTable)

400378

401− transaction do

402− result <- lift do

403− statement () $ Rel8.select do

404− liftA2 (,) (Rel8.values (Rel8.lit <$> rows1)) (Rel8.values (Rel8.lit <$> rows2))

379+ transaction \connection -> do

380+ result <- liftIO $ Rel8.select connection $ do

381+ liftA2 (,) (Rel8.values (Rel8.lit <$> rows1)) (Rel8.values (Rel8.lit <$> rows2))

405382

406383 sort result === sort (liftA2 (,) rows1 rows2)

407384

@@ -430,22 +407,21 @@ testDBType getTestDatabase = testGroup "DBType instances"

430407 where

431408 dbTypeTest :: (Eq a, Show a, Rel8.DBType a) => TestName -> Gen a -> TestTree

432409 dbTypeTest name generator = testGroup name

433− [ databasePropertyTest name (t generator) getTestDatabase

434− , databasePropertyTest ("Maybe " <> name) (t (Gen.maybe generator)) getTestDatabase

410+ [ databasePropertyTest name (t (==) generator) getTestDatabase

411+ , databasePropertyTest ("Maybe " <> name) (t (==) (Gen.maybe generator)) getTestDatabase

435412 ]

436413

437− t :: forall a b. (Eq a, Show a, Rel8.Sql Rel8.DBType a)

438− => Gen a

439− -> (TestT Transaction () -> PropertyT IO b)

414+ t :: forall a b. (Show a, Rel8.Sql Rel8.DBType a)

415+ => (a -> a -> Bool)

416+ -> Gen a

417+ -> ((Connection -> TestT IO ()) -> PropertyT IO b)

440418 -> PropertyT IO b

441− t generator transaction = do

419+ t eq generator transaction = do

442420 x <- forAll generator

443421

444− transaction do

445− [res] <- lift do

446− statement () $ Rel8.select do

447− pure (Rel8.litExpr x)

448− diff res (==) x

422+ transaction \connection -> do

423+ [res] <- liftIO $ Rel8.select connection $ pure (Rel8.litExpr x)

424+ diff res eq x

449425

450426 genDay :: Gen Day

451427 genDay = do

@@ -487,15 +463,13 @@ testDBEq getTestDatabase = testGroup "DBEq instances"

487463

488464 t :: forall a. (Eq a, Show a, Rel8.Sql Rel8.DBEq a)

489465 => Gen a

490− -> (TestT Transaction () -> PropertyT IO ())

466+ -> ((Connection -> TestT IO ()) -> PropertyT IO ())

491467 -> PropertyT IO ()

492468 t generator transaction = do

493469 (x, y) <- forAll (liftA2 (,) generator generator)

494470

495− transaction do

496− [res] <- lift do

497− statement () $ Rel8.select do

498− pure $ Rel8.litExpr x Rel8.==. Rel8.litExpr y

471+ transaction \connection -> do

472+ [res] <- liftIO $ Rel8.select connection $ pure $ Rel8.litExpr x Rel8.==. Rel8.litExpr y

499473 res === (x == y)

500474

501475

@@ -503,10 +477,9 @@ testTableEquality :: IO TmpPostgres.DB -> TestTree

503477testTableEquality = databasePropertyTest "TestTable equality" \transaction -> do

504478 (x, y) <- forAll $ liftA2 (,) genTestTable genTestTable

505479

506− transaction do

507− [eq] <- lift do

508− statement () $ Rel8.select do

509− pure $ Rel8.lit x Rel8.==: Rel8.lit y

480+ transaction \connection -> do

481+ [eq] <- liftIO $ Rel8.select connection do

482+ pure $ Rel8.lit x Rel8.==: Rel8.lit y

510483

511484 eq === (x == y)

512485

@@ -515,10 +488,8 @@ testFromString :: IO TmpPostgres.DB -> TestTree

515488testFromString = databasePropertyTest "FromString" \transaction -> do

516489 str <- forAll $ Gen.list (Range.linear 0 10) Gen.unicode

517490

518− transaction do

519− [result] <- lift do

520− statement () $ Rel8.select do

521− pure $ fromString str

491+ transaction \connection -> do

492+ [result] <- liftIO $ Rel8.select connection $ pure $ fromString str

522493 result === pack str

523494

524495

@@ -526,11 +497,10 @@ testCatMaybeTable :: IO TmpPostgres.DB -> TestTree

526497testCatMaybeTable = databasePropertyTest "catMaybeTable" \transaction -> do

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

528499

529− transaction do

530− selected <- lift do

531− statement () $ Rel8.select do

532− testTable <- Rel8.values $ Rel8.lit <$> rows

533− Rel8.catMaybeTable $ Rel8.bool Rel8.nothingTable (pure testTable) (testTableColumn2 testTable)

500+ transaction \connection -> do

501+ selected <- liftIO $ Rel8.select connection do

502+ testTable <- Rel8.values $ Rel8.lit <$> rows

503+ Rel8.catMaybeTable $ Rel8.bool Rel8.nothingTable (pure testTable) (testTableColumn2 testTable)

534504

535505 sort selected === sort (filter testTableColumn2 rows)

536506

@@ -539,10 +509,9 @@ testCatMaybe :: IO TmpPostgres.DB -> TestTree

539509testCatMaybe = databasePropertyTest "catMaybe" \transaction -> evalM do

540510 rows <- forAll $ Gen.list (Range.linear 0 10) $ Gen.maybe Gen.bool

541511

542− transaction do

543− selected <- lift do

544− statement () $ Rel8.select do

545− Rel8.catNull =<< Rel8.values (map Rel8.lit rows)

512+ transaction \connection -> do

513+ selected <- evalM $ liftIO $ Rel8.select connection do

514+ Rel8.catNull =<< Rel8.values (map Rel8.lit rows)

546515

547516 sort selected === sort (catMaybes rows)

548517

@@ -551,38 +520,15 @@ testMaybeTable :: IO TmpPostgres.DB -> TestTree

551520testMaybeTable = databasePropertyTest "maybeTable" \transaction -> evalM do

552521 (rows, def) <- forAll $ liftA2 (,) (Gen.list (Range.linear 0 10) genTestTable) genTestTable

553522

554− transaction do

555− selected <- lift do

556− statement () $ Rel8.select do

557− Rel8.maybeTable (Rel8.lit def) id <$> Rel8.optional (Rel8.values (Rel8.lit <$> rows))

523+ transaction \connection -> do

524+ selected <- liftIO $ Rel8.select connection $

525+ Rel8.maybeTable (Rel8.lit def) id <$> Rel8.optional (Rel8.values (Rel8.lit <$> rows))

558526

559527 case rows of

560528 [] -> selected === [def]

561529 _ -> sort selected === sort rows

562530

563531

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−

586532data TwoTestTables f =

587533 TwoTestTables

588534 { testTable1 :: TestTable f

@@ -603,10 +549,9 @@ testNestedTables = databasePropertyTest "Nested TestTables" \transaction -> eval

603549 Gen.list (Range.linear 0 10) $

604550 liftA2 TwoTestTables genTestTable genTestTable

605551

606− transaction do

607− selected <- lift do

608− statement () $ Rel8.select do

609− Rel8.values (Rel8.lit <$> rows)

552+ transaction \connection -> do

553+ selected <- liftIO $ Rel8.select connection do

554+ Rel8.values (Rel8.lit <$> rows)

610555

611556 sort selected === sort rows

612557

@@ -616,12 +561,11 @@ testMaybeTableApplicative = databasePropertyTest "MaybeTable (<*>)" \transaction

616561 rows1 <- genRows

617562 rows2 <- genRows

618563

619− transaction do

620− selected <- lift do

621− statement () $ Rel8.select do

622− as <- Rel8.optional (Rel8.values (Rel8.lit <$> rows1))

623− bs <- Rel8.optional (Rel8.values (Rel8.lit <$> rows2))

624− pure $ liftA2 (,) as bs

564+ transaction \connection -> do

565+ selected <- liftIO $ Rel8.select connection do

566+ as <- Rel8.optional (Rel8.values (Rel8.lit <$> rows1))

567+ bs <- Rel8.optional (Rel8.values (Rel8.lit <$> rows2))

568+ pure $ liftA2 (,) as bs

625569

626570 case (rows1, rows2) of

627571 ([], []) -> selected === [Nothing]

@@ -633,6 +577,14 @@ testMaybeTableApplicative = databasePropertyTest "MaybeTable (<*>)" \transaction

633577 genRows = forAll do

634578 Gen.list (Range.linear 0 10) $ liftA2 TestTable (Gen.text (Range.linear 0 10) Gen.unicode) (pure True)

635579

580+rollingBack

581+ :: (MonadBaseControl IO m, MonadIO m)

582+ => Connection -> m a -> m a

583+rollingBack connection =

584+ bracket_

585+ (liftIO (run (sql "BEGIN") connection))

586+ (liftIO (run (sql "ROLLBACK") connection))

587+

636588

637589genTestTable :: Gen (TestTable Result)

638590genTestTable = do

@@ -645,16 +597,17 @@ testUpdate :: IO TmpPostgres.DB -> TestTree

645597testUpdate = databasePropertyTest "Can UPDATE TestTable" \transaction -> do

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

647599

648− transaction do

649− selected <- lift do

650− statement () $ Rel8.insert Rel8.Insert

600+ transaction \connection -> do

601+ liftIO $ Rel8.insert connection

602+ Rel8.Insert

651603 { into = testTableSchema

652604 , rows = Rel8.values $ map Rel8.lit $ Map.keys rows

653605 , onConflict = Rel8.DoNothing

654606 , returning = pure ()

655607 }

656608

657− statement () $ Rel8.update Rel8.Update

609+ liftIO $ Rel8.update connection

610+ Rel8.Update

658611 { target = testTableSchema

659612 , from = pure ()

660613 , set = \_ r ->

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

675628 , returning = pure ()

676629 }

677630

678− statement () $ Rel8.select do

679− Rel8.each testTableSchema

631+ selected <- liftIO $ Rel8.select connection do

632+ Rel8.each testTableSchema

680633

681634 sort selected === sort (Map.elems rows)

682635

@@ -689,96 +642,30 @@ testDelete :: IO TmpPostgres.DB -> TestTree

689642testDelete = databasePropertyTest "Can DELETE TestTable" \transaction -> do

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

691644

692− transaction do

693− (deleted, selected) <- lift do

694− statement () $ Rel8.insert Rel8.Insert

645+ transaction \connection -> do

646+ liftIO $ Rel8.insert connection

647+ Rel8.Insert

695648 { into = testTableSchema

696649 , rows = Rel8.values $ map Rel8.lit rows

697650 , onConflict = Rel8.DoNothing

698651 , returning = pure ()

699652 }

700653

701− deleted <- statement () $ Rel8.delete Rel8.Delete

654+ deleted <-

655+ liftIO $ Rel8.delete connection

656+ Rel8.Delete

702657 { from = testTableSchema

703658 , using = pure ()

704659 , deleteWhere = const testTableColumn2

705660 , returning = Rel8.Projection id

706661 }

707662

708− selected <- statement () $ Rel8.select do

709− Rel8.each testTableSchema

710−

711− pure (deleted, selected)

663+ selected <- liftIO $ Rel8.select connection do

664+ Rel8.each testTableSchema

712665

713666 sort (deleted <> selected) === sort rows

714667

715668

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−

782669newtype HKNestedPair f = HKNestedPair { pairOne :: (TestTable f, TestTable f) }

783670 deriving stock Generic

784671 deriving anyclass Rel8.Rel8able

@@ -792,10 +679,9 @@ testSelectNestedPairs :: IO TmpPostgres.DB -> TestTree

792679testSelectNestedPairs = databasePropertyTest "Can SELECT nested pairs" \transaction -> do

793680 rows <- forAll $ Gen.list (Range.linear 0 10) $ HKNestedPair <$> liftA2 (,) genTestTable genTestTable

794681

795− transaction do

796− selected <- lift do

797− statement () $ Rel8.select do

798− Rel8.values $ map Rel8.lit rows

682+ transaction \connection -> do

683+ selected <- liftIO $ Rel8.select connection do

684+ Rel8.values $ map Rel8.lit rows

799685

800686 sort selected === sort rows

801687

@@ -804,20 +690,18 @@ testSelectArray :: IO TmpPostgres.DB -> TestTree

804690testSelectArray = databasePropertyTest "Can SELECT Arrays (with aggregation)" \transaction -> do

805691 rows <- forAll $ Gen.list (Range.linear 1 10) Gen.bool

806692

807− transaction do

808− selected <- lift do

809− statement () $ Rel8.select do

810− Rel8.many $ Rel8.values (map Rel8.lit rows)

693+ transaction \connection -> do

694+ selected <- liftIO $ Rel8.select connection do

695+ Rel8.many $ Rel8.values (map Rel8.lit rows)

811696

812697 selected === [foldMap pure rows]

813698

814− selected' <- lift do

815− statement () $ Rel8.select do

816− a <- Rel8.catListTable =<< do

817− Rel8.many $ Rel8.values (map Rel8.lit rows)

818− b <- Rel8.catListTable =<< do

819− Rel8.many $ Rel8.values (map Rel8.lit rows)

820− pure (a, b)

699+ selected' <- liftIO $ Rel8.select connection $ do

700+ a <- Rel8.catListTable =<< do

701+ Rel8.many $ Rel8.values (map Rel8.lit rows)

702+ b <- Rel8.catListTable =<< do

703+ Rel8.many $ Rel8.values (map Rel8.lit rows)

704+ pure (a, b)

821705

822706 selected' === liftA2 (,) rows rows

823707

@@ -839,11 +723,10 @@ testNestedMaybeTable :: IO TmpPostgres.DB -> TestTree

839723testNestedMaybeTable = databasePropertyTest "Can nest MaybeTable within other tables" \transaction -> do

840724 let example = NestedMaybeTable { nmt1 = True, nmt2 = Just (TestTable "Hi" True) }

841725

842− transaction do

843− selected <- lift do

844− statement () $ Rel8.select do

845− x <- Rel8.values [Rel8.lit example]

846− pure $ Rel8.maybeTable (Rel8.lit False) (\_ -> Rel8.lit True) (nmt2 x)

726+ transaction \connection -> do

727+ selected <- liftIO $ Rel8.select connection do

728+ x <- Rel8.values [Rel8.lit example]

729+ pure $ Rel8.maybeTable (Rel8.lit False) (\_ -> Rel8.lit True) (nmt2 x)

847730

848731 selected === [True]

849732

@@ -851,12 +734,11 @@ testNestedMaybeTable = databasePropertyTest "Can nest MaybeTable within other ta

851734testEvaluate :: IO TmpPostgres.DB -> TestTree

852735testEvaluate = databasePropertyTest "evaluate has the evaluation order we expect" \transaction -> do

853736

854− transaction do

855− selected <- lift do

856− statement () $ Rel8.select do

857− x <- Rel8.values (Rel8.lit <$> ['a', 'b', 'c'])

858− y <- Rel8.evaluate (Rel8.nextval "test_seq")

859− pure (x, (y, y))

737+ transaction \connection -> do

738+ selected <- liftIO $ Rel8.select connection do

739+ x <- Rel8.values (Rel8.lit <$> ['a', 'b', 'c'])

740+ y <- Rel8.evaluate (Rel8.nextval "test_seq")

741+ pure (x, (y, y))

860742

861743 normalize selected ===

862744 [ ('a', (0, 0))

@@ -864,12 +746,11 @@ testEvaluate = databasePropertyTest "evaluate has the evaluation order we expect

864746 , ('c', (2, 2))

865747 ]

866748

867− selected' <- lift do

868− statement () $ Rel8.select do

869− x <- Rel8.values (Rel8.lit <$> ['a', 'b', 'c'])

870− y <- Rel8.values (Rel8.lit <$> ['d', 'e', 'f'])

871− z <- Rel8.evaluate (Rel8.nextval "test_seq")

872− pure ((x, y), (z, z))

749+ selected' <- liftIO $ Rel8.select connection do

750+ x <- Rel8.values (Rel8.lit <$> ['a', 'b', 'c'])

751+ y <- Rel8.values (Rel8.lit <$> ['d', 'e', 'f'])

752+ z <- Rel8.evaluate (Rel8.nextval "test_seq")

753+ pure ((x, y), (z, z))

873754

874755 normalize selected' ===

875756 [ (('a', 'd'), (0, 0))

@@ -887,3 +768,13 @@ testEvaluate = databasePropertyTest "evaluate has the evaluation order we expect

887768 normalize :: [(x, (Int64, Int64))] -> [(x, (Int64, Int64))]

888769 normalize [] = []

889770 normalize xs@((_, (i, _)) : _) = map (fmap (\(a, b) -> (a - i, b - i))) xs

771+

772+{-

773+ selected <- liftIO $ Rel8.select connection do

774+ x <- Rel8.values (Rel8.lit <$> ['a', 'b', 'c'])

775+ x <- Rel8.values (Rel8.lit <$> ['d', 'e', 'f'])

776+ y <- Rel8.evaluate (Rel8.nextval "test_seq")

777+ pure (x, y, y)

778+

779+ selected === [('a', 1, 1), ('b', 2, 2), ('c', 3, 3)]

780+-}

tests/Rel8/Generic/Rel8able/Test.hs+1−10

@@ -5,7 +5,6 @@

55{-# language DuplicateRecordFields #-}

66{-# language FlexibleInstances #-}

77{-# language MultiParamTypeClasses #-}

8−{-# language StandaloneKindSignatures #-}

98{-# language TypeFamilies #-}

109{-# language UndecidableInstances #-}

1110

@@ -172,17 +171,9 @@ data NestedTableTestB f = NestedTableTestB

172171 deriving anyclass Rel8able

173172

174173

174+

175175newtype IdRecord a f = IdRecord { recordId :: Column f a }

176176 deriving stock Generic

177177

178178

179179instance 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