master..8de0eec · rel8

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

since splitsnapshots

unifiedsplit

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

9 persist-credentials: false

10 submodules: true

11

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

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

13 with:

14 nix_path: nixpkgs=channel:nixos-unstable

15 extra_nix_config: |

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

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

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

18

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

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

20 with:

21 name: rel8

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

Changelog.md+2−92

@@ -1,90 +1,4 @@

1−# 1.4.0.0 (2002-08-17)

1+# 1.1.0.0 (??)

2−

3−## Breaking changes

4−

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

78−

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

80−

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

82−

83−## Breaking changes

84−

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

86−

87−# 1.1.0.0 (2021-07-16)

88

2

89## New features

3## New features

90

4

@@ -96,7 +10,7 @@

96 , myTableY :: f Text

10 , myTableY :: f Text

97 } deriving (Generic, Rel8able)

11 } deriving (Generic, Rel8able)

98 ```

12 ```

99−

13+

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

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

101

15

102 ```haskell

16 ```haskell

@@ -113,8 +27,6 @@

113

27

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

28* 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

29

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

30## Breaking changes

119

31

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

32* `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))

@@ -133,8 +45,6 @@

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

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

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

135

47

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−

138## Bug fixes

48## Bug fixes

139

49

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

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

1packages: .

2+

3+allow-newer: generic-monoid:base

4+allow-newer: cryptohash-sha1:base

5+allow-newer: cryptohash-md5:base

6+allow-newer: entropy:Cabal

cabal.project.haskell-nix+6

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

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

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

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

5+

6+source-repository-package

7+ type: git

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

9+ tag: f99b05454874192e3511bd133555dfb6cc6a6ecb

10+ --sha256: 0yy2i2jbllwavv5d2176rf8lmm4l1ws90lxkmdlfgvfzqxidx0gi

default.nix+2−2

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

1let

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

3

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

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

5

6 nixpkgsArgs = haskellNix.nixpkgsArgs;

7

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

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

9

10 pkgs = import nixpkgsSrc nixpkgsArgs;

11

docs/cookbook.rst+7−9

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

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

143posts. We want our query to return:

144

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

145+1. The latest 5 blog posts.

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

148

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

150

151 latestBlogPosts = do

152 post <- each postSchema

153

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

155− tags <- some $ do

154+ tags <- aggregate do

156 tag <- each tagSchema

155 tag <- each tagSchema

157 where_ (tagPostId tag ==. postId post)

156 where_ (tagPostId tag ==. postId post)

158− return (tagName tag)

157+ return (listAgg (tagName tag))

159

158

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

161− latestComments <-

159+ latestComments <-

162− many $

160+ many $

163− limit 3 $

161+ limit 3 $

164 orderBy (commentCreatedAt >$< desc) do

162 orderBy (commentCreatedAt >$< desc) do

165 comment <- each commentSchema

163 comment <- each commentSchema

166 where_ (commentPostId comment ==. postId post)

164 where_ (commentPostId comment ==. postId post)

nix/sources.json+9−9

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

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

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

7 "repo": "haskell.nix",

8− "rev": "0837156c56cb5350dd9bd84eb424187e00aa1e8a",

8+ "rev": "3856d2d24dca0ecc71fcfc314253a2a2d07a3c4f",

9− "sha256": "1djmv5a0vfj78csw2cad6nicrs8iqrp928b9b3v4h7lwwhhzliwl",

9+ "sha256": "0s69nasqhkv8n0qmdv075k83p3z584ja9vkzdnp2291mymghvx87",

10 "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",

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

13 },

14 "niv": {

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

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

18 "owner": "nmattia",

19 "repo": "niv",

20− "rev": "acdb1726783637852c01e0ad639ac9cbec28d8c8",

20+ "rev": "e0ca65c81a2d7a4d82a189f1e23a48d59ad42070",

21− "sha256": "1wszl8q70z6wfgkh2dvgmhhry6qp9nar421qq2ifd17hq2jj9ck3",

21+ "sha256": "1pq9nh1d8nn3xvbdny8fafzw87mj7gsmp6pxkdl65w2g18rmcmzx",

22 "type": "tarball",

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

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

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

25 },

26 "nixpkgs": {

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

29 "homepage": null,

30 "owner": "nixos",

31 "repo": "nixpkgs",

32− "rev": "1c1f5649bb9c1b0d98637c8c365228f57126f361",

32+ "rev": "59b8d9cf24e9fcf10341a0923c9bdca088dca8c8",

33− "sha256": "0f2nvdijyxfgl5kwyb4465pppd5vkhqxddx6v40k2s0z9jfhj0xl",

33+ "sha256": "08f38v4b2kcxnbapdwrb54bglka92cxj9qlnqlk5px206jyq9v4c",

34 "type": "tarball",

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

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

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

37 }

38}

nix/sources.nix+1−21

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

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

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

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

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

35− submoduleArg =

36− let

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

38− emptyArgWithWarning =

39− if submodules == true

40− then

41− builtins.trace

42− (

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

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

45− + "does not support them"

46− )

47− {}

48− else {};

49− in

50− if nixSupportsSubmodules

51− then { inherit submodules; }

52− else emptyArgWithWarning;

53 in

34 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; };

56

36

57 fetch_local = spec: spec.path;

37 fetch_local = spec: spec.path;

58

38

rel8.cabal+8−19

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

1cabal-version: 2.0

2name: rel8

3−version: 1.4.0.0

3+version: 1.0.0.1

4synopsis: Hey! Hey! Can u rel8?

5license: BSD3

6license-file: LICENSE

@@ -20,14 +20,14 @@ source-repository head

20library

21 build-depends:

22 aeson

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

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

24 , bifunctors

25 , bytestring

26 , case-insensitive

27 , comonad

28 , contravariant

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

29+ , hasql ^>= 1.4.5.1

30− , opaleye ^>= 0.9.6.1

30+ , opaleye ^>= 0.7.3.0

31 , pretty

32 , profunctors

33 , product-profunctors

@@ -37,6 +37,7 @@ library

37 , text

38 , these

39 , time

40+ , transformers

40 , uuid

41 , uuid

41 default-language:

42 default-language:

42 Haskell2010

43 Haskell2010

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

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

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

47 -Wno-monomorphism-restriction

48 -Wno-monomorphism-restriction

48 -Wno-missing-local-signatures

49 -Wno-missing-local-signatures

49− -Wno-missing-kind-signatures

50 hs-source-dirs:

51 src

52 exposed-modules:

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

66 Rel8.Column.List

67 Rel8.Column.Maybe

68 Rel8.Column.NonEmpty

69− Rel8.Column.Null

70 Rel8.Column.These

69 Rel8.Column.These

71

70

72 Rel8.Expr

71 Rel8.Expr

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

82 Rel8.Expr.Order

81 Rel8.Expr.Order

83 Rel8.Expr.Sequence

82 Rel8.Expr.Sequence

84 Rel8.Expr.Serialize

83 Rel8.Expr.Serialize

85− Rel8.Expr.Window

86

84

87 Rel8.FCF

85 Rel8.FCF

88

86

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

109 Rel8.Query.Evaluate

107 Rel8.Query.Evaluate

110 Rel8.Query.Exists

108 Rel8.Query.Exists

111 Rel8.Query.Filter

109 Rel8.Query.Filter

112− Rel8.Query.Indexed

113 Rel8.Query.Limit

110 Rel8.Query.Limit

114 Rel8.Query.List

111 Rel8.Query.List

115 Rel8.Query.Maybe

112 Rel8.Query.Maybe

116 Rel8.Query.Null

113 Rel8.Query.Null

117 Rel8.Query.Opaleye

114 Rel8.Query.Opaleye

118 Rel8.Query.Order

115 Rel8.Query.Order

119− Rel8.Query.Rebind

120 Rel8.Query.Set

116 Rel8.Query.Set

121 Rel8.Query.SQL

117 Rel8.Query.SQL

122 Rel8.Query.These

118 Rel8.Query.These

123 Rel8.Query.Values

119 Rel8.Query.Values

124− Rel8.Query.Window

125

120

126 Rel8.Schema.Context.Nullify

121 Rel8.Schema.Context.Nullify

127 Rel8.Schema.Dict

122 Rel8.Schema.Dict

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

170 Rel8.Table.Maybe

165 Rel8.Table.Maybe

171 Rel8.Table.Name

166 Rel8.Table.Name

172 Rel8.Table.NonEmpty

167 Rel8.Table.NonEmpty

173− Rel8.Table.Null

174 Rel8.Table.Nullify

168 Rel8.Table.Nullify

175 Rel8.Table.Opaleye

169 Rel8.Table.Opaleye

176 Rel8.Table.Ord

170 Rel8.Table.Ord

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

181 Rel8.Table.These

175 Rel8.Table.These

182 Rel8.Table.Transpose

176 Rel8.Table.Transpose

183 Rel8.Table.Undefined

177 Rel8.Table.Undefined

184− Rel8.Table.Window

185

178

186 Rel8.Type

179 Rel8.Type

187 Rel8.Type.Array

180 Rel8.Type.Array

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

200 Rel8.Type.Sum

193 Rel8.Type.Sum

201 Rel8.Type.Tag

194 Rel8.Type.Tag

202

195

203− Rel8.Window

204−

205−

206test-suite tests

196test-suite tests

207 type: exitcode-stdio-1.0

197 type: exitcode-stdio-1.0

208 build-depends:

198 build-depends:

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

211 , case-insensitive

201 , case-insensitive

212 , containers

202 , containers

213 , hasql

203 , hasql

214− , hasql-transaction

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

204+ , hedgehog ^>=1.0.2

216− , mmorph

205+ , lifted-base ^>=0.2.3.12

206+ , monad-control ^>=1.0.2.3

217 , rel8

207 , rel8

218 , scientific

208 , scientific

219 , tasty

209 , tasty

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

221 , text

211 , text

222 , time

212 , time

223 , tmp-postgres ^>=1.34.1.0

213 , tmp-postgres ^>=1.34.1.0

224− , transformers

225 , uuid

214 , uuid

226

215

227 other-modules:

216 other-modules:

shell.nix+1−1

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

1let

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

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

3+ pkgs = import sources.nixpkgs {};

4 hsPkgs = import ./default.nix;

5in

6 hsPkgs.shellFor {

src/Rel8.hs+8−277

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

38 , HMaybe

39 , HList

40 , HNonEmpty

41− , HNull

42 , HThese

41 , HThese

43 , Lift

42 , Lift

44

43

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

47 , Transposes

46 , Transposes

48 , AltTable((<|>:))

47 , AltTable((<|>:))

49 , AlternativeTable( emptyTable )

48 , AlternativeTable( emptyTable )

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

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

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

50+ , OrdTable, ascTable, descTable

52 , lit

51 , lit

53 , bool

52 , bool

54 , case_

53 , case_

55− , castTable

56

54

57 -- ** @MaybeTable@

55 -- ** @MaybeTable@

58 , MaybeTable

56 , MaybeTable

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

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

60 , isNothingTable, isJustTable

58 , isNothingTable, isJustTable

61− , fromMaybeTable

62 , optional

59 , optional

63 , catMaybeTable

60 , catMaybeTable

64 , traverseMaybeTable

61 , traverseMaybeTable

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

81 , isThisTable, isThatTable, isThoseTable

78 , isThisTable, isThatTable, isThoseTable

82 , hasHereTable, hasThereTable

79 , hasHereTable, hasThereTable

83 , justHereTable, justThereTable

80 , justHereTable, justThereTable

84− , alignMaybeTable

85 , alignBy

81 , alignBy

86 , keepHereTable, loseHereTable

82 , keepHereTable, loseHereTable

87 , keepThereTable, loseThereTable

83 , keepThereTable, loseThereTable

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

94

90

95 -- ** @ListTable@

91 -- ** @ListTable@

96 , ListTable

92 , ListTable

97− , listTable, ($*)

93+ , listTable

98 , nameListTable

94 , nameListTable

99 , many

95 , many

100 , manyExpr

96 , manyExpr

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

103

99

104 -- ** @NonEmptyTable@

100 -- ** @NonEmptyTable@

105 , NonEmptyTable

101 , NonEmptyTable

106− , nonEmptyTable, ($+)

102+ , nonEmptyTable

107 , nameNonEmptyTable

103 , nameNonEmptyTable

108 , some

104 , some

109 , someExpr

105 , someExpr

110 , catNonEmptyTable

106 , catNonEmptyTable

111 , catNonEmpty

107 , catNonEmpty

112

108

113− -- ** @NullTable@

109+ -- ** @ADT@

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

127 , ADT, ADTable

110 , ADT, ADTable

128−

129− -- *** Deconstruction of ADTs

130− -- $deconstruction

131− , DeconstructADT, deconstructADT

132−

133− -- *** Construction of ADTs

134− -- $construction

135 , BuildADT, buildADT

111 , BuildADT, buildADT

136 , ConstructADT, constructADT

112 , ConstructADT, constructADT

137−

113+ , DeconstructADT, deconstructADT

138− -- *** Other ADT operations

114+ , NameADT, nameADT

139 , AggregateADT, aggregateADT

115 , AggregateADT, aggregateADT

140

116

141− -- *** Miscellaneous notes

142− -- $misc-notes

143−

144 -- ** @HKD@

117 -- ** @HKD@

145 , HKD, HKDable

118 , HKD, HKDable

146 , BuildHKD, buildHKD

119 , BuildHKD, buildHKD

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

165 -- ** @null@

138 -- ** @null@

166 , NotNull

139 , NotNull

167 , Nullable

140 , Nullable

168− , Homonullable

169 , null

141 , null

170 , nullify

142 , nullify

171 , nullable

143 , nullable

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

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

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

185 , in_

157 , in_

186 , boolExpr, caseExpr

158 , boolExpr, caseExpr

187− , like, ilike

188

159

189 -- ** Ordering

160 -- ** Ordering

190 , DBOrd

161 , DBOrd

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

253 , countRows

224 , countRows

254 , groupBy

225 , groupBy

255 , listAgg, listAggExpr

226 , listAgg, listAggExpr

256− , mode

257 , nonEmptyAgg, nonEmptyAggExpr

227 , nonEmptyAgg, nonEmptyAggExpr

258 , DBMax, max

228 , DBMax, max

259 , DBMin, min

229 , DBMin, min

260− , DBSum, sum, sumWhere, avg

230+ , DBSum, sum, sumWhere

261 , DBString, stringAgg

231 , DBString, stringAgg

262 , count

232 , count

263 , countStar

233 , countStar

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

274 , nullsFirst

244 , nullsFirst

275 , nullsLast

245 , nullsLast

276

246

277− -- ** Window functions

278− , Window

279− , window

280− , Partition

281− , over

282− , partitionBy

283− , orderPartitionBy

284− , cumulative

285− , cumulative_

286− , currentRow

287− , rowNumber

288− , rank

289− , denseRank

290− , percentRank

291− , cumeDist

292− , ntile

293− , lag

294− , lead

295− , firstValue

296− , lastValue

297− , nthValue

298− , indexed

299−

300 -- ** Bindings

247 -- ** Bindings

301 , rebind

248 , rebind

302

249

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

334

281

335 -- ** @CREATE VIEW@

282 -- ** @CREATE VIEW@

336 , createView

283 , createView

337− , createOrReplaceView

338

284

339 -- ** Sequences

285 -- ** Sequences

340 , nextval

286 , nextval

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

353import Rel8.Column.List

299import Rel8.Column.List

354import Rel8.Column.Maybe

300import Rel8.Column.Maybe

355import Rel8.Column.NonEmpty

301import Rel8.Column.NonEmpty

356−import Rel8.Column.Null

357import Rel8.Column.These

302import Rel8.Column.These

358import Rel8.Expr

303import Rel8.Expr

359import Rel8.Expr.Aggregate

304import Rel8.Expr.Aggregate

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

367import Rel8.Expr.Order

312import Rel8.Expr.Order

368import Rel8.Expr.Serialize

313import Rel8.Expr.Serialize

369import Rel8.Expr.Sequence

314import Rel8.Expr.Sequence

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

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

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

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

373import Rel8.Order

316import Rel8.Order

374import Rel8.Query

317import Rel8.Query

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

379import Rel8.Query.Evaluate

322import Rel8.Query.Evaluate

380import Rel8.Query.Exists

323import Rel8.Query.Exists

381import Rel8.Query.Filter

324import Rel8.Query.Filter

382−import Rel8.Query.Indexed

383import Rel8.Query.Limit

325import Rel8.Query.Limit

384import Rel8.Query.List

326import Rel8.Query.List

385import Rel8.Query.Maybe

327import Rel8.Query.Maybe

386import Rel8.Query.Null

328import Rel8.Query.Null

387import Rel8.Query.Order

329import Rel8.Query.Order

388−import Rel8.Query.Rebind

389import Rel8.Query.SQL (showQuery)

330import Rel8.Query.SQL (showQuery)

390import Rel8.Query.Set

331import Rel8.Query.Set

391import Rel8.Query.These

332import Rel8.Query.These

392import Rel8.Query.Values

333import Rel8.Query.Values

393−import Rel8.Query.Window

394import Rel8.Schema.Field

334import Rel8.Schema.Field

395import Rel8.Schema.HTable

335import Rel8.Schema.HTable

396import Rel8.Schema.Name

336import Rel8.Schema.Name

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

417import Rel8.Table.Maybe

357import Rel8.Table.Maybe

418import Rel8.Table.Name

358import Rel8.Table.Name

419import Rel8.Table.NonEmpty

359import Rel8.Table.NonEmpty

420−import Rel8.Table.Null

421−import Rel8.Table.Opaleye ( castTable )

422import Rel8.Table.Ord

360import Rel8.Table.Ord

423import Rel8.Table.Order

361import Rel8.Table.Order

424import Rel8.Table.Projection

362import Rel8.Table.Projection

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

426import Rel8.Table.Serialize

364import Rel8.Table.Serialize

427import Rel8.Table.These

365import Rel8.Table.These

428import Rel8.Table.Transpose

366import Rel8.Table.Transpose

429−import Rel8.Table.Window

430import Rel8.Type

367import Rel8.Type

431import Rel8.Type.Composite

368import Rel8.Type.Composite

432import Rel8.Type.Eq

369import Rel8.Type.Eq

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

441import Rel8.Type.Semigroup

378import Rel8.Type.Semigroup

442import Rel8.Type.String

379import Rel8.Type.String

443import Rel8.Type.Sum

380import Rel8.Type.Sum

444−import Rel8.Window

445

381

446

382

447-- $running

383-- $running

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

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

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

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

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

451-- `DuplicateRecordFields` language extension enabled.

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

2{-# language FlexibleContexts #-}

3{-# language FlexibleInstances #-}

4{-# language MultiParamTypeClasses #-}

5+{-# language NamedFieldPuns #-}

5{-# language RankNTypes #-}

6{-# language RankNTypes #-}

6{-# language StandaloneKindSignatures #-}

7{-# language StandaloneKindSignatures #-}

7{-# language TypeFamilies #-}

8{-# language TypeFamilies #-}

8{-# language UndecidableInstances #-}

9{-# language UndecidableInstances #-}

9

10

10module Rel8.Aggregate

11module Rel8.Aggregate

11− ( Aggregate(..), zipOutputs

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

12− , unsafeMakeAggregate

13+ , Aggregator(..), unsafeMakeAggregate

13 , Aggregates

14 , Aggregates

14 )

15 )

15where

16where

16

17

17-- base

18-- base

18−import Control.Applicative ( liftA2 )

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

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

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

20import Data.Kind ( Constraint, Type )

21import Data.Kind ( Constraint, Type )

21import Prelude

22import Prelude

22

23

23−-- profunctors

24−import Data.Profunctor ( dimap )

25−

26-- opaleye

24-- opaleye

27−import qualified Opaleye.Aggregate as Opaleye

25+import qualified Opaleye.Internal.Aggregate as Opaleye

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

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

29−import qualified Opaleye.Internal.Column as Opaleye

27+import qualified Opaleye.Internal.PackMap as Opaleye

30

28

31-- rel8

29-- rel8

32import Rel8.Expr ( Expr )

30import Rel8.Expr ( Expr )

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

42import Rel8.Type ( DBType )

40import Rel8.Type ( DBType )

43

41

44

42

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.

46type Aggregate :: K.Context

48type Aggregate :: K.Context

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

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

48

50

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

59 fromResult (HIdentity (Identity a)) = a

61 fromResult (HIdentity (Identity a)) = a

60

62

61

63

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

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

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

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

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

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

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

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

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

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

67

69

68

70

69−zipOutputs :: ()

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

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

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

71−zipOutputs f (Aggregate a) (Aggregate b) = Aggregate (liftA2 f 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+ }

72

94

73

95

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

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

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

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

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

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

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

99+ -> Maybe Aggregator

78 -> Expr input

100 -> Expr input

79 -> Aggregate output

101 -> Aggregate output

80unsafeMakeAggregate input output aggregator expr =

102unsafeMakeAggregate input output aggregator expr =

81− Aggregate $ dimap in_ out aggregator

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

82− where out = output . Opaleye.unColumn

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

83− in_ = Opaleye.Column . input . const 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 @@

1{-# language DataKinds #-}

2{-# language DerivingStrategies #-}

3−{-# language FlexibleContexts #-}

4{-# language FlexibleInstances #-}

3{-# language FlexibleInstances #-}

5{-# language MultiParamTypeClasses #-}

4{-# language MultiParamTypeClasses #-}

6{-# language ScopedTypeVariables #-}

5{-# language ScopedTypeVariables #-}

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

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

10 , and, or

11 , min, max

12 , sum, sumWhere

13− , avg

14 , stringAgg

13 , stringAgg

15 , groupByExpr

14 , groupByExpr

16 , listAggExpr, nonEmptyAggExpr

15 , listAggExpr, nonEmptyAggExpr

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

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

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

25

24

26-- opaleye

25-- opaleye

27−import qualified Opaleye.Internal.Aggregate as Opaleye

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

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

29−import qualified Opaleye.Aggregate as Opaleye

30

27

31-- rel8

28-- rel8

32−import Rel8.Aggregate ( Aggregate, unsafeMakeAggregate )

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

33import Rel8.Expr ( Expr )

30import Rel8.Expr ( Expr )

34import Rel8.Expr.Bool ( caseExpr )

31import Rel8.Expr.Bool ( caseExpr )

35import Rel8.Expr.Opaleye

32import Rel8.Expr.Opaleye

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

53

50

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

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

55count :: Expr a -> Aggregate Int64

52count :: 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+

57

60

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

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

59-- @COUNT(DISTINCT a)@

62-- @COUNT(DISTINCT a)@

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

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

61countDistinct = unsafeMakeAggregate toPrimExpr fromPrimExpr $

64countDistinct = unsafeMakeAggregate toPrimExpr fromPrimExpr $

62− Opaleye.distinctAggregator Opaleye.count

65+ Just Aggregator

66+ { operation = Opaleye.AggrCount

67+ , ordering = []

68+ , distinction = Opaleye.AggrDistinct

69+ }

63

70

64

71

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

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

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

74

81

75-- | Corresponds to @bool_and@.

82-- | Corresponds to @bool_and@.

76and :: Expr Bool -> Aggregate Bool

83and :: 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+ }

78

90

79

91

80-- | Corresponds to @bool_or@.

92-- | Corresponds to @bool_or@.

81or :: Expr Bool -> Aggregate Bool

93or :: 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+ }

83

100

84

101

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

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

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

103max :: 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+ }

88

110

89

111

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

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

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

113min :: 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+ }

93

120

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

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

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

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

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

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

98-- your input.

125-- your input.

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

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

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

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

101−

128+ Just Aggregator

129+ { operation = Opaleye.AggrSum

130+ , ordering = []

131+ , distinction = Opaleye.AggrAll

132+ }

102

133

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

110

134

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

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

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

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

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

118stringAgg :: Sql DBString a

142stringAgg :: Sql DBString a

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

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

120stringAgg delimiter =

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

122

151

123

152

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

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

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

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

126−groupByExpr = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.groupBy

155+groupByExpr = unsafeMakeAggregate toPrimExpr fromPrimExpr Nothing

127

156

128

157

129-- | Collect expressions values as a list.

158-- | Collect expressions values as a list.

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

138

167

139slistAggExpr :: ()

168slistAggExpr :: ()

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

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

142 where

176 where

143 to = encodeArrayElement info . toPrimExpr

177 to = encodeArrayElement info . toPrimExpr

144

178

145

179

146snonEmptyAggExpr :: ()

180snonEmptyAggExpr :: ()

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

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

149 where

188 where

150 to = encodeArrayElement info . toPrimExpr

189 to = encodeArrayElement info . toPrimExpr

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

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

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

5

6module 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

12 )

8 )

13where

9where

14

10

15-- base

11-- base

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

12+import Prelude ()

17

13

18-- rel

14-- rel

19import Rel8.Expr ( Expr( Expr ) )

15import Rel8.Expr ( Expr( Expr ) )

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

21import Rel8.Expr.Function ( function )

16import Rel8.Expr.Function ( function )

22import Rel8.Expr.Opaleye ( castExpr )

17import Rel8.Expr.Opaleye ( castExpr )

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

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

24−import Rel8.Table.Bool ( bool )

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

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

26

20

27

21

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

48ceiling = function "ceiling"

42ceiling = function "ceiling"

49

43

50

44

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

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

52−-- PostgreSQL.

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

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

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

47+div = function "div"

55

48

56

49

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

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

58−-- PostgreSQL.

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

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

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

52+mod = function "mod"

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)

86

53

87

54

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

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

10 , scastExpr, sunsafeCastExpr

11 , unsafeLiteral

12 , fromPrimExpr, toPrimExpr, mapPrimExpr, zipPrimExprsWith, traversePrimExpr

13− , toColumn, fromColumn, traverseFieldP

13+ , toColumn, fromColumn

14 )

15where

16

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

27import Rel8.Type ( DBType, typeInformation )

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

29

30−-- profunctors

31−import Data.Profunctor ( Profunctor, dimap )

32−

33

30

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

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

35castExpr = scastExpr typeInformation

32castExpr = scastExpr typeInformation

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

83traversePrimExpr f = fmap fromPrimExpr . f . toPrimExpr

80traversePrimExpr f = fmap fromPrimExpr . f . toPrimExpr

84

81

85

82

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

93toColumn = Opaleye.Column

84toColumn = Opaleye.Column

94

85

95

86

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

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

97fromColumn (Opaleye.Column a) = a

88fromColumn (Opaleye.Column a) = a

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

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

11import Rel8.Expr ( Expr )

12import Rel8.Expr.Function ( function )

13import Rel8.Expr.Serialize ( litExpr )

14−import Rel8.Expr.Text ( quoteIdent )

15

14

16-- text

15-- text

17import Data.Text ( pack )

16import Data.Text ( pack )

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

19

18

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

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

21nextval :: String -> Expr Int64

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

17 , pgClientEncoding, quoteIdent, quoteLiteral, quoteNullable, regexpReplace

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

19 , splitPart, strpos, substr, translate

20−

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

22− , like, ilike

23 )

20 )

24where

21where

25

22

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

27import Data.Bool ( Bool )

24import Data.Bool ( Bool )

28import Data.Int ( Int32 )

25import Data.Int ( Int32 )

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

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

30−import Prelude ( flip )

27+import Prelude ()

31

28

32-- bytestring

29-- bytestring

33import Data.ByteString ( ByteString )

30import Data.ByteString ( ByteString )

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

52

49

53

50

54-- | Matches regular expression, case sensitive

51-- | Matches regular expression, case sensitive

55−--

52+--

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

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

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

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

58(~.) = binaryOperator "~."

55(~.) = binaryOperator "~."

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

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

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

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

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

278translate = function "translate"

275translate = 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 @@

1{-# language AllowAmbiguousTypes #-}

2{-# language BlockArguments #-}

3{-# language DataKinds #-}

4−{-# language FlexibleContexts #-}

5{-# language FlexibleInstances #-}

4{-# language FlexibleInstances #-}

6{-# language MultiParamTypeClasses #-}

5{-# language MultiParamTypeClasses #-}

7{-# language RankNTypes #-}

6{-# language RankNTypes #-}

src/Rel8/Generic/Record.hs−2

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

1{-# language AllowAmbiguousTypes #-}

2{-# language DataKinds #-}

3−{-# language FlexibleContexts #-}

4{-# language FlexibleInstances #-}

3{-# language FlexibleInstances #-}

5{-# language MultiParamTypeClasses #-}

4{-# language MultiParamTypeClasses #-}

6{-# language PolyKinds #-}

5{-# language PolyKinds #-}

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

142 uncount = id

141 uncount = id

143

142

144

143

145−type Record :: Type -> Type

146newtype Record a = Record

144newtype Record a = Record

147 { unrecord :: a

145 { unrecord :: a

148 }

146 }

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

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

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

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

65type family a == b where

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

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

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

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

70−

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

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

72 -- which occurs when we have polymorphic Rel8ables

67 -- which occurs when we have polymorphic Rel8ables

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

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

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

146-- [Supplying @Rel8able@ instances]

141-- [Supplying @Rel8able@ instances]

147--

142--

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

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

150-- extensions:

145-- extensions:

151--

146--

152-- @

147-- @

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

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

1{-# language AllowAmbiguousTypes #-}

2{-# language DataKinds #-}

3−{-# language FlexibleContexts #-}

4{-# language FlexibleInstances #-}

3{-# language FlexibleInstances #-}

5{-# language LambdaCase #-}

4{-# language LambdaCase #-}

6{-# language MultiParamTypeClasses #-}

5{-# language MultiParamTypeClasses #-}

src/Rel8/Order.hs+8−1

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

4

5module Rel8.Order

6 ( Order(..)

7+ , toOrderExprs

7 )

8 )

8where

9where

9

10

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

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

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

17

18

18-- opaleye

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

20

22

21

23

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

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

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

28type Order :: Type -> Type

30type Order :: Type -> Type

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

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

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

32 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+10−23

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

1−{-# language FlexibleContexts #-}

2{-# language StandaloneKindSignatures #-}

1{-# language StandaloneKindSignatures #-}

3−{-# language UndecidableInstances #-}

4

2

5module Rel8.Query

3module Rel8.Query

6 ( Query( Query )

4 ( Query( Query )

@@ -17,16 +15,15 @@ import Prelude

17-- opaleye

15-- opaleye

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

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

19import qualified Opaleye.Internal.PackMap as Opaleye

17import qualified Opaleye.Internal.PackMap as Opaleye

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

18+import qualified Opaleye.Internal.PrimQuery as Opaleye

21import qualified Opaleye.Internal.QueryArr as Opaleye

19import qualified Opaleye.Internal.QueryArr as Opaleye

22import qualified Opaleye.Internal.Tag as Opaleye

20import qualified Opaleye.Internal.Tag as Opaleye

23

21

24-- rel8

22-- rel8

25−import Rel8.Expr ( Expr )

26import Rel8.Query.Set ( unionAll )

23import Rel8.Query.Set ( unionAll )

27import Rel8.Query.Opaleye ( fromOpaleye )

24import Rel8.Query.Opaleye ( fromOpaleye )

28import Rel8.Query.Values ( values )

25import Rel8.Query.Values ( values )

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

26+import Rel8.Table ( fromColumns, toColumns )

30import Rel8.Table.Alternative

27import Rel8.Table.Alternative

31 ( AltTable, (<|>:)

28 ( AltTable, (<|>:)

32 , AlternativeTable, emptyTable

29 , AlternativeTable, emptyTable

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

178

175

179

176

180instance Monad Query where

177instance Monad Query where

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

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

182 let

179 let

183− qa = q dummies

180+ Opaleye.QueryArr qa = q dummies

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

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

185 Query q' = f a

182 Query q' = f a

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

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

187 ( dummy : dummies

184 ( dummy : dummies

188− , query <> Opaleye.aRebind bindings

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

189 , Opaleye.next tag'

186 , Opaleye.next tag'

190 )

187 )

191 where

188 where

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

193 where

190 where

194 random = Opaleye.FunExpr "random" []

191 random = Opaleye.FunExpr "random" []

195 name = Opaleye.extractAttr "dummy" tag'

192 name = Opaleye.extractAttr "dummy" tag'

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

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

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

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

198 query'''

195 query'''

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

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

200− | otherwise = query <> query''

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

201 m'' = m <> m'

198 m'' = m <> m'

202 in

199 in

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

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

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

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

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

212instance AlternativeTable Query where

209instance AlternativeTable Query where

213 emptyTable = values []

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

1{-# language FlexibleContexts #-}

2{-# language MonoLocalBinds #-}

3−{-# language ScopedTypeVariables #-}

4−{-# language TypeApplications #-}

5

3

6module Rel8.Query.Aggregate

4module Rel8.Query.Aggregate

7 ( aggregate

5 ( aggregate

8 , countRows

6 , countRows

9− , mode

10 )

7 )

11where

8where

12

9

13-- base

10-- base

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

15import Data.Int ( Int64 )

11import Data.Int ( Int64 )

16import Prelude

12import Prelude

17

13

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

22import Rel8.Aggregate ( Aggregates )

18import Rel8.Aggregate ( Aggregates )

23import Rel8.Expr ( Expr )

19import Rel8.Expr ( Expr )

24import Rel8.Expr.Aggregate ( countStar )

20import Rel8.Expr.Aggregate ( countStar )

25−import Rel8.Expr.Order ( desc )

26import Rel8.Query ( Query )

21import Rel8.Query ( Query )

27−import Rel8.Query.Limit ( limit )

28import Rel8.Query.Maybe ( optional )

22import Rel8.Query.Maybe ( optional )

29import Rel8.Query.Opaleye ( mapOpaleye )

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

35import Rel8.Table.Opaleye ( aggregator )

24import Rel8.Table.Opaleye ( aggregator )

36import Rel8.Table.Maybe ( maybeTable )

25import Rel8.Table.Maybe ( maybeTable )

37

26

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

46-- will return @0@.

35-- will return @0@.

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

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

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

37countRows = 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 #-}

2+

1module Rel8.Query.Distinct

3module Rel8.Query.Distinct

2 ( distinct

4 ( distinct

3 , distinctOn

5 , distinctOn

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

6where

8where

7

9

8-- base

10-- base

9−import Prelude ()

11+import Prelude

10

12

11-- opaleye

13-- opaleye

12import qualified Opaleye.Distinct as Opaleye

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

14

17

15-- rel8

18-- rel8

16import Rel8.Order ( Order( Order ) )

19import Rel8.Order ( Order( Order ) )

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

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

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

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

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

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

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

36+distinctOn proj =

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

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

34

38

35

39

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

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

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

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

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

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

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

43distinctOnBy :: 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 @@

3

4module Rel8.Query.Evaluate

5 ( evaluate

6+ , rebind

6 )

7 )

7where

8where

8

9

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

15

16

16-- opaleye

17-- opaleye

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

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

18

24

19-- rel8

25-- rel8

20import Rel8.Expr ( Expr )

26import Rel8.Expr ( Expr )

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

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

22import Rel8.Expr.Opaleye ( fromPrimExpr )

28import Rel8.Expr.Opaleye ( fromPrimExpr )

23import Rel8.Query ( Query( Query ) )

29import Rel8.Query ( Query( Query ) )

24−import Rel8.Query.Rebind ( rebind )

25import Rel8.Table ( Table )

30import Rel8.Table ( Table )

26import Rel8.Table.Bool ( case_ )

31import Rel8.Table.Bool ( case_ )

27−import Rel8.Table.Undefined ( undefined )

32+import Rel8.Table.Opaleye ( unpackspec )

33+import Rel8.Table.Undefined

28

34

29

35

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

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

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

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

32-- effects and can safely be reused.

38-- effects and can safely be reused.

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

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

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

40+evaluate = laterally >=> rebind

35

41

36

42

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

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

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

45 go = fromPrimExpr . Opaleye.UnExpr Opaleye.OpIsNotNull

51 go = fromPrimExpr . Opaleye.UnExpr Opaleye.OpIsNotNull

46

52

47

53

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+

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

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

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

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

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

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

12

13-- opaleye

14import qualified Opaleye.Exists as Opaleye

15−import qualified Opaleye.Operators as Opaleye

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

16

17-- rel8

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

24import Rel8.Expr.Opaleye ( mapPrimExpr )

25import Rel8.Query ( Query )

26import Rel8.Query.Aggregate ( aggregate )

27+import Rel8.Query.Evaluate ( rebind )

27import Rel8.Query.Maybe ( optional )

28import Rel8.Query.Maybe ( optional )

28−import Rel8.Query.Rebind ( rebind )

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

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

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

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

85--

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

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

88−catListTable (ListTable as) =

89− rebind "unnest" $ fromColumns $ runIdentity $

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

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

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

91

90

92

91

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

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

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

95--

94--

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

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

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

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

98−catNonEmptyTable (NonEmptyTable as) =

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

99− rebind "unnest" $ fromColumns $ runIdentity $

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

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

101

99

102

100

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

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

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

105--

103--

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

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

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

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

108−catList = rebind "unnest" . sunnest typeInformation

106+catList = rebind . sunnest typeInformation

109

107

110

108

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

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

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

113--

111--

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

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

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

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

116−catNonEmpty = rebind "unnest" . sunnest typeInformation

114+catNonEmpty = rebind . sunnest typeInformation

117

115

118

116

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

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

src/Rel8/Query/Null.hs−15

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

1−{-# language FlexibleContexts #-}

2−

3module Rel8.Query.Null

1module Rel8.Query.Null

4 ( catNull

2 ( catNull

5− , catNullTable

6 )

3 )

7where

4where

8

5

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

12-- rel8

9-- rel8

13import Rel8.Expr ( Expr )

10import Rel8.Expr ( Expr )

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

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

15−import Rel8.Table ( Table )

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

17import Rel8.Query ( Query )

12import Rel8.Query ( Query )

18import Rel8.Query.Filter ( where_ )

13import Rel8.Query.Filter ( where_ )

19

14

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

26catNull a = do

21catNull a = do

27 where_ $ isNonNull a

22 where_ $ isNonNull a

28 pure $ unsafeUnnullify a

23 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+11−11

@@ -41,30 +41,30 @@ zipOpaleyeWith f (Query a) (Query b) = Query $ liftA2 (zipping f) a b

41

42unsafePeekQuery :: Query a -> a

43unsafePeekQuery (Query q) = case q mempty of

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

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

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

46

47

48mapping :: ()

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

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

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

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

52 let

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

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

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

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

55 in

56− Opaleye.runStateQueryArr q' () tag

56+ qa' ((), tag)

57

58

59zipping :: Semigroup m

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

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

62−zipping f q q' =

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

63− Opaleye.stateQueryArr $ \_ tag ->

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

64 let

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

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

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

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

67 m'' = m <> m'

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

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

69 in

70− Opaleye.runStateQueryArr q'' () tag

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

18

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

20showQuery :: 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 )

23

24

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

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

28union = zipOpaleyeWith (Opaleye.unionExplicit binaryspec)

29

30

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

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

34unionAll = zipOpaleyeWith (Opaleye.unionAllExplicit binaryspec)

35

36

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

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

40intersect = zipOpaleyeWith (Opaleye.intersectExplicit binaryspec)

41

42

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

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

46intersectAll = zipOpaleyeWith (Opaleye.intersectAllExplicit binaryspec)

47

48

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

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

52except = zipOpaleyeWith (Opaleye.exceptExplicit binaryspec)

53

54

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

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

58exceptAll = zipOpaleyeWith (Opaleye.exceptAllExplicit binaryspec)

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

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

48alignBy :: ()

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

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

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

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

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

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

53 where

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

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

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

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

56 MaybeTable hasHere a = ma

57 MaybeTable hasThere b = mb

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

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

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

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

62 tag''' = Opaleye.next tag''

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

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

64 where

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

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

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

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

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

68 ma' = MaybeTable hasHere' a

69 mb' = MaybeTable hasThere' b

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

71− join' = Opaleye.aProduct join

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

72

73

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

18import Data.Bool ( bool )

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

20import Data.Kind ( Constraint, Type )

21+import Data.Monoid ( getFirst )

21import Prelude hiding ( null )

22import Prelude hiding ( null )

22

23

23-- opaleye

24-- opaleye

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

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

25

26

26-- rel8

27-- rel8

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

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

28import Rel8.Expr ( Expr )

29import Rel8.Expr ( Expr )

29import Rel8.Expr.Bool ( boolExpr )

30import Rel8.Expr.Bool ( boolExpr )

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

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

31−import Rel8.Expr.Opaleye ( fromPrimExpr )

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

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

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

33import Rel8.Schema.Field ( Field )

34import Rel8.Schema.Field ( Field )

34import qualified Rel8.Schema.Kind as K

35import qualified Rel8.Schema.Kind as K

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

94 -> context (Maybe a)

95 -> context (Maybe a)

96 -> context (Maybe a)

96guarder = \case

97guarder = \case

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

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

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

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

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

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

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

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

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

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

102 Identity (bool Nothing a (isNonNull tag))

110 Identity (bool Nothing a (isNonNull tag))

103

111

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

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

16module Rel8.Schema.HTable

17 ( HTable (HField, HConstrainTable)

18 , hfield, htabulate, htraverse, hdicts, hspecs

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

19+ , hmap, htabulateA

20 )

21where

22

23-- base

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

25import Data.Kind ( Constraint, Type )

24import Data.Kind ( Constraint, Type )

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

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

27import Data.Proxy ( Proxy )

26import Data.Proxy ( Proxy )

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

33 )

32 )

34import Prelude

33import Prelude

35

34

36−-- profunctors

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

38−

39−-- product-profunctors

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

41−

42-- rel8

35-- rel8

43import Rel8.Schema.Dict ( Dict )

36import Rel8.Schema.Dict ( Dict )

44import Rel8.Schema.Spec ( Spec )

37import Rel8.Schema.Spec ( Spec )

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

48-- semigroupoids

41-- semigroupoids

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

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

50

43

44+

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

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

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

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

53-- specified ('hspecs').

47-- specified ('hspecs').

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

120 {-# INLINABLE hspecs #-}

114 {-# INLINABLE hspecs #-}

121

115

122

116

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−

128hmap :: HTable t

117hmap :: HTable t

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

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

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

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

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

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

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

136{-# INLINABLE htabulateA #-}

125{-# INLINABLE htabulateA #-}

137

126

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)

154

127

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

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

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

129newtype 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

22 , hvectorize, hunvectorize

23 , happend, hempty

24 , hproject

25− , hcolumn

26 )

25 )

27where

26where

28

27

29-- base

28-- base

30−import Data.Kind ( Constraint, Type )

29+import Data.Kind ( Type )

31import Data.List.NonEmpty ( NonEmpty )

30import Data.List.NonEmpty ( NonEmpty )

32import GHC.Generics (Generic)

31import GHC.Generics (Generic)

33import Prelude

32import Prelude

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

37import Rel8.Schema.Dict ( Dict( Dict ) )

36import Rel8.Schema.Dict ( Dict( Dict ) )

38import qualified Rel8.Schema.Kind as K

37import qualified Rel8.Schema.Kind as K

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

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

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

41import Rel8.Schema.HTable.MapTable

39import Rel8.Schema.HTable.MapTable

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

40+ ( HMapTable, HMapTableField( HMapTableField )

43 , MapSpec, mapInfo

41 , MapSpec, mapInfo

44− , Precompose( Precompose )

45 )

42 )

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

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

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

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

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

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

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

54

51

55

52

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

57class Vector list where

53class Vector list where

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

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

59 vectorTypeInformation :: ()

55 vectorTypeInformation :: ()

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

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

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

138 -> HVectorize list t context -> HVectorize list t' context

134 -> HVectorize list t context -> HVectorize list t' context

139hproject f (HVectorize a) = HVectorize (HMapTable.hproject f a)

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

2{-# language DerivingStrategies #-}

3{-# language DisambiguateRecordFields #-}

4{-# language NamedFieldPuns #-}

5−{-# language StandaloneKindSignatures #-}

6

5

7module Rel8.Schema.Table

6module Rel8.Schema.Table

8 ( TableSchema(..)

7 ( TableSchema(..)

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

11where

10where

12

11

13-- base

12-- base

14−import Data.Kind ( Type )

15import Prelude

13import Prelude

16

14

17-- opaleye

15-- opaleye

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

28--

26--

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

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

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

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

31−type TableSchema :: Type -> Type

32data TableSchema names = TableSchema

29data TableSchema names = TableSchema

33 { name :: String

30 { name :: String

34 -- ^ The name of the table.

31 -- ^ The name of the table.

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

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

14where

15

16-- base

17+import Control.Exception ( throwIO )

17import Data.Kind ( Type )

18import Data.Kind ( Type )

18import Prelude

19import Prelude

19

20

20-- hasql

21-- hasql

22+import Hasql.Connection ( Connection )

21import qualified Hasql.Encoders as Hasql

23import qualified Hasql.Encoders as Hasql

24+import qualified Hasql.Session as Hasql

22import qualified Hasql.Statement as Hasql

25import qualified Hasql.Statement as Hasql

23

26

24-- pretty

27-- pretty

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

29import Rel8.Query ( Query )

32import Rel8.Query ( Query )

30import Rel8.Schema.Name ( Selects )

33import Rel8.Schema.Name ( Selects )

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

34import 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+ )

33import Rel8.Statement.Using ( ppUsing )

39import Rel8.Statement.Using ( ppUsing )

34import Rel8.Statement.Where ( ppWhere )

40import Rel8.Statement.Where ( ppWhere )

35

41

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

55 -> Delete a

61 -> Delete a

56

62

57

63

58−ppDelete :: Delete a -> Doc

64+ppDelete :: Delete a -> Maybe Doc

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

65+ppDelete Delete {..} = do

60− Nothing ->

66+ (usingDoc, i) <- ppUsing using

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

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

62− text "WHERE false"

63− Just (usingDoc, i) ->

68+ $$ usingDoc

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

65− usingDoc $$

66− ppWhere from (deleteWhere i) $$

69+ $$ ppWhere from (deleteWhere i)

67− ppReturning from returning

70+ $$ ppReturning from returning

68

71

69

72

70-- | Run a 'Delete' statement.

73-- | Run a 'Delete' statement.

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

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

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

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

73− where

80+ where

81+ session = Hasql.statement () statement

82+ statement = Hasql.Statement bytes params decode prepare

74− bytes = encodeUtf8 $ Text.pack sql

83+ bytes = encodeUtf8 $ Text.pack sql

75− params = Hasql.noParams

84+ params = Hasql.noParams

76− decode = decodeReturning returning

85+ decode = decodeReturning returning

77− prepare = False

86+ prepare = False

78− sql = show doc

79− doc = ppDelete d

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

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

15where

16

17-- base

18+import Control.Exception ( throwIO )

18import Data.Foldable ( toList )

19import Data.Foldable ( toList )

19import Data.Kind ( Type )

20import Data.Kind ( Type )

20import Prelude

21import Prelude

21

22

22-- hasql

23-- hasql

24+import Hasql.Connection ( Connection )

23import qualified Hasql.Encoders as Hasql

25import qualified Hasql.Encoders as Hasql

26+import qualified Hasql.Session as Hasql

24import qualified Hasql.Statement as Hasql

27import qualified Hasql.Statement as Hasql

25

28

26-- opaleye

29-- opaleye

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

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

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

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

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

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

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

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

40+import Rel8.Statement.Returning

41+ ( Returning

42+ , decodeReturning, emptyReturning, ppReturning

43+ )

38−import Rel8.Statement.Select ( ppRows )

44+import Rel8.Statement.Select ( ppSelect )

39import Rel8.Table ( Table )

45import Rel8.Table ( Table )

40import Rel8.Table.Name ( showNames )

46import Rel8.Table.Name ( showNames )

41

47

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

62 -> Insert a

68 -> Insert a

63

69

64

70

65−ppInsert :: Insert a -> Doc

71+ppInsert :: Insert a -> Maybe Doc

66−ppInsert Insert {..} =

72+ppInsert Insert {..} = do

73+ rows' <- ppSelect rows

67− text "INSERT INTO" <+>

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

68− ppInto into $$

69− ppRows rows $$

75+ $$ rows'

70− ppOnConflict into onConflict $$

76+ $$ ppOnConflict into onConflict

71− ppReturning into returning

77+ $$ ppReturning into returning

72

78

73

79

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

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

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

78

84

79

85

80-- | Run an 'Insert' statement.

86-- | Run an 'Insert' statement.

81−insert :: Insert a -> Hasql.Statement () a

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

82−insert i@Insert {returning} = Hasql.Statement bytes params decode prepare

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

83− where

93+ where

94+ session = Hasql.statement () statement

95+ statement = Hasql.Statement bytes params decode prepare

84− bytes = encodeUtf8 $ Text.pack sql

96+ bytes = encodeUtf8 $ Text.pack sql

85− params = Hasql.noParams

97+ params = Hasql.noParams

86− decode = decodeReturning returning

98+ decode = decodeReturning returning

87− prepare = False

99+ prepare = False

88− sql = show doc

89− doc = ppInsert i

src/Rel8/Statement/Returning.hs+7

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

9

10module Rel8.Statement.Returning

11 ( Returning( NumberOfRowsAffected, Projection )

12+

12 , decodeReturning

13 , decodeReturning

14+ , emptyReturning

13 , ppReturning

15 , ppReturning

14 )

16 )

15where

17where

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

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

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

125

127

126

128

129+emptyReturning :: Returning names a -> a

130+emptyReturning =

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

132+

133+

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

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

128ppReturning schema returning = case projections schema returning of

135ppReturning schema returning = case projections schema returning of

129 Nothing -> mempty

136 Nothing -> mempty

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

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

16

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

18showDelete :: Delete a -> String

19−showDelete = show . ppDelete

19+showDelete = foldMap show . ppDelete

20

21

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

23showInsert :: Insert a -> String

24−showInsert = show . ppInsert

24+showInsert = foldMap show . ppInsert

25

26

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

28showUpdate :: Update a -> String

29−showUpdate = show . ppUpdate

29+showUpdate = foldMap show . ppUpdate

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

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

3{-# language FlexibleContexts #-}

4{-# language MonoLocalBinds #-}

5{-# language ScopedTypeVariables #-}

6−{-# language StandaloneKindSignatures #-}

7{-# language TypeApplications #-}

6{-# language TypeApplications #-}

8

7

9module Rel8.Statement.Select

8module Rel8.Statement.Select

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

12

11

13 , Optimized(..)

12 , Optimized(..)

14 , ppPrimSelect

13 , ppPrimSelect

15− , ppRows

16 )

14 )

17where

15where

18

16

19-- base

17-- base

20−import Data.Foldable ( toList )

18+import Control.Exception ( throwIO )

21−import Data.Kind ( Type )

22import Data.Void ( Void )

19import Data.Void ( Void )

23−import Prelude hiding ( undefined )

20+import Prelude

24

21

25-- hasql

22-- hasql

23+import Hasql.Connection ( Connection )

26import qualified Hasql.Decoders as Hasql

24import qualified Hasql.Decoders as Hasql

27import qualified Hasql.Encoders as Hasql

25import qualified Hasql.Encoders as Hasql

26+import qualified Hasql.Session as Hasql

28import qualified Hasql.Statement as Hasql

27import qualified Hasql.Statement as Hasql

29

28

30-- opaleye

29-- opaleye

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

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

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

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

34import qualified Opaleye.Internal.PrimQuery as Opaleye

31import qualified Opaleye.Internal.PrimQuery as Opaleye

35import qualified Opaleye.Internal.Print as Opaleye

32import qualified Opaleye.Internal.Print as Opaleye

36import qualified Opaleye.Internal.Optimize as Opaleye

33import qualified Opaleye.Internal.Optimize as Opaleye

37import qualified Opaleye.Internal.QueryArr as Opaleye hiding ( Select )

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

38−import qualified Opaleye.Internal.Sql as Opaleye hiding ( Values )

35+import qualified Opaleye.Internal.Sql as Opaleye

39−import qualified Opaleye.Internal.Tag as Opaleye

40

36

41-- pretty

37-- pretty

42import Text.PrettyPrint ( Doc )

38import Text.PrettyPrint ( Doc )

43

39

44-- rel8

40-- rel8

45import Rel8.Expr ( Expr )

41import Rel8.Expr ( Expr )

46−import Rel8.Expr.Bool ( false )

47−import Rel8.Expr.Opaleye ( toPrimExpr )

48import Rel8.Query ( Query )

42import Rel8.Query ( Query )

49import Rel8.Query.Opaleye ( toOpaleye )

43import Rel8.Query.Opaleye ( toOpaleye )

50import Rel8.Schema.Name ( Selects )

44import Rel8.Schema.Name ( Selects )

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

52import Rel8.Table.Cols ( toCols )

46import Rel8.Table.Cols ( toCols )

53import Rel8.Table.Name ( namesFromLabels )

47import Rel8.Table.Name ( namesFromLabels )

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

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

55−import qualified Rel8.Table.Opaleye as T

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

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

57−import Rel8.Table.Undefined ( undefined )

58

50

59-- text

51-- text

60import qualified Data.Text as Text

52import qualified Data.Text as Text

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

63

55

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

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

65select :: forall exprs a. Serializable exprs a

57select :: forall exprs a. Serializable exprs a

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

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

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

59+select c query = case ppSelect query of

60+ Nothing -> pure []

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

68− where

62+ where

63+ session = Hasql.statement () statement

64+ statement = Hasql.Statement bytes params decode prepare

69− bytes = encodeUtf8 (Text.pack sql)

65+ bytes = encodeUtf8 (Text.pack sql)

70− params = Hasql.noParams

66+ params = Hasql.noParams

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

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

72− prepare = False

68+ prepare = False

73− sql = show doc

69+ sql = show doc

74− doc = ppSelect query

70+

75−

71+

76−

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

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

78−ppSelect query =

73+ppSelect query = do

74+ primQuery' <- case optimize primQuery of

75+ Empty -> Nothing

76+ Unit -> Just Opaleye.Unit

77+ Optimized primQuery' -> Just primQuery'

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

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

80 where

79 where

81 names = namesFromLabels

80 names = namesFromLabels

82 (exprs, primQuery, _) =

81 (exprs, primQuery, _) =

83 Opaleye.runSimpleQueryArrStart (toOpaleye query) ()

82 Opaleye.runSimpleQueryArrStart (toOpaleye query) ()

84− (exprs', primQuery') = case optimize primQuery of

85− Empty -> (undefined, Opaleye.Product (pure (pure Opaleye.Unit)) never)

86− Unit -> (exprs, Opaleye.Unit)

87− Optimized pq -> (exprs, pq)

88− never = pure (toPrimExpr false)

89−

90−

91−ppRows :: Table Expr a => Query a -> Doc

92−ppRows query = case optimize primQuery of

93− -- Special case VALUES because we can't use DEFAULT inside a SELECT

94− Optimized (Opaleye.Values symbols rows)

95− | eqSymbols symbols (toList (T.exprs a)) ->

96− Opaleye.ppValues_ (map Opaleye.sqlExpr <$> toList rows)

97− _ -> ppSelect query

98− where

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

100−

101− eqSymbols (symbol : symbols) (Opaleye.AttrExpr symbol' : exprs)

102− | eqSymbol symbol symbol' = eqSymbols symbols exprs

103− | otherwise = False

104− eqSymbols [] [] = True

105− eqSymbols _ _ = False

106−

107− eqSymbol

108− (Opaleye.Symbol name (Opaleye.UnsafeTag tag))

109− (Opaleye.Symbol name' (Opaleye.UnsafeTag tag'))

110− = name == name' && tag == tag'

111

83

112

84

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

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

114ppPrimSelect query =

86ppPrimSelect query =

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

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

116 where

88 where

89+ (a, primQuery, _) =

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

90+ Opaleye.runSimpleQueryArrStart (toOpaleye query) ()

118

91

119

92

120−type Optimized :: Type -> Type

121data Optimized a = Empty | Unit | Optimized a

93data Optimized a = Empty | Unit | Optimized a

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

94+ deriving stock (Functor, Foldable, Traversable)

123

95

124

96

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

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

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

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

13where

14

15-- base

16+import Control.Exception ( throwIO )

16import Data.Kind ( Type )

17import Data.Kind ( Type )

17import Prelude

18import Prelude

18

19

19-- hasql

20-- hasql

21+import Hasql.Connection ( Connection )

20import qualified Hasql.Encoders as Hasql

22import qualified Hasql.Encoders as Hasql

23+import qualified Hasql.Session as Hasql

21import qualified Hasql.Statement as Hasql

24import qualified Hasql.Statement as Hasql

22

25

23-- pretty

26-- pretty

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

28import Rel8.Query ( Query )

31import Rel8.Query ( Query )

29import Rel8.Schema.Name ( Selects )

32import Rel8.Schema.Name ( Selects )

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

33import 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+ )

32import Rel8.Statement.Set ( ppSet )

38import Rel8.Statement.Set ( ppSet )

33import Rel8.Statement.Using ( ppFrom )

39import Rel8.Statement.Using ( ppFrom )

34import Rel8.Statement.Where ( ppWhere )

40import Rel8.Statement.Where ( ppWhere )

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

57 -> Update a

63 -> Update a

58

64

59

65

60−ppUpdate :: Update a -> Doc

66+ppUpdate :: Update a -> Maybe Doc

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

67+ppUpdate Update {..} = do

62− Nothing ->

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

64− ppSet target id $$

65− text "WHERE false"

66− Just (fromDoc, i) ->

68+ (fromDoc, i) <- ppFrom from

69+ pure $

70+ text "UPDATE" <+>

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

71+ ppTable target $$

68 ppSet target (set i) $$

72 ppSet target (set i) $$

69 fromDoc $$

73 fromDoc $$

70 ppWhere target (updateWhere i) $$

74 ppWhere target (updateWhere i) $$

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

72

76

73

77

74-- | Run an @UPDATE@ statement.

78-- | Run an @UPDATE@ statement.

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

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

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

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

77− where

85+ where

86+ session = Hasql.statement () statement

87+ statement = Hasql.Statement bytes params decode prepare

78− bytes = encodeUtf8 $ Text.pack sql

88+ bytes = encodeUtf8 $ Text.pack sql

79− params = Hasql.noParams

89+ params = Hasql.noParams

80− decode = decodeReturning returning

90+ decode = decodeReturning returning

81− prepare = False

91+ prepare = False

82− sql = show doc

83− doc = ppUpdate u

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

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

3

4module Rel8.Statement.View

5 ( createView

6− , createOrReplaceView

7 )

6 )

8where

7where

9

8

10-- base

9-- base

10+import Control.Exception ( throwIO )

11+import Data.Foldable ( fold )

12+import Data.Maybe ( fromMaybe )

11import Prelude

13import Prelude

12

14

13-- hasql

15-- hasql

16+import Hasql.Connection ( Connection )

14import qualified Hasql.Decoders as Hasql

17import qualified Hasql.Decoders as Hasql

15import qualified Hasql.Encoders as Hasql

18import qualified Hasql.Encoders as Hasql

19+import qualified Hasql.Session as Hasql

16import qualified Hasql.Statement as Hasql

20import qualified Hasql.Statement as Hasql

17

21

18-- rel8

22-- rel8

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

21import Rel8.Schema.Table ( TableSchema )

25import Rel8.Schema.Table ( TableSchema )

22import Rel8.Statement.Insert ( ppInto )

26import Rel8.Statement.Insert ( ppInto )

23import Rel8.Statement.Select ( ppSelect )

27import Rel8.Statement.Select ( ppSelect )

28+import Rel8.Table.Alternative ( emptyTable )

24

29

25-- pretty

30-- pretty

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

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

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

30import Data.Text.Encoding ( encodeUtf8 )

35import Data.Text.Encoding ( encodeUtf8 )

31

36

32

37

33−data CreateView = Create | CreateOrReplace

34−

35−

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

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

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

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

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

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

39createView :: Selects names exprs

41createView :: Selects names exprs

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

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

41−createView =

43+createView connection schema query =

42− createViewGeneric Create

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

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

60 where

45 where

46+ session = Hasql.statement () statement

47+ statement = Hasql.Statement bytes params decode prepare

61 bytes = encodeUtf8 (Text.pack sql)

48 bytes = encodeUtf8 (Text.pack sql)

62 params = Hasql.noParams

49 params = Hasql.noParams

63 decode = Hasql.noResult

50 decode = Hasql.noResult

64 prepare = False

51 prepare = False

65− sql = show doc

66− doc = ppCreateView schema query replace

52+ sql = show (ppCreateView schema query)

67

53

68

54

69ppCreateView :: Selects names exprs

55ppCreateView :: Selects names exprs

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

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

71−ppCreateView schema query replace =

57+ppCreateView schema query =

72− createOrReplace replace <+>

58+ text "CREATE VIEW" <+>

73 ppInto schema $$

59 ppInto schema $$

74 text "AS" <+>

60 text "AS" <+>

75− ppSelect query

61+ fromMaybe fallback (ppSelect query)

76 where

62 where

77− createOrReplace Create = text "CREATE VIEW"

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

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

src/Rel8/Table/Aggregate.hs−12

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

37

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

39-- given table with 'groupByExpr'.

40−--

41−-- For example, if we have a table of items, we could group the items by the

42−-- order they belong to:

43−--

44−-- @

45−-- itemsByOrder :: Query (OrderId Expr, ListTable Expr (Item Expr))

46−-- itemsByOrder = aggregate $ do

47−-- item <- each itemSchema

48−-- let orderId = groupBy (itemOrderId item)

49−-- let orderItems = listAgg item

50−-- pure (orderId, orderItems)

51−-- @

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

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

53 => exprs -> aggregates

41 => exprs -> aggregates

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

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

src/Rel8/Table/HKD.hs−1

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

157 => HKDable a

158

159

160−type Top_ :: Constraint

161class Top_

160class Top_

162instance Top_

161instance Top_

163

162

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

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

11

12module Rel8.Table.List

13 ( ListTable(..)

14− , ($*)

15− , listTable

16− , nameListTable

14+ , listTable, nameListTable

17 )

15 )

18where

16where

19

17

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

30import Rel8.Schema.HTable.Vectorize

28import Rel8.Schema.HTable.Vectorize

31 ( hvectorize, hunvectorize

29 ( hvectorize, hunvectorize

32 , happend, hempty

30 , happend, hempty

33− , hproject, hcolumn

31+ , hproject

34 )

32 )

35import qualified Rel8.Schema.Kind as K

33import qualified Rel8.Schema.Kind as K

36import Rel8.Schema.Name ( Name( Name ) )

34import Rel8.Schema.Name ( Name( Name ) )

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

48 )

46 )

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

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

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

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

51−import Rel8.Table.Projection

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

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

53− )

54import Rel8.Table.Serialize ( ToExprs )

50import Rel8.Table.Serialize ( ToExprs )

55

51

56

52

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

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

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

121

117

122

118

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−

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

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

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

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

132listTable =

121listTable =

src/Rel8/Table/Maybe.hs−6

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

15 ( MaybeTable(..)

16 , maybeTable, nothingTable, justTable

17 , isNothingTable, isJustTable

18− , fromMaybeTable

19 , ($?)

18 , ($?)

20 , aggregateMaybeTable

19 , aggregateMaybeTable

21 , nameMaybeTable

20 , nameMaybeTable

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

207justTable = MaybeTable mempty . pure

206justTable = MaybeTable mempty . pure

208

207

209

208

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−

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

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

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

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

217-- @null@.

211-- @null@.

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

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

11

12module Rel8.Table.NonEmpty

13 ( NonEmptyTable(..)

14− , ($+)

15− , nonEmptyTable

16− , nameNonEmptyTable

14+ , nonEmptyTable, nameNonEmptyTable

17 )

15 )

18where

16where

19

17

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

31import Rel8.Schema.HTable.Vectorize

29import Rel8.Schema.HTable.Vectorize

32 ( hvectorize, hunvectorize

30 ( hvectorize, hunvectorize

33 , happend

31 , happend

34− , hproject, hcolumn

32+ , hproject

35 )

33 )

36import qualified Rel8.Schema.Kind as K

34import qualified Rel8.Schema.Kind as K

37import Rel8.Schema.Name ( Name( Name ) )

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

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

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

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

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

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

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

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

49−import Rel8.Table.Projection

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

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

51− )

52import Rel8.Table.Serialize ( ToExprs )

48import Rel8.Table.Serialize ( ToExprs )

53

49

54

50

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

114 happend (const sappend1) as bs

110 happend (const sappend1) as bs

115

111

116

112

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−

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

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

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

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

126nonEmptyTable =

115nonEmptyTable =

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

1{-# language DataKinds #-}

2−{-# language FlexibleContexts #-}

3{-# language FlexibleInstances #-}

2{-# language FlexibleInstances #-}

4{-# language LambdaCase #-}

3{-# language LambdaCase #-}

5{-# language MultiParamTypeClasses #-}

4{-# language MultiParamTypeClasses #-}

6−{-# language NamedFieldPuns #-}

7{-# language ScopedTypeVariables #-}

5{-# language ScopedTypeVariables #-}

8{-# language StandaloneKindSignatures #-}

6{-# language StandaloneKindSignatures #-}

9{-# language TypeApplications #-}

7{-# language TypeApplications #-}

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

14 ( Nullify

12 ( Nullify

15 , aggregateNullify

13 , aggregateNullify

16 , guard

14 , guard

17− , isNull

18 )

15 )

19where

16where

20

17

21-- base

18-- base

22import Control.Applicative ( liftA2 )

19import Control.Applicative ( liftA2 )

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

24import Data.Functor.Identity ( runIdentity )

20import Data.Functor.Identity ( runIdentity )

25import Data.Kind ( Type )

21import Data.Kind ( Type )

26import Prelude

22import Prelude

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

31-- rel8

27-- rel8

32import Rel8.Aggregate ( Aggregate )

28import Rel8.Aggregate ( Aggregate )

33import Rel8.Expr ( Expr )

29import Rel8.Expr ( Expr )

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

35−import qualified Rel8.Expr.Null as Expr

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

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

37import Rel8.Schema.Context.Nullify

31import Rel8.Schema.Context.Nullify

38 ( Nullifiability( NAggregate, NExpr )

32 ( Nullifiability( NAggregate, NExpr )

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

51 , hproject

45 , hproject

52 )

46 )

53import qualified Rel8.Schema.Kind as K

47import qualified Rel8.Schema.Kind as K

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

55import qualified Rel8.Schema.Result as R

48import qualified Rel8.Schema.Result as R

56import Rel8.Table

49import Rel8.Table

57 ( Table, Columns, Context, toColumns, fromColumns

50 ( Table, Columns, Context, toColumns, fromColumns

58 , FromExprs, fromResult, toResult

51 , FromExprs, fromResult, toResult

59 , Transpose

52 , Transpose

60 )

53 )

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

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

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

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

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

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

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

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

190 -> HNullify t context

182 -> HNullify t context

191guard tag isNonNull isNonNullExpr =

183guard tag isNonNull isNonNullExpr =

192 hguard (guarder contextSing tag isNonNull isNonNullExpr)

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

7{-# language TypeFamilies #-}

8{-# language ViewPatterns #-}

9

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

11−

12module Rel8.Table.Opaleye

10module Rel8.Table.Opaleye

13 ( aggregator

11 ( aggregator

14 , attributes

12 , attributes

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

28-- base

26-- base

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

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

30import Data.List.NonEmpty ( NonEmpty )

28import Data.List.NonEmpty ( NonEmpty )

31−import Prelude

29+import Prelude hiding ( undefined )

32

30

33-- opaleye

31-- opaleye

34−import qualified Opaleye.Adaptors as Opaleye

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

36import qualified Opaleye.Internal.Aggregate as Opaleye

32import qualified Opaleye.Internal.Aggregate as Opaleye

33+import qualified Opaleye.Internal.Binary as Opaleye

34+import qualified Opaleye.Internal.Distinct as Opaleye

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

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

36+import qualified Opaleye.Internal.PackMap as Opaleye

37+import qualified Opaleye.Internal.Unpackspec as Opaleye

38import qualified Opaleye.Internal.Values as Opaleye

39−import qualified Opaleye.Table as Opaleye

39+import qualified Opaleye.Internal.Table as Opaleye

40

41-- profunctors

42import Data.Profunctor ( dimap, lmap )

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

46import Rel8.Expr ( Expr )

47import Rel8.Expr.Opaleye

48 ( fromPrimExpr, toPrimExpr

49+ , traversePrimExpr

50+ , fromColumn, toColumn

49− , scastExpr, traverseFieldP

51+ , scastExpr

50 )

52 )

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

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

52− htraverseP, htraversePWithField )

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

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

54import Rel8.Schema.Spec ( Spec(..) )

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

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

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

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

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

57−import Rel8.Type.Information ( typeName )

58+import Rel8.Table.Undefined ( undefined )

58

59

59-- semigroupoids

60-- semigroupoids

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

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

61−import Data.Profunctor.Product ( ProductProfunctor )

62

63

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

65−aggregator = dimap toColumns fromColumns $

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

66− htraverseP $

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

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

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

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

69+ inner f ()

68

70

69

71

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

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

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

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

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

76

78

77

79

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−

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

80binaryspec :: 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)

87

86

88

87

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

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

91

96

92

97

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

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

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

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

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

107table (TableSchema name schema columns) =

112table (TableSchema name schema columns) =

108 case schema of

113 case schema of

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

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

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

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

111

116

112

117

113tableFields :: Selects names exprs

118tableFields :: Selects names exprs

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

119 where

124 where

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

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

121 go (Name name) =

126 go (Name name) =

122− traverseFieldP $

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

123 Opaleye.requiredTableField name

128 Opaleye.requiredTableField name

124

129

125

130

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

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

128{-# INLINABLE unpackspec #-}

137{-# INLINABLE unpackspec #-}

129

138

130

139

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

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

132−valuesspec = dimap toColumns fromColumns $

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

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

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

135

142

136

143

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

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

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

140 Name column -> fromPrimExpr $ Opaleye.BaseTableAttrExpr column

147 Name column -> fromPrimExpr $ Opaleye.BaseTableAttrExpr column

141

148

142

149

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+

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

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

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

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

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

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

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

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

146

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

148least :: OrdTable a => a -> a -> a

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

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

150

151

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

153greatest :: OrdTable a => a -> a -> a

154−greatest a b = bool 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

35 => Projecting a b

36instance

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

39 )

40 => Projecting a b

41

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

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

20 , isThisTable, isThatTable, isThoseTable

21 , hasHereTable, hasThereTable

22 , justHereTable, justThereTable

23− , alignMaybeTable

24 , aggregateTheseTable

23 , aggregateTheseTable

25 , nameTheseTable

24 , nameTheseTable

26 )

25 )

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

30import Data.Bifunctor ( Bifunctor, bimap )

29import Data.Bifunctor ( Bifunctor, bimap )

31import Data.Kind ( Type )

30import Data.Kind ( Type )

32import Data.Maybe ( isJust )

31import Data.Maybe ( isJust )

33−import Prelude hiding ( null, undefined )

32+import Prelude hiding ( undefined )

34

33

35-- rel8

34-- rel8

36import Rel8.Aggregate ( Aggregate )

35import Rel8.Aggregate ( Aggregate )

37import Rel8.Expr ( Expr )

36import Rel8.Expr ( Expr )

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

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

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

38+import Rel8.Expr.Null ( isNonNull )

40import Rel8.Kind.Context ( Reifiable )

39import Rel8.Kind.Context ( Reifiable )

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

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

42import Rel8.Schema.Dict ( Dict( Dict ) )

41import Rel8.Schema.Dict ( Dict( Dict ) )

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

289justThereTable = there

288justThereTable = there

290

289

291

290

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−

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

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

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

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

304thisTable a = TheseTable (justTable a) nothingTable

293thisTable 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.hs+21−24

@@ -58,7 +58,7 @@ import Data.Function ( on )

58import Data.Functor.Contravariant ( Contravariant, (>$<), contramap )

59import Data.Int ( Int64 )

60import Data.Kind ( Type )

61−import Data.Maybe ( fromJust, fromMaybe )

61+import Data.Maybe ( fromMaybe )

62import Prelude hiding ( lookup, zip, zipWith )

63

64-- bifunctors

@@ -69,7 +69,9 @@ import Control.Comonad ( extract )

69

70-- opaleye

71import qualified Opaleye.Aggregate as Opaleye

72−import qualified Opaleye.Order as Opaleye ( orderBy, distinctOnExplicit )

72+import qualified Opaleye.Internal.Order as Opaleye

73+import qualified Opaleye.Internal.QueryArr as Opaleye

74+import qualified Opaleye.Order as Opaleye ( orderBy )

73

75

74-- profunctors

76-- profunctors

75import Data.Profunctor ( dimap, lmap )

77import Data.Profunctor ( dimap, lmap )

@@ -90,10 +92,10 @@ import Rel8.Order ( Order( Order ) )

90import Rel8.Query ( Query )

92import Rel8.Query ( Query )

91import qualified Rel8.Query.Exists as Q ( exists, present, absent )

93import qualified Rel8.Query.Exists as Q ( exists, present, absent )

92import Rel8.Query.Filter ( where_ )

94import Rel8.Query.Filter ( where_ )

95+import Rel8.Query.Limit ( limit )

93import Rel8.Query.List ( catNonEmptyTable )

96import Rel8.Query.List ( catNonEmptyTable )

94import qualified Rel8.Query.Maybe as Q ( optional )

97import qualified Rel8.Query.Maybe as Q ( optional )

95import Rel8.Query.Opaleye ( mapOpaleye, unsafePeekQuery )

98import Rel8.Query.Opaleye ( mapOpaleye, unsafePeekQuery )

96−import Rel8.Query.Rebind ( rebind )

97import Rel8.Query.These ( alignBy )

99import Rel8.Query.These ( alignBy )

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

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

99import Rel8.Table.Aggregate ( hgroupBy, listAgg, nonEmptyAgg )

101import Rel8.Table.Aggregate ( hgroupBy, listAgg, nonEmptyAgg )

@@ -177,7 +179,7 @@ ensure (Predicate mp) = traverse_ (\k -> traverse_ (\p -> where_ (p k)) mp)

177-- stopping a 'Tabulation' from containing multiple rows with the same key, so

179-- stopping a 'Tabulation' from containing multiple rows with the same key, so

178-- technically @Map k (NonEmpty a)@ is more accurate.

180-- technically @Map k (NonEmpty a)@ is more accurate.

179--

181--

180−-- 'Tabulation's can be created from 'Query's with 'fromQuery' and 'liftQuery'

182+-- 'Tabulation's can be created from 'Query's with 'fromQuery' and 'littQuery'

181-- and converted back to 'Query's with 'lookup' and 'toQuery' (though note the

183-- and converted back to 'Query's with 'lookup' and 'toQuery' (though note the

182-- caveats that come with the latter).

184-- caveats that come with the latter).

183type Tabulation :: Type -> Type -> Type

185type Tabulation :: Type -> Type -> Type

@@ -234,13 +236,7 @@ instance EqTable k => Monad (Tabulation k) where

234-- | If @'Tabulation' k a@ is @Map k (NonEmpty a)@, then @(<|>:)@ is

236-- | If @'Tabulation' k a@ is @Map k (NonEmpty a)@, then @(<|>:)@ is

235-- @unionWith (<>)@.

237-- @unionWith (<>)@.

236instance EqTable k => AltTable (Tabulation k) where

238instance 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

239+ as <|>: bs = catNonEmptyTable `through` ((<>) `on` some) as bs

244

240

245

241

246instance EqTable k => AlternativeTable (Tabulation k) where

242instance EqTable k => AlternativeTable (Tabulation k) where

@@ -349,8 +345,19 @@ aggregate (Tabulation f) = Tabulation $

349-- \"first\" value it encounters for each key, but note that \"first\" is

345-- \"first\" value it encounters for each key, but note that \"first\" is

350-- undefined unless you first call 'order'.

346-- undefined unless you first call 'order'.

351distinct :: EqTable k => Tabulation k a -> Tabulation k a

347distinct :: EqTable k => Tabulation k a -> Tabulation k a

352−distinct (Tabulation f) = Tabulation $

348+distinct (Tabulation f) = Tabulation $ \p ->

349+ -- workaround for https://github.com/tomjaguarpaw/haskell-opaleye/pull/518

350+ case fst (unsafePeekQuery (f p)) of

351+ Nothing -> limit 1 (f p)

352+ Just _ ->

353+ mapOpaleye

354+ (\q ->

355+ Opaleye.productQueryArr

353− mapOpaleye (Opaleye.distinctOnExplicit (key unpackspec) fst) . f

356+ ( Opaleye.distinctOn (key unpackspec) fst

357+ . Opaleye.runSimpleQueryArr q

358+ )

359+ )

360+ (f p)

354

361

355

362

356-- | 'order' orders the /values/ of a 'Tabulation' within their

363-- | 'order' orders the /values/ of a 'Tabulation' within their

@@ -509,8 +516,8 @@ alignWith :: EqTable k

509 -> Tabulation k a -> Tabulation k b -> Tabulation k c

516 -> Tabulation k a -> Tabulation k b -> Tabulation k c

510alignWith f (Tabulation as) (Tabulation bs) = Tabulation $ \p -> do

517alignWith f (Tabulation as) (Tabulation bs) = Tabulation $ \p -> do

511 tkab <- liftF2 (alignBy condition) as bs p

518 tkab <- liftF2 (alignBy condition) as bs p

512− k <- traverse (rebind "key") $ recover $ bimap fst fst tkab

513 let

519 let

520+ k = recover $ bimap fst fst tkab

514 tab = bimap snd snd tkab

521 tab = bimap snd snd tkab

515 pure (k, f tab)

522 pure (k, f tab)

516 where

523 where

@@ -628,13 +635,3 @@ similarity a b = a <* present b

628-- @do@-notation.

635-- @do@-notation.

629difference :: EqTable k => Tabulation k a -> Tabulation k b -> Tabulation k a

636difference :: EqTable k => Tabulation k a -> Tabulation k b -> Tabulation k a

630difference a b = a <* absent b

637difference 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 #-}

2{-# language FlexibleInstances #-}

1{-# language FlexibleInstances #-}

3{-# language MonoLocalBinds #-}

2{-# language MonoLocalBinds #-}

4{-# language MultiWayIf #-}

3{-# language MultiWayIf #-}

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

128instance DBType Float where

127instance DBType Float where

129 typeInformation = TypeInformation

128 typeInformation = TypeInformation

130 { encode = \x -> Opaleye.ConstExpr

129 { encode = \x -> Opaleye.ConstExpr

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

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

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

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

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

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

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

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

135 , decode = Hasql.float4

134 , decode = Hasql.float4

136 , typeName = "float4"

135 , typeName = "float4"

137 }

136 }

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

141instance DBType Double where

140instance DBType Double where

142 typeInformation = TypeInformation

141 typeInformation = TypeInformation

143 { encode = \x -> Opaleye.ConstExpr

142 { encode = \x -> Opaleye.ConstExpr

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

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

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

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

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

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

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

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

148 , decode = Hasql.float8

147 , decode = Hasql.float8

149 , typeName = "float8"

148 , typeName = "float8"

150 }

149 }

src/Rel8/Type/Enum.hs−1

@@ -106,7 +106,6 @@ class (DBType a, Enumable a) => DBEnum a where

106

107-- | Types that are sum types, where each constructor is unary (that is, has no

108-- fields).

109−type Enumable :: Type -> Constraint

110class (Generic a, GEnumable (Rep a)) => Enumable a

109class (Generic a, GEnumable (Rep a)) => Enumable a

111instance (Generic a, GEnumable (Rep a)) => Enumable a

110instance (Generic a, GEnumable (Rep a)) => Enumable a

112

111

src/Rel8/Type/JSONBEncoded.hs−4

@@ -1,5 +1,3 @@

1−{-# language StandaloneKindSignatures #-}

2−

3module Rel8.Type.JSONBEncoded ( JSONBEncoded(..) ) where

1module Rel8.Type.JSONBEncoded ( JSONBEncoded(..) ) where

4

2

5-- aeson

3-- aeson

@@ -8,7 +6,6 @@ import Data.Aeson.Types ( parseEither )

8

6

9-- base

7-- base

10import Data.Bifunctor ( first )

8import Data.Bifunctor ( first )

11−import Data.Kind ( Type )

12import Prelude

9import Prelude

13

10

14-- hasql

11-- hasql

@@ -23,7 +20,6 @@ import Data.Text ( pack )

23

20

24

21

25-- | Like 'Rel8.JSONEncoded', but works for @jsonb@ columns.

22-- | Like 'Rel8.JSONEncoded', but works for @jsonb@ columns.

26−type JSONBEncoded :: Type -> Type

27newtype JSONBEncoded a = JSONBEncoded { fromJSONBEncoded :: a }

23newtype JSONBEncoded a = JSONBEncoded { fromJSONBEncoded :: a }

28

24

29

25

src/Rel8/Type/JSONEncoded.hs−4

@@ -1,5 +1,3 @@

1−{-# language StandaloneKindSignatures #-}

2−

3module Rel8.Type.JSONEncoded ( JSONEncoded(..) ) where

1module Rel8.Type.JSONEncoded ( JSONEncoded(..) ) where

4

2

5-- aeson

3-- aeson

@@ -7,7 +5,6 @@ import Data.Aeson ( FromJSON, ToJSON, parseJSON, toJSON )

7import Data.Aeson.Types ( parseEither )

5import Data.Aeson.Types ( parseEither )

8

6

9-- base

7-- base

10−import Data.Kind ( Type )

11import Prelude

8import Prelude

12

9

13-- rel8

10-- rel8

@@ -18,7 +15,6 @@ import Rel8.Type.Information ( parseTypeInformation )

18-- | A deriving-via helper type for column types that store a Haskell value

15-- | A deriving-via helper type for column types that store a Haskell value

19-- using a JSON encoding described by @aeson@'s 'ToJSON' and 'FromJSON' type

16-- using a JSON encoding described by @aeson@'s 'ToJSON' and 'FromJSON' type

20-- classes.

17-- classes.

21−type JSONEncoded :: Type -> Type

22newtype JSONEncoded a = JSONEncoded { fromJSONEncoded :: a }

18newtype JSONEncoded a = JSONEncoded { fromJSONEncoded :: a }

23

19

24

20

src/Rel8/Type/Num.hs+1−4

@@ -18,7 +18,6 @@ import Prelude

18

19-- rel8

20import Rel8.Type ( DBType )

21−import Rel8.Type.Ord ( DBOrd )

22

21

23-- scientific

22-- scientific

24import Data.Scientific ( Scientific )

23import Data.Scientific ( Scientific )

@@ -40,14 +39,13 @@ instance DBNum Scientific

40-- expressions. This is a Rel8 concept, and allows us to provide

39-- expressions. This is a Rel8 concept, and allows us to provide

41-- 'fromIntegral'.

40-- 'fromIntegral'.

42type DBIntegral :: Type -> Constraint

41type DBIntegral :: Type -> Constraint

43−class (DBNum a, DBOrd a) => DBIntegral a

42+class DBNum a => DBIntegral a

44instance DBIntegral Int16

43instance DBIntegral Int16

45instance DBIntegral Int32

44instance DBIntegral Int32

46instance DBIntegral Int64

45instance DBIntegral Int64

47

46

48

47

49-- | The class of database types that support the @/@ operator.

48-- | The class of database types that support the @/@ operator.

50−type DBFractional :: Type -> Constraint

51class DBNum a => DBFractional a

49class DBNum a => DBFractional a

52instance DBFractional Float

50instance DBFractional Float

53instance DBFractional Double

51instance DBFractional Double

@@ -55,7 +53,6 @@ instance DBFractional Scientific

55

53

56

54

57-- | The class of database types that support the @/@ operator.

55-- | The class of database types that support the @/@ operator.

58−type DBFloating :: Type -> Constraint

59class DBFractional a => DBFloating a

56class DBFractional a => DBFloating a

60instance DBFloating Float

57instance DBFloating Float

61instance DBFloating Double

58instance DBFloating Double

src/Rel8/Type/Ord.hs+2

@@ -75,6 +75,7 @@ instance Sql DBOrd a => DBOrd (NonEmpty a)

75-- | The class of database types that support the @max@ aggregation function.

76type DBMax :: Type -> Constraint

77class DBOrd a => DBMax a

78+instance DBMax Bool

78instance DBMax Char

79instance DBMax Char

79instance DBMax Int16

80instance DBMax Int16

80instance DBMax Int32

81instance DBMax Int32

@@ -100,6 +101,7 @@ instance Sql DBMax a => DBMax (NonEmpty a)

100-- | The class of database types that support the @min@ aggregation function.

101-- | The class of database types that support the @min@ aggregation function.

101type DBMin :: Type -> Constraint

102type DBMin :: Type -> Constraint

102class DBOrd a => DBMin a

103class DBOrd a => DBMin a

104+instance DBMin Bool

103instance DBMin Char

105instance DBMin Char

104instance DBMin Int16

106instance DBMin Int16

105instance DBMin Int32

107instance DBMin Int32

src/Rel8/Type/ReadShow.hs−3

@@ -1,12 +1,10 @@

1{-# language ScopedTypeVariables #-}

2−{-# language StandaloneKindSignatures #-}

3{-# language TypeApplications #-}

2{-# language TypeApplications #-}

4{-# language ViewPatterns #-}

3{-# language ViewPatterns #-}

5

4

6module Rel8.Type.ReadShow ( ReadShow(..) ) where

5module Rel8.Type.ReadShow ( ReadShow(..) ) where

7

6

8-- base

7-- base

9−import Data.Kind ( Type )

10import Data.Proxy ( Proxy( Proxy ) )

8import Data.Proxy ( Proxy( Proxy ) )

11import Data.Typeable ( Typeable, typeRep )

9import Data.Typeable ( Typeable, typeRep )

12import Prelude

10import Prelude

@@ -22,7 +20,6 @@ import qualified Data.Text as Text

22

20

23-- | A deriving-via helper type for column types that store a Haskell value

21-- | A deriving-via helper type for column types that store a Haskell value

24-- using a Haskell's 'Read' and 'Show' type classes.

22-- using a Haskell's 'Read' and 'Show' type classes.

25−type ReadShow :: Type -> Type

26newtype ReadShow a = ReadShow { fromReadShow :: a }

23newtype ReadShow a = ReadShow { fromReadShow :: a }

27

24

28

25

src/Rel8/Type/Tag.hs−1

@@ -90,7 +90,6 @@ instance DBMonoid MaybeTag where

90 memptyExpr = litExpr mempty

91

92

93−type Tag :: Type

94newtype Tag = Tag Text

93newtype Tag = Tag Text

95 deriving newtype

94 deriving newtype

96 ( Eq, Ord, Read, Show

95 ( 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 #-}

2{-# language BlockArguments #-}

1{-# language BlockArguments #-}

2+{-# language DataKinds #-}

3{-# language DeriveAnyClass #-}

4{-# language DeriveGeneric #-}

5{-# language DerivingStrategies #-}

6+{-# language DisambiguateRecordFields #-}

6{-# language FlexibleContexts #-}

7{-# language FlexibleContexts #-}

7{-# language FlexibleInstances #-}

8{-# language FlexibleInstances #-}

8−{-# language MonoLocalBinds #-}

9+{-# language GADTs #-}

9{-# language NamedFieldPuns #-}

10{-# language NamedFieldPuns #-}

10{-# language OverloadedStrings #-}

11{-# language OverloadedStrings #-}

11{-# language RecordWildCards #-}

12{-# language RecordWildCards #-}

@@ -13,15 +14,17 @@

13{-# language StandaloneDeriving #-}

14{-# language StandaloneDeriving #-}

14{-# language TypeApplications #-}

15{-# language TypeApplications #-}

15

16

17+{-# options_ghc -fno-warn-redundant-constraints #-}

18+

16module Main

19module Main

17 ( main

20 ( main

18 )

21 )

19where

22where

20

23

21-- base

24-- base

22−import Control.Applicative ( empty, liftA2, liftA3 )

25+import Control.Applicative ( liftA2, liftA3 )

23−import Control.Exception ( bracket, throwIO )

26+import Control.Monad (void)

24−import Control.Monad ( (>=>), void )

27+import Control.Monad.IO.Class ( MonadIO, liftIO )

25import Data.Bifunctor ( bimap )

28import Data.Bifunctor ( bimap )

26import Data.Foldable ( for_ )

29import Data.Foldable ( for_ )

27import Data.Int ( Int32, Int64 )

30import Data.Int ( Int32, Int64 )

@@ -35,27 +38,25 @@ import GHC.Generics ( Generic )

35import qualified Data.ByteString.Lazy

38import qualified Data.ByteString.Lazy

36

39

37-- case-insensitive

40-- case-insensitive

38−import Data.CaseInsensitive ( mk )

41+import Data.CaseInsensitive (mk)

39

42

40-- containers

43-- containers

41−import Data.Containers.ListUtils ( nubOrdOn )

42import qualified Data.Map.Strict as Map

44import qualified Data.Map.Strict as Map

43

45

44-- hasql

46-- hasql

45−import Hasql.Connection ( Connection, acquire, release )

47+import Hasql.Connection ( Connection, acquire, release )

46import Hasql.Session ( sql, run )

48import Hasql.Session ( sql, run )

47

49

48−-- hasql-transaction

49−import Hasql.Transaction ( Transaction, condemn, statement )

50−import qualified Hasql.Transaction.Sessions as Hasql

51−

52-- hedgehog

50-- hedgehog

53import Hedgehog ( property, (===), forAll, cover, diff, evalM, PropertyT, TestT, test, Gen )

51import Hedgehog ( property, (===), forAll, cover, diff, evalM, PropertyT, TestT, test, Gen )

54import qualified Hedgehog.Gen as Gen

52import qualified Hedgehog.Gen as Gen

55import qualified Hedgehog.Range as Range

53import qualified Hedgehog.Range as Range

56

54

57−-- mmorph

55+-- lifted-base

56+import Control.Exception.Lifted ( bracket, throwIO, bracket_ )

57+

58+-- monad-control

58−import Control.Monad.Morph ( hoist )

59+import Control.Monad.Trans.Control ( MonadBaseControl )

59

60

60-- rel8

61-- rel8

61import Rel8 ( Result )

62import Rel8 ( Result )

@@ -71,16 +72,12 @@ import Test.Tasty

71import Test.Tasty.Hedgehog ( testProperty )

72import Test.Tasty.Hedgehog ( testProperty )

72

73

73-- text

74-- text

74−import Data.Text ( Text, pack, unpack )

75+import Data.Text (Text, pack)

75import qualified Data.Text.Lazy

76import qualified Data.Text.Lazy

76−import Data.Text.Encoding ( decodeUtf8 )

77

78-- time

79import Data.Time

80

81−-- transformers

82−import Control.Monad.Trans.Class ( lift )

83−

84-- tmp-postgres

81-- tmp-postgres

85import qualified Database.Postgres.Temp as TmpPostgres

82import qualified Database.Postgres.Temp as TmpPostgres

86

83

@@ -116,13 +113,11 @@ tests =

116 , testCatMaybeTable getTestDatabase

113 , testCatMaybeTable getTestDatabase

117 , testCatMaybe getTestDatabase

114 , testCatMaybe getTestDatabase

118 , testMaybeTable getTestDatabase

115 , testMaybeTable getTestDatabase

119− , testAggregateMaybeTable getTestDatabase

120 , testNestedTables getTestDatabase

116 , testNestedTables getTestDatabase

121 , testMaybeTableApplicative getTestDatabase

117 , testMaybeTableApplicative getTestDatabase

122 , testLogicalFixities getTestDatabase

118 , testLogicalFixities getTestDatabase

123 , testUpdate getTestDatabase

119 , testUpdate getTestDatabase

124 , testDelete getTestDatabase

120 , testDelete getTestDatabase

125− , testUpsert getTestDatabase

126 , testSelectNestedPairs getTestDatabase

121 , testSelectNestedPairs getTestDatabase

127 , testSelectArray getTestDatabase

122 , testSelectArray getTestDatabase

128 , testNestedMaybeTable getTestDatabase

123 , testNestedMaybeTable getTestDatabase

@@ -138,7 +133,6 @@ tests =

138 flip run conn do

133 flip run conn do

139 sql "CREATE EXTENSION citext"

134 sql "CREATE EXTENSION citext"

140 sql "CREATE TABLE test_table ( column1 text not null, column2 bool not null )"

135 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 )"

142 sql "CREATE SEQUENCE test_seq"

136 sql "CREATE SEQUENCE test_seq"

143

137

144 return db

138 return db

@@ -146,21 +140,19 @@ tests =

146 stopTestDatabase = TmpPostgres.stop

140 stopTestDatabase = TmpPostgres.stop

147

141

148

142

149−connect :: TmpPostgres.DB -> IO Connection

150−connect = acquire . TmpPostgres.toConnectionString >=> either (maybe empty (fail . unpack . decodeUtf8)) pure

151−

152−

153databasePropertyTest

143databasePropertyTest

154 :: TestName

144 :: TestName

155− -> ((TestT Transaction () -> PropertyT IO ()) -> PropertyT IO ())

145+ -> (((Connection -> TestT IO ()) -> PropertyT IO ()) -> PropertyT IO ())

156 -> IO TmpPostgres.DB -> TestTree

146 -> IO TmpPostgres.DB -> TestTree

157databasePropertyTest testName f getTestDatabase =

147databasePropertyTest testName f getTestDatabase =

158− withResource (connect =<< getTestDatabase) release $ \c ->

148+ withResource connect release $ \c ->

159 testProperty testName $ property do

149 testProperty testName $ property do

160− connection <- lift c

150+ connection <- liftIO c

161− f $ test . hoist \m -> do

151+ f \g -> test $ rollingBack connection $ g connection

162− e <- run (Hasql.transaction Hasql.Serializable Hasql.Write (m <* condemn)) connection

152+

163− either throwIO pure e

153+ where

154+

155+ connect = either (error . show) return =<< acquire . TmpPostgres.toConnectionString =<< getTestDatabase

164

156

165

157

166data TestTable f = TestTable

158data TestTable f = TestTable

@@ -192,17 +184,17 @@ testSelectTestTable :: IO TmpPostgres.DB -> TestTree

192testSelectTestTable = databasePropertyTest "Can SELECT TestTable" \transaction -> do

184testSelectTestTable = databasePropertyTest "Can SELECT TestTable" \transaction -> do

193 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable

185 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable

194

186

195− transaction do

187+ transaction \connection -> do

196− selected <- lift do

188+ liftIO $ Rel8.insert connection

197− statement () $ Rel8.insert Rel8.Insert

189+ Rel8.Insert

198 { into = testTableSchema

190 { into = testTableSchema

199 , rows = Rel8.values $ map Rel8.lit rows

191 , rows = Rel8.values $ map Rel8.lit rows

200 , onConflict = Rel8.DoNothing

192 , onConflict = Rel8.DoNothing

201 , returning = pure ()

193 , returning = pure ()

202 }

194 }

203

195

204− statement () $ Rel8.select do

196+ selected <- liftIO $ Rel8.select connection do

205− Rel8.each testTableSchema

197+ Rel8.each testTableSchema

206

198

207 sort selected === sort rows

199 sort selected === sort rows

208

200

@@ -219,12 +211,11 @@ testWhere_ = databasePropertyTest "WHERE (Rel8.where_)" \transaction -> do

219

211

220 let expected = filter (\t -> testTableColumn2 t == magicBool) rows

212 let expected = filter (\t -> testTableColumn2 t == magicBool) rows

221

213

222− transaction do

214+ transaction \connection -> do

223− selected <- lift do

224− statement () $ Rel8.select do

215+ selected <- liftIO $ Rel8.select connection do

225− t <- Rel8.values $ Rel8.lit <$> rows

216+ t <- Rel8.values $ Rel8.lit <$> rows

226− Rel8.where_ $ testTableColumn2 t Rel8.==. Rel8.lit magicBool

217+ Rel8.where_ $ testTableColumn2 t Rel8.==. Rel8.lit magicBool

227− return t

218+ return t

228

219

229 sort selected === sort expected

220 sort selected === sort expected

230

221

@@ -237,12 +228,11 @@ testFilter :: IO TmpPostgres.DB -> TestTree

237testFilter = databasePropertyTest "filter" \transaction -> do

228testFilter = databasePropertyTest "filter" \transaction -> do

238 rows <- forAll $ Gen.list (Range.linear 1 10) genTestTable

229 rows <- forAll $ Gen.list (Range.linear 1 10) genTestTable

239

230

240− transaction do

231+ transaction \connection -> do

241 let expected = filter testTableColumn2 rows

232 let expected = filter testTableColumn2 rows

242

233

243− selected <- lift do

234+ selected <- liftIO $ Rel8.select connection

244− statement () $ Rel8.select do

245− Rel8.filter testTableColumn2 =<< Rel8.values (Rel8.lit <$> rows)

235+ $ Rel8.filter testTableColumn2 =<< Rel8.values (Rel8.lit <$> rows)

246

236

247 sort selected === sort expected

237 sort selected === sort expected

248

238

@@ -257,10 +247,9 @@ testLimit = databasePropertyTest "LIMIT (Rel8.limit)" \transaction -> do

257

247

258 n <- forAll $ Gen.integral (Range.linear 0 10)

248 n <- forAll $ Gen.integral (Range.linear 0 10)

259

249

260− transaction do

250+ transaction \connection -> do

261− selected <- lift do

251+ selected <- liftIO $ Rel8.select connection do

262− statement () $ Rel8.select do

263− Rel8.limit n $ Rel8.values (Rel8.lit <$> rows)

252+ Rel8.limit n $ Rel8.values (Rel8.lit <$> rows)

264

253

265 diff (length selected) (<=) (fromIntegral n)

254 diff (length selected) (<=) (fromIntegral n)

266

255

@@ -278,10 +267,9 @@ testUnion = databasePropertyTest "UNION (Rel8.union)" \transaction -> evalM do

278 left <- forAll $ Gen.list (Range.linear 0 10) genTestTable

267 left <- forAll $ Gen.list (Range.linear 0 10) genTestTable

279 right <- forAll $ Gen.list (Range.linear 0 10) genTestTable

268 right <- forAll $ Gen.list (Range.linear 0 10) genTestTable

280

269

281− transaction do

270+ transaction \connection -> do

282− selected <- lift do

271+ selected <- liftIO $ Rel8.select connection do

283− statement () $ Rel8.select do

284− Rel8.values (Rel8.lit <$> nub left) `Rel8.union` Rel8.values (Rel8.lit <$> nub right)

272+ Rel8.values (Rel8.lit <$> nub left) `Rel8.union` Rel8.values (Rel8.lit <$> nub right)

285

273

286 sort selected === sort (nub (left ++ right))

274 sort selected === sort (nub (left ++ right))

287

275

@@ -290,11 +278,9 @@ testDistinct :: IO TmpPostgres.DB -> TestTree

290testDistinct = databasePropertyTest "DISTINCT (Rel8.distinct)" \transaction -> do

278testDistinct = databasePropertyTest "DISTINCT (Rel8.distinct)" \transaction -> do

291 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable

279 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable

292

280

293− transaction do

281+ transaction \connection -> do

294− selected <- lift do

295− statement () $ Rel8.select do

296− Rel8.distinct do

282+ selected <- liftIO $ Rel8.select connection $ Rel8.distinct do

297− Rel8.values (Rel8.lit <$> rows)

283+ Rel8.values (Rel8.lit <$> rows)

298

284

299 sort selected === nub (sort rows)

285 sort selected === nub (sort rows)

300

286

@@ -307,10 +293,8 @@ testExists :: IO TmpPostgres.DB -> TestTree

307testExists = databasePropertyTest "EXISTS (Rel8.exists)" \transaction -> do

293testExists = databasePropertyTest "EXISTS (Rel8.exists)" \transaction -> do

308 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable

294 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable

309

295

310− transaction do

296+ transaction \connection -> do

311− exists <- lift do

312− statement () $ Rel8.select do

313− Rel8.exists $ Rel8.values $ Rel8.lit <$> rows

297+ exists <- liftIO $ Rel8.select connection $ Rel8.exists $ Rel8.values $ Rel8.lit <$> rows

314

298

315 case rows of

299 case rows of

316 [] -> exists === [False]

300 [] -> exists === [False]

@@ -321,10 +305,9 @@ testOptional :: IO TmpPostgres.DB -> TestTree

321testOptional = databasePropertyTest "Rel8.optional" \transaction -> do

305testOptional = databasePropertyTest "Rel8.optional" \transaction -> do

322 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable

306 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable

323

307

324− transaction do

308+ transaction \connection -> do

325− selected <- lift do

309+ selected <- liftIO $ Rel8.select connection do

326− statement () $ Rel8.select do

327− Rel8.optional $ Rel8.values (Rel8.lit <$> rows)

310+ Rel8.optional $ Rel8.values (Rel8.lit <$> rows)

328

311

329 case rows of

312 case rows of

330 [] -> selected === [Nothing]

313 [] -> selected === [Nothing]

@@ -335,10 +318,9 @@ testAnd :: IO TmpPostgres.DB -> TestTree

335testAnd = databasePropertyTest "AND (&&.)" \transaction -> do

318testAnd = databasePropertyTest "AND (&&.)" \transaction -> do

336 (x, y) <- forAll $ liftA2 (,) Gen.bool Gen.bool

319 (x, y) <- forAll $ liftA2 (,) Gen.bool Gen.bool

337

320

338− transaction do

321+ transaction \connection -> do

339− [result] <- lift do

322+ [result] <- liftIO $ Rel8.select connection $ pure $

340− statement () $ Rel8.select do

341− pure $ Rel8.lit x Rel8.&&. Rel8.lit y

323+ Rel8.lit x Rel8.&&. Rel8.lit y

342

324

343 result === (x && y)

325 result === (x && y)

344

326

@@ -347,10 +329,9 @@ testOr :: IO TmpPostgres.DB -> TestTree

347testOr = databasePropertyTest "OR (||.)" \transaction -> do

329testOr = databasePropertyTest "OR (||.)" \transaction -> do

348 (x, y) <- forAll $ liftA2 (,) Gen.bool Gen.bool

330 (x, y) <- forAll $ liftA2 (,) Gen.bool Gen.bool

349

331

350− transaction do

332+ transaction \connection -> do

351− [result] <- lift do

352− statement () $ Rel8.select $ pure $

333+ [result] <- liftIO $ Rel8.select connection $ pure $

353− Rel8.lit x Rel8.||. Rel8.lit y

334+ Rel8.lit x Rel8.||. Rel8.lit y

354

335

355 result === (x || y)

336 result === (x || y)

356

337

@@ -359,10 +340,9 @@ testLogicalFixities :: IO TmpPostgres.DB -> TestTree

359testLogicalFixities = databasePropertyTest "Logical operator fixities" \transaction -> do

340testLogicalFixities = databasePropertyTest "Logical operator fixities" \transaction -> do

360 (u, v, w, x) <- forAll $ (,,,) <$> Gen.bool <*> Gen.bool <*> Gen.bool <*> Gen.bool

341 (u, v, w, x) <- forAll $ (,,,) <$> Gen.bool <*> Gen.bool <*> Gen.bool <*> Gen.bool

361

342

362− transaction do

343+ transaction \connection -> do

363− [result] <- lift do

344+ [result] <- liftIO $ Rel8.select connection $ pure $

364− statement () $ Rel8.select do

365− pure $ Rel8.lit u Rel8.||. Rel8.lit v Rel8.&&. Rel8.lit w Rel8.==. Rel8.lit x

345+ Rel8.lit u Rel8.||. Rel8.lit v Rel8.&&. Rel8.lit w Rel8.==. Rel8.lit x

366

346

367 result === (u || v && w == x)

347 result === (u || v && w == x)

368

348

@@ -371,10 +351,9 @@ testNot :: IO TmpPostgres.DB -> TestTree

371testNot = databasePropertyTest "NOT (not_)" \transaction -> do

351testNot = databasePropertyTest "NOT (not_)" \transaction -> do

372 x <- forAll Gen.bool

352 x <- forAll Gen.bool

373

353

374− transaction do

354+ transaction \connection -> do

375− [result] <- lift do

355+ [result] <- liftIO $ Rel8.select connection $ pure $

376− statement () $ Rel8.select do

377− pure $ Rel8.not_ $ Rel8.lit x

356+ Rel8.not_ $ Rel8.lit x

378

357

379 result === not x

358 result === not x

380

359

@@ -383,10 +362,9 @@ testBool :: IO TmpPostgres.DB -> TestTree

383testBool = databasePropertyTest "ifThenElse_" \transaction -> do

362testBool = databasePropertyTest "ifThenElse_" \transaction -> do

384 (x, y, z) <- forAll $ liftA3 (,,) Gen.bool Gen.bool Gen.bool

363 (x, y, z) <- forAll $ liftA3 (,,) Gen.bool Gen.bool Gen.bool

385

364

386− transaction do

365+ transaction \connection -> do

387− [result] <- lift do

366+ [result] <- liftIO $ Rel8.select connection $ pure $

388− statement () $ Rel8.select do

389− pure $ Rel8.bool (Rel8.lit z) (Rel8.lit y) (Rel8.lit x)

367+ Rel8.bool (Rel8.lit z) (Rel8.lit y) (Rel8.lit x)

390

368

391 result === if x then y else z

369 result === if x then y else z

392

370

@@ -398,10 +376,9 @@ testAp = databasePropertyTest "Cartesian product (<*>)" \transaction -> do

398 (Gen.list (Range.linear 1 10) genTestTable)

376 (Gen.list (Range.linear 1 10) genTestTable)

399 (Gen.list (Range.linear 1 10) genTestTable)

377 (Gen.list (Range.linear 1 10) genTestTable)

400

378

401− transaction do

379+ transaction \connection -> do

402− result <- lift do

380+ result <- liftIO $ Rel8.select connection $ do

403− statement () $ Rel8.select do

404− liftA2 (,) (Rel8.values (Rel8.lit <$> rows1)) (Rel8.values (Rel8.lit <$> rows2))

381+ liftA2 (,) (Rel8.values (Rel8.lit <$> rows1)) (Rel8.values (Rel8.lit <$> rows2))

405

382

406 sort result === sort (liftA2 (,) rows1 rows2)

383 sort result === sort (liftA2 (,) rows1 rows2)

407

384

@@ -430,22 +407,21 @@ testDBType getTestDatabase = testGroup "DBType instances"

430 where

407 where

431 dbTypeTest :: (Eq a, Show a, Rel8.DBType a) => TestName -> Gen a -> TestTree

408 dbTypeTest :: (Eq a, Show a, Rel8.DBType a) => TestName -> Gen a -> TestTree

432 dbTypeTest name generator = testGroup name

409 dbTypeTest name generator = testGroup name

433− [ databasePropertyTest name (t generator) getTestDatabase

410+ [ databasePropertyTest name (t (==) generator) getTestDatabase

434− , databasePropertyTest ("Maybe " <> name) (t (Gen.maybe generator)) getTestDatabase

411+ , databasePropertyTest ("Maybe " <> name) (t (==) (Gen.maybe generator)) getTestDatabase

435 ]

412 ]

436

413

437− t :: forall a b. (Eq a, Show a, Rel8.Sql Rel8.DBType a)

414+ t :: forall a b. (Show a, Rel8.Sql Rel8.DBType a)

415+ => (a -> a -> Bool)

438− => Gen a

416+ -> Gen a

439− -> (TestT Transaction () -> PropertyT IO b)

417+ -> ((Connection -> TestT IO ()) -> PropertyT IO b)

440 -> PropertyT IO b

418 -> PropertyT IO b

441− t generator transaction = do

419+ t eq generator transaction = do

442 x <- forAll generator

420 x <- forAll generator

443

421

444− transaction do

422+ transaction \connection -> do

445− [res] <- lift do

446− statement () $ Rel8.select do

447− pure (Rel8.litExpr x)

423+ [res] <- liftIO $ Rel8.select connection $ pure (Rel8.litExpr x)

448− diff res (==) x

424+ diff res eq x

449

425

450 genDay :: Gen Day

426 genDay :: Gen Day

451 genDay = do

427 genDay = do

@@ -487,15 +463,13 @@ testDBEq getTestDatabase = testGroup "DBEq instances"

487

463

488 t :: forall a. (Eq a, Show a, Rel8.Sql Rel8.DBEq a)

464 t :: forall a. (Eq a, Show a, Rel8.Sql Rel8.DBEq a)

489 => Gen a

465 => Gen a

490− -> (TestT Transaction () -> PropertyT IO ())

466+ -> ((Connection -> TestT IO ()) -> PropertyT IO ())

491 -> PropertyT IO ()

467 -> PropertyT IO ()

492 t generator transaction = do

468 t generator transaction = do

493 (x, y) <- forAll (liftA2 (,) generator generator)

469 (x, y) <- forAll (liftA2 (,) generator generator)

494

470

495− transaction do

471+ transaction \connection -> do

496− [res] <- lift do

497− statement () $ Rel8.select do

498− pure $ Rel8.litExpr x Rel8.==. Rel8.litExpr y

472+ [res] <- liftIO $ Rel8.select connection $ pure $ Rel8.litExpr x Rel8.==. Rel8.litExpr y

499 res === (x == y)

473 res === (x == y)

500

474

501

475

@@ -503,10 +477,9 @@ testTableEquality :: IO TmpPostgres.DB -> TestTree

503testTableEquality = databasePropertyTest "TestTable equality" \transaction -> do

477testTableEquality = databasePropertyTest "TestTable equality" \transaction -> do

504 (x, y) <- forAll $ liftA2 (,) genTestTable genTestTable

478 (x, y) <- forAll $ liftA2 (,) genTestTable genTestTable

505

479

506− transaction do

480+ transaction \connection -> do

507− [eq] <- lift do

481+ [eq] <- liftIO $ Rel8.select connection do

508− statement () $ Rel8.select do

509− pure $ Rel8.lit x Rel8.==: Rel8.lit y

482+ pure $ Rel8.lit x Rel8.==: Rel8.lit y

510

483

511 eq === (x == y)

484 eq === (x == y)

512

485

@@ -515,10 +488,8 @@ testFromString :: IO TmpPostgres.DB -> TestTree

515testFromString = databasePropertyTest "FromString" \transaction -> do

488testFromString = databasePropertyTest "FromString" \transaction -> do

516 str <- forAll $ Gen.list (Range.linear 0 10) Gen.unicode

489 str <- forAll $ Gen.list (Range.linear 0 10) Gen.unicode

517

490

518− transaction do

491+ transaction \connection -> do

519− [result] <- lift do

520− statement () $ Rel8.select do

521− pure $ fromString str

492+ [result] <- liftIO $ Rel8.select connection $ pure $ fromString str

522 result === pack str

493 result === pack str

523

494

524

495

@@ -526,11 +497,10 @@ testCatMaybeTable :: IO TmpPostgres.DB -> TestTree

526testCatMaybeTable = databasePropertyTest "catMaybeTable" \transaction -> do

497testCatMaybeTable = databasePropertyTest "catMaybeTable" \transaction -> do

527 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable

498 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable

528

499

529− transaction do

500+ transaction \connection -> do

530− selected <- lift do

531− statement () $ Rel8.select do

501+ selected <- liftIO $ Rel8.select connection do

532− testTable <- Rel8.values $ Rel8.lit <$> rows

502+ testTable <- Rel8.values $ Rel8.lit <$> rows

533− Rel8.catMaybeTable $ Rel8.bool Rel8.nothingTable (pure testTable) (testTableColumn2 testTable)

503+ Rel8.catMaybeTable $ Rel8.bool Rel8.nothingTable (pure testTable) (testTableColumn2 testTable)

534

504

535 sort selected === sort (filter testTableColumn2 rows)

505 sort selected === sort (filter testTableColumn2 rows)

536

506

@@ -539,10 +509,9 @@ testCatMaybe :: IO TmpPostgres.DB -> TestTree

539testCatMaybe = databasePropertyTest "catMaybe" \transaction -> evalM do

509testCatMaybe = databasePropertyTest "catMaybe" \transaction -> evalM do

540 rows <- forAll $ Gen.list (Range.linear 0 10) $ Gen.maybe Gen.bool

510 rows <- forAll $ Gen.list (Range.linear 0 10) $ Gen.maybe Gen.bool

541

511

542− transaction do

512+ transaction \connection -> do

543− selected <- lift do

513+ selected <- evalM $ liftIO $ Rel8.select connection do

544− statement () $ Rel8.select do

545− Rel8.catNull =<< Rel8.values (map Rel8.lit rows)

514+ Rel8.catNull =<< Rel8.values (map Rel8.lit rows)

546

515

547 sort selected === sort (catMaybes rows)

516 sort selected === sort (catMaybes rows)

548

517

@@ -551,38 +520,15 @@ testMaybeTable :: IO TmpPostgres.DB -> TestTree

551testMaybeTable = databasePropertyTest "maybeTable" \transaction -> evalM do

520testMaybeTable = databasePropertyTest "maybeTable" \transaction -> evalM do

552 (rows, def) <- forAll $ liftA2 (,) (Gen.list (Range.linear 0 10) genTestTable) genTestTable

521 (rows, def) <- forAll $ liftA2 (,) (Gen.list (Range.linear 0 10) genTestTable) genTestTable

553

522

554− transaction do

523+ transaction \connection -> do

555− selected <- lift do

524+ selected <- liftIO $ Rel8.select connection $

556− statement () $ Rel8.select do

557− Rel8.maybeTable (Rel8.lit def) id <$> Rel8.optional (Rel8.values (Rel8.lit <$> rows))

525+ Rel8.maybeTable (Rel8.lit def) id <$> Rel8.optional (Rel8.values (Rel8.lit <$> rows))

558

526

559 case rows of

527 case rows of

560 [] -> selected === [def]

528 [] -> selected === [def]

561 _ -> sort selected === sort rows

529 _ -> sort selected === sort rows

562

530

563

531

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−

586data TwoTestTables f =

532data TwoTestTables f =

587 TwoTestTables

533 TwoTestTables

588 { testTable1 :: TestTable f

534 { testTable1 :: TestTable f

@@ -603,10 +549,9 @@ testNestedTables = databasePropertyTest "Nested TestTables" \transaction -> eval

603 Gen.list (Range.linear 0 10) $

549 Gen.list (Range.linear 0 10) $

604 liftA2 TwoTestTables genTestTable genTestTable

550 liftA2 TwoTestTables genTestTable genTestTable

605

551

606− transaction do

552+ transaction \connection -> do

607− selected <- lift do

553+ selected <- liftIO $ Rel8.select connection do

608− statement () $ Rel8.select do

609− Rel8.values (Rel8.lit <$> rows)

554+ Rel8.values (Rel8.lit <$> rows)

610

555

611 sort selected === sort rows

556 sort selected === sort rows

612

557

@@ -616,12 +561,11 @@ testMaybeTableApplicative = databasePropertyTest "MaybeTable (<*>)" \transaction

616 rows1 <- genRows

561 rows1 <- genRows

617 rows2 <- genRows

562 rows2 <- genRows

618

563

619− transaction do

564+ transaction \connection -> do

620− selected <- lift do

621− statement () $ Rel8.select do

565+ selected <- liftIO $ Rel8.select connection do

622− as <- Rel8.optional (Rel8.values (Rel8.lit <$> rows1))

566+ as <- Rel8.optional (Rel8.values (Rel8.lit <$> rows1))

623− bs <- Rel8.optional (Rel8.values (Rel8.lit <$> rows2))

567+ bs <- Rel8.optional (Rel8.values (Rel8.lit <$> rows2))

624− pure $ liftA2 (,) as bs

568+ pure $ liftA2 (,) as bs

625

569

626 case (rows1, rows2) of

570 case (rows1, rows2) of

627 ([], []) -> selected === [Nothing]

571 ([], []) -> selected === [Nothing]

@@ -633,6 +577,14 @@ testMaybeTableApplicative = databasePropertyTest "MaybeTable (<*>)" \transaction

633 genRows = forAll do

577 genRows = forAll do

634 Gen.list (Range.linear 0 10) $ liftA2 TestTable (Gen.text (Range.linear 0 10) Gen.unicode) (pure True)

578 Gen.list (Range.linear 0 10) $ liftA2 TestTable (Gen.text (Range.linear 0 10) Gen.unicode) (pure True)

635

579

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+

636

588

637genTestTable :: Gen (TestTable Result)

589genTestTable :: Gen (TestTable Result)

638genTestTable = do

590genTestTable = do

@@ -645,16 +597,17 @@ testUpdate :: IO TmpPostgres.DB -> TestTree

645testUpdate = databasePropertyTest "Can UPDATE TestTable" \transaction -> do

597testUpdate = databasePropertyTest "Can UPDATE TestTable" \transaction -> do

646 rows <- forAll $ Gen.map (Range.linear 0 5) $ liftA2 (,) genTestTable genTestTable

598 rows <- forAll $ Gen.map (Range.linear 0 5) $ liftA2 (,) genTestTable genTestTable

647

599

648− transaction do

600+ transaction \connection -> do

649− selected <- lift do

601+ liftIO $ Rel8.insert connection

650− statement () $ Rel8.insert Rel8.Insert

602+ Rel8.Insert

651 { into = testTableSchema

603 { into = testTableSchema

652 , rows = Rel8.values $ map Rel8.lit $ Map.keys rows

604 , rows = Rel8.values $ map Rel8.lit $ Map.keys rows

653 , onConflict = Rel8.DoNothing

605 , onConflict = Rel8.DoNothing

654 , returning = pure ()

606 , returning = pure ()

655 }

607 }

656

608

609+ liftIO $ Rel8.update connection

657− statement () $ Rel8.update Rel8.Update

610+ Rel8.Update

658 { target = testTableSchema

611 { target = testTableSchema

659 , from = pure ()

612 , from = pure ()

660 , set = \_ r ->

613 , set = \_ r ->

@@ -675,8 +628,8 @@ testUpdate = databasePropertyTest "Can UPDATE TestTable" \transaction -> do

675 , returning = pure ()

628 , returning = pure ()

676 }

629 }

677

630

678− statement () $ Rel8.select do

631+ selected <- liftIO $ Rel8.select connection do

679− Rel8.each testTableSchema

632+ Rel8.each testTableSchema

680

633

681 sort selected === sort (Map.elems rows)

634 sort selected === sort (Map.elems rows)

682

635

@@ -689,96 +642,30 @@ testDelete :: IO TmpPostgres.DB -> TestTree

689testDelete = databasePropertyTest "Can DELETE TestTable" \transaction -> do

642testDelete = databasePropertyTest "Can DELETE TestTable" \transaction -> do

690 rows <- forAll $ Gen.list (Range.linear 0 5) genTestTable

643 rows <- forAll $ Gen.list (Range.linear 0 5) genTestTable

691

644

692− transaction do

645+ transaction \connection -> do

693− (deleted, selected) <- lift do

646+ liftIO $ Rel8.insert connection

694− statement () $ Rel8.insert Rel8.Insert

647+ Rel8.Insert

695 { into = testTableSchema

648 { into = testTableSchema

696 , rows = Rel8.values $ map Rel8.lit rows

649 , rows = Rel8.values $ map Rel8.lit rows

697 , onConflict = Rel8.DoNothing

650 , onConflict = Rel8.DoNothing

698 , returning = pure ()

651 , returning = pure ()

699 }

652 }

700

653

654+ deleted <-

655+ liftIO $ Rel8.delete connection

701− deleted <- statement () $ Rel8.delete Rel8.Delete

656+ Rel8.Delete

702 { from = testTableSchema

657 { from = testTableSchema

703 , using = pure ()

658 , using = pure ()

704 , deleteWhere = const testTableColumn2

659 , deleteWhere = const testTableColumn2

705 , returning = Rel8.Projection id

660 , returning = Rel8.Projection id

706 }

661 }

707

662

708− selected <- statement () $ Rel8.select do

663+ selected <- liftIO $ Rel8.select connection do

709− Rel8.each testTableSchema

664+ Rel8.each testTableSchema

710−

711− pure (deleted, selected)

712

665

713 sort (deleted <> selected) === sort rows

666 sort (deleted <> selected) === sort rows

714

667

715

668

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−

782newtype HKNestedPair f = HKNestedPair { pairOne :: (TestTable f, TestTable f) }

669newtype HKNestedPair f = HKNestedPair { pairOne :: (TestTable f, TestTable f) }

783 deriving stock Generic

670 deriving stock Generic

784 deriving anyclass Rel8.Rel8able

671 deriving anyclass Rel8.Rel8able

@@ -792,10 +679,9 @@ testSelectNestedPairs :: IO TmpPostgres.DB -> TestTree

792testSelectNestedPairs = databasePropertyTest "Can SELECT nested pairs" \transaction -> do

679testSelectNestedPairs = databasePropertyTest "Can SELECT nested pairs" \transaction -> do

793 rows <- forAll $ Gen.list (Range.linear 0 10) $ HKNestedPair <$> liftA2 (,) genTestTable genTestTable

680 rows <- forAll $ Gen.list (Range.linear 0 10) $ HKNestedPair <$> liftA2 (,) genTestTable genTestTable

794

681

795− transaction do

682+ transaction \connection -> do

796− selected <- lift do

683+ selected <- liftIO $ Rel8.select connection do

797− statement () $ Rel8.select do

798− Rel8.values $ map Rel8.lit rows

684+ Rel8.values $ map Rel8.lit rows

799

685

800 sort selected === sort rows

686 sort selected === sort rows

801

687

@@ -804,20 +690,18 @@ testSelectArray :: IO TmpPostgres.DB -> TestTree

804testSelectArray = databasePropertyTest "Can SELECT Arrays (with aggregation)" \transaction -> do

690testSelectArray = databasePropertyTest "Can SELECT Arrays (with aggregation)" \transaction -> do

805 rows <- forAll $ Gen.list (Range.linear 1 10) Gen.bool

691 rows <- forAll $ Gen.list (Range.linear 1 10) Gen.bool

806

692

807− transaction do

693+ transaction \connection -> do

808− selected <- lift do

694+ selected <- liftIO $ Rel8.select connection do

809− statement () $ Rel8.select do

810− Rel8.many $ Rel8.values (map Rel8.lit rows)

695+ Rel8.many $ Rel8.values (map Rel8.lit rows)

811

696

812 selected === [foldMap pure rows]

697 selected === [foldMap pure rows]

813

698

814− selected' <- lift do

815− statement () $ Rel8.select do

699+ selected' <- liftIO $ Rel8.select connection $ do

816− a <- Rel8.catListTable =<< do

700+ a <- Rel8.catListTable =<< do

817− Rel8.many $ Rel8.values (map Rel8.lit rows)

701+ Rel8.many $ Rel8.values (map Rel8.lit rows)

818− b <- Rel8.catListTable =<< do

702+ b <- Rel8.catListTable =<< do

819− Rel8.many $ Rel8.values (map Rel8.lit rows)

703+ Rel8.many $ Rel8.values (map Rel8.lit rows)

820− pure (a, b)

704+ pure (a, b)

821

705

822 selected' === liftA2 (,) rows rows

706 selected' === liftA2 (,) rows rows

823

707

@@ -839,11 +723,10 @@ testNestedMaybeTable :: IO TmpPostgres.DB -> TestTree

839testNestedMaybeTable = databasePropertyTest "Can nest MaybeTable within other tables" \transaction -> do

723testNestedMaybeTable = databasePropertyTest "Can nest MaybeTable within other tables" \transaction -> do

840 let example = NestedMaybeTable { nmt1 = True, nmt2 = Just (TestTable "Hi" True) }

724 let example = NestedMaybeTable { nmt1 = True, nmt2 = Just (TestTable "Hi" True) }

841

725

842− transaction do

726+ transaction \connection -> do

843− selected <- lift do

844− statement () $ Rel8.select do

727+ selected <- liftIO $ Rel8.select connection do

845− x <- Rel8.values [Rel8.lit example]

728+ x <- Rel8.values [Rel8.lit example]

846− pure $ Rel8.maybeTable (Rel8.lit False) (\_ -> Rel8.lit True) (nmt2 x)

729+ pure $ Rel8.maybeTable (Rel8.lit False) (\_ -> Rel8.lit True) (nmt2 x)

847

730

848 selected === [True]

731 selected === [True]

849

732

@@ -851,12 +734,11 @@ testNestedMaybeTable = databasePropertyTest "Can nest MaybeTable within other ta

851testEvaluate :: IO TmpPostgres.DB -> TestTree

734testEvaluate :: IO TmpPostgres.DB -> TestTree

852testEvaluate = databasePropertyTest "evaluate has the evaluation order we expect" \transaction -> do

735testEvaluate = databasePropertyTest "evaluate has the evaluation order we expect" \transaction -> do

853

736

854− transaction do

737+ transaction \connection -> do

855− selected <- lift do

856− statement () $ Rel8.select do

738+ selected <- liftIO $ Rel8.select connection do

857− x <- Rel8.values (Rel8.lit <$> ['a', 'b', 'c'])

739+ x <- Rel8.values (Rel8.lit <$> ['a', 'b', 'c'])

858− y <- Rel8.evaluate (Rel8.nextval "test_seq")

740+ y <- Rel8.evaluate (Rel8.nextval "test_seq")

859− pure (x, (y, y))

741+ pure (x, (y, y))

860

742

861 normalize selected ===

743 normalize selected ===

862 [ ('a', (0, 0))

744 [ ('a', (0, 0))

@@ -864,12 +746,11 @@ testEvaluate = databasePropertyTest "evaluate has the evaluation order we expect

864 , ('c', (2, 2))

746 , ('c', (2, 2))

865 ]

747 ]

866

748

867− selected' <- lift do

868− statement () $ Rel8.select do

749+ selected' <- liftIO $ Rel8.select connection do

869− x <- Rel8.values (Rel8.lit <$> ['a', 'b', 'c'])

750+ x <- Rel8.values (Rel8.lit <$> ['a', 'b', 'c'])

870− y <- Rel8.values (Rel8.lit <$> ['d', 'e', 'f'])

751+ y <- Rel8.values (Rel8.lit <$> ['d', 'e', 'f'])

871− z <- Rel8.evaluate (Rel8.nextval "test_seq")

752+ z <- Rel8.evaluate (Rel8.nextval "test_seq")

872− pure ((x, y), (z, z))

753+ pure ((x, y), (z, z))

873

754

874 normalize selected' ===

755 normalize selected' ===

875 [ (('a', 'd'), (0, 0))

756 [ (('a', 'd'), (0, 0))

@@ -887,3 +768,13 @@ testEvaluate = databasePropertyTest "evaluate has the evaluation order we expect

887 normalize :: [(x, (Int64, Int64))] -> [(x, (Int64, Int64))]

768 normalize :: [(x, (Int64, Int64))] -> [(x, (Int64, Int64))]

888 normalize [] = []

769 normalize [] = []

889 normalize xs@((_, (i, _)) : _) = map (fmap (\(a, b) -> (a - i, b - i))) xs

770 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 @@

5{-# language DuplicateRecordFields #-}

6{-# language FlexibleInstances #-}

7{-# language MultiParamTypeClasses #-}

8−{-# language StandaloneKindSignatures #-}

9{-# language TypeFamilies #-}

8{-# language TypeFamilies #-}

10{-# language UndecidableInstances #-}

9{-# language UndecidableInstances #-}

11

10

@@ -172,17 +171,9 @@ data NestedTableTestB f = NestedTableTestB

172 deriving anyclass Rel8able

171 deriving anyclass Rel8able

173

172

174

173

174+

175newtype IdRecord a f = IdRecord { recordId :: Column f a }

176 deriving stock Generic

177

178

179instance 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