40994a7..master · 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@v12

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

13 with:

14 nix_path: nixpkgs=channel:nixos-unstable

15 extra_nix_config: |

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

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

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

18

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

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

20 with:

21 name: rel8

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

Changelog.md+84−2

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

1−# Unreleased

1+# 1.4.0.0 (2002-08-17)

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+

3− New `$*` and `$+` operators for projecting out of `ListTable` and `NonEmptyTable` respectively (analogous to the existing `$?` for `MaybeTable`).

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

4

86

5# 1.1.0.0 (2021-07-16)

87# 1.1.0.0 (2021-07-16)

6

88

cabal.project−5

@@ -1,6 +1 @@

1packages: .

2−

3−allow-newer: generic-monoid:base

4−allow-newer: cryptohash-sha1:base

5−allow-newer: cryptohash-md5:base

6−allow-newer: entropy:Cabal

cabal.project.haskell-nix−6

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

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

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

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

5−

6−source-repository-package

7− type: git

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

9− tag: f99b05454874192e3511bd133555dfb6cc6a6ecb

10− --sha256: 0yy2i2jbllwavv5d2176rf8lmm4l1ws90lxkmdlfgvfzqxidx0gi

default.nix+2−2

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

1let

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

3

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

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

5

6 nixpkgsArgs = haskellNix.nixpkgsArgs;

7

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

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

9

10 pkgs = import nixpkgsSrc nixpkgsArgs;

11

docs/cookbook.rst+9−7

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

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

143posts. We want our query to return:

144

145−1. The latest 5 blog posts.

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

1462. For each blog post, all tags.

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

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

148

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

150

151 latestBlogPosts = do

152 post <- each postSchema

153

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

154− tags <- aggregate do

155+ tags <- some $ do

155 tag <- each tagSchema

156 tag <- each tagSchema

156 where_ (tagPostId tag ==. postId post)

157 where_ (tagPostId tag ==. postId post)

157− return (listAgg (tagName tag))

158+ return (tagName tag)

158

159

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

159− latestComments <-

161+ latestComments <-

160− many $

162+ many $

161− limit 3 $

163+ limit 3 $

162 orderBy (commentCreatedAt >$< desc) do

164 orderBy (commentCreatedAt >$< desc) do

163 comment <- each commentSchema

165 comment <- each commentSchema

164 where_ (commentPostId comment ==. postId post)

166 where_ (commentPostId comment ==. postId post)

nix/sources.json+9−9

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

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

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

7 "repo": "haskell.nix",

8− "rev": "3856d2d24dca0ecc71fcfc314253a2a2d07a3c4f",

8+ "rev": "0837156c56cb5350dd9bd84eb424187e00aa1e8a",

9− "sha256": "0s69nasqhkv8n0qmdv075k83p3z584ja9vkzdnp2291mymghvx87",

9+ "sha256": "1djmv5a0vfj78csw2cad6nicrs8iqrp928b9b3v4h7lwwhhzliwl",

10 "type": "tarball",

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

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

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

13 },

14 "niv": {

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

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

18 "owner": "nmattia",

19 "repo": "niv",

20− "rev": "e0ca65c81a2d7a4d82a189f1e23a48d59ad42070",

20+ "rev": "acdb1726783637852c01e0ad639ac9cbec28d8c8",

21− "sha256": "1pq9nh1d8nn3xvbdny8fafzw87mj7gsmp6pxkdl65w2g18rmcmzx",

21+ "sha256": "1wszl8q70z6wfgkh2dvgmhhry6qp9nar421qq2ifd17hq2jj9ck3",

22 "type": "tarball",

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

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

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

25 },

26 "nixpkgs": {

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

29 "homepage": null,

30 "owner": "nixos",

31 "repo": "nixpkgs",

32− "rev": "59b8d9cf24e9fcf10341a0923c9bdca088dca8c8",

32+ "rev": "1c1f5649bb9c1b0d98637c8c365228f57126f361",

33− "sha256": "08f38v4b2kcxnbapdwrb54bglka92cxj9qlnqlk5px206jyq9v4c",

33+ "sha256": "0f2nvdijyxfgl5kwyb4465pppd5vkhqxddx6v40k2s0z9jfhj0xl",

34 "type": "tarball",

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

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

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

37 }

38}

nix/sources.nix+21−1

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

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

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

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

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

35+ submoduleArg =

36+ let

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

38+ emptyArgWithWarning =

39+ if submodules == true

40+ then

41+ builtins.trace

42+ (

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

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

45+ + "does not support them"

46+ )

47+ {}

48+ else {};

49+ in

50+ if nixSupportsSubmodules

51+ then { inherit submodules; }

52+ else emptyArgWithWarning;

34 in

53 in

54+ builtins.fetchGit

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

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

36

56

37 fetch_local = spec: spec.path;

57 fetch_local = spec: spec.path;

38

58

rel8.cabal+14−5

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

1cabal-version: 2.0

2name: rel8

3−version: 1.1.0.0

3+version: 1.4.0.0

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

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

24 , bifunctors

25 , bytestring

26 , case-insensitive

27 , comonad

28 , contravariant

29− , hasql ^>= 1.4.5.1

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

30− , opaleye ^>= 0.7.3.0

30+ , opaleye ^>= 0.9.6.1

31 , pretty

32 , profunctors

33 , product-profunctors

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

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

47 -Wno-monomorphism-restriction

48 -Wno-missing-local-signatures

49+ -Wno-missing-kind-signatures

49 hs-source-dirs:

50 hs-source-dirs:

50 src

51 src

51 exposed-modules:

52 exposed-modules:

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

65 Rel8.Column.List

66 Rel8.Column.List

66 Rel8.Column.Maybe

67 Rel8.Column.Maybe

67 Rel8.Column.NonEmpty

68 Rel8.Column.NonEmpty

69+ Rel8.Column.Null

68 Rel8.Column.These

70 Rel8.Column.These

69

71

70 Rel8.Expr

72 Rel8.Expr

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

80 Rel8.Expr.Order

82 Rel8.Expr.Order

81 Rel8.Expr.Sequence

83 Rel8.Expr.Sequence

82 Rel8.Expr.Serialize

84 Rel8.Expr.Serialize

85+ Rel8.Expr.Window

83

86

84 Rel8.FCF

87 Rel8.FCF

85

88

@@ -118,6 +121,7 @@ library

118 Rel8.Query.SQL

121 Rel8.Query.SQL

119 Rel8.Query.These

122 Rel8.Query.These

120 Rel8.Query.Values

123 Rel8.Query.Values

124+ Rel8.Query.Window

121

125

122 Rel8.Schema.Context.Nullify

126 Rel8.Schema.Context.Nullify

123 Rel8.Schema.Dict

127 Rel8.Schema.Dict

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

166 Rel8.Table.Maybe

170 Rel8.Table.Maybe

167 Rel8.Table.Name

171 Rel8.Table.Name

168 Rel8.Table.NonEmpty

172 Rel8.Table.NonEmpty

173+ Rel8.Table.Null

169 Rel8.Table.Nullify

174 Rel8.Table.Nullify

170 Rel8.Table.Opaleye

175 Rel8.Table.Opaleye

171 Rel8.Table.Ord

176 Rel8.Table.Ord

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

176 Rel8.Table.These

181 Rel8.Table.These

177 Rel8.Table.Transpose

182 Rel8.Table.Transpose

178 Rel8.Table.Undefined

183 Rel8.Table.Undefined

184+ Rel8.Table.Window

179

185

180 Rel8.Type

186 Rel8.Type

181 Rel8.Type.Array

187 Rel8.Type.Array

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

194 Rel8.Type.Sum

200 Rel8.Type.Sum

195 Rel8.Type.Tag

201 Rel8.Type.Tag

196

202

203+ Rel8.Window

204+

205+

197test-suite tests

206test-suite tests

198 type: exitcode-stdio-1.0

207 type: exitcode-stdio-1.0

199 build-depends:

208 build-depends:

@@ -203,7 +212,7 @@ test-suite tests

203 , containers

212 , containers

204 , hasql

213 , hasql

205 , hasql-transaction

214 , hasql-transaction

206− , hedgehog ^>=1.0.2

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

207 , mmorph

216 , mmorph

208 , rel8

217 , rel8

209 , scientific

218 , scientific

shell.nix+1−1

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

1let

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

3− pkgs = import sources.nixpkgs {};

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

4 hsPkgs = import ./default.nix;

5in

6 hsPkgs.shellFor {

src/Rel8.hs+270−6

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

38 , HMaybe

39 , HList

40 , HNonEmpty

41+ , HNull

41 , HThese

42 , HThese

42 , Lift

43 , Lift

43

44

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

46 , Transposes

47 , Transposes

47 , AltTable((<|>:))

48 , AltTable((<|>:))

48 , AlternativeTable( emptyTable )

49 , AlternativeTable( emptyTable )

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

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

50− , OrdTable, ascTable, descTable

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

51 , lit

52 , lit

52 , bool

53 , bool

53 , case_

54 , case_

55+ , castTable

54

56

55 -- ** @MaybeTable@

57 -- ** @MaybeTable@

56 , MaybeTable

58 , MaybeTable

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

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

58 , isNothingTable, isJustTable

60 , isNothingTable, isJustTable

61+ , fromMaybeTable

59 , optional

62 , optional

60 , catMaybeTable

63 , catMaybeTable

61 , traverseMaybeTable

64 , traverseMaybeTable

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

78 , isThisTable, isThatTable, isThoseTable

81 , isThisTable, isThatTable, isThoseTable

79 , hasHereTable, hasThereTable

82 , hasHereTable, hasThereTable

80 , justHereTable, justThereTable

83 , justHereTable, justThereTable

84+ , alignMaybeTable

81 , alignBy

85 , alignBy

82 , keepHereTable, loseHereTable

86 , keepHereTable, loseHereTable

83 , keepThereTable, loseThereTable

87 , keepThereTable, loseThereTable

@@ -106,14 +110,37 @@ module Rel8

106 , catNonEmptyTable

110 , catNonEmptyTable

107 , catNonEmpty

111 , catNonEmpty

108

112

109− -- ** @ADT@

113+ -- ** @NullTable@

114+ , NullTable

115+ , nullableTable, nullTable, nullifyTable

116+ , isNullTable, isNonNullTable

117+ , catNullTable

118+ , nameNullTable

119+ , toNullTable, toMaybeTable

120+

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

122+ -- $adts

123+

124+ -- *** Naming of ADTs

125+ -- $naming

126+ , NameADT, nameADT

110 , ADT, ADTable

127 , ADT, ADTable

128+

129+ -- *** Deconstruction of ADTs

130+ -- $deconstruction

131+ , DeconstructADT, deconstructADT

132+

133+ -- *** Construction of ADTs

134+ -- $construction

111 , BuildADT, buildADT

135 , BuildADT, buildADT

112 , ConstructADT, constructADT

136 , ConstructADT, constructADT

113− , DeconstructADT, deconstructADT

137+

114− , NameADT, nameADT

138+ -- *** Other ADT operations

115 , AggregateADT, aggregateADT

139 , AggregateADT, aggregateADT

116

140

141+ -- *** Miscellaneous notes

142+ -- $misc-notes

143+

117 -- ** @HKD@

144 -- ** @HKD@

118 , HKD, HKDable

145 , HKD, HKDable

119 , BuildHKD, buildHKD

146 , BuildHKD, buildHKD

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

138 -- ** @null@

165 -- ** @null@

139 , NotNull

166 , NotNull

140 , Nullable

167 , Nullable

168+ , Homonullable

141 , null

169 , null

142 , nullify

170 , nullify

143 , nullable

171 , nullable

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

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

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

157 , in_

185 , in_

158 , boolExpr, caseExpr

186 , boolExpr, caseExpr

187+ , like, ilike

159

188

160 -- ** Ordering

189 -- ** Ordering

161 , DBOrd

190 , DBOrd

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

224 , countRows

253 , countRows

225 , groupBy

254 , groupBy

226 , listAgg, listAggExpr

255 , listAgg, listAggExpr

256+ , mode

227 , nonEmptyAgg, nonEmptyAggExpr

257 , nonEmptyAgg, nonEmptyAggExpr

228 , DBMax, max

258 , DBMax, max

229 , DBMin, min

259 , DBMin, min

230− , DBSum, sum, sumWhere

260+ , DBSum, sum, sumWhere, avg

231 , DBString, stringAgg

261 , DBString, stringAgg

232 , count

262 , count

233 , countStar

263 , countStar

@@ -245,6 +275,26 @@ module Rel8

245 , nullsLast

275 , nullsLast

246

276

247 -- ** Window functions

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

248 , indexed

298 , indexed

249

299

250 -- ** Bindings

300 -- ** Bindings

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

284

334

285 -- ** @CREATE VIEW@

335 -- ** @CREATE VIEW@

286 , createView

336 , createView

337+ , createOrReplaceView

287

338

288 -- ** Sequences

339 -- ** Sequences

289 , nextval

340 , nextval

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

302import Rel8.Column.List

353import Rel8.Column.List

303import Rel8.Column.Maybe

354import Rel8.Column.Maybe

304import Rel8.Column.NonEmpty

355import Rel8.Column.NonEmpty

356+import Rel8.Column.Null

305import Rel8.Column.These

357import Rel8.Column.These

306import Rel8.Expr

358import Rel8.Expr

307import Rel8.Expr.Aggregate

359import Rel8.Expr.Aggregate

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

315import Rel8.Expr.Order

367import Rel8.Expr.Order

316import Rel8.Expr.Serialize

368import Rel8.Expr.Serialize

317import Rel8.Expr.Sequence

369import Rel8.Expr.Sequence

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

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

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

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

319import Rel8.Order

373import Rel8.Order

320import Rel8.Query

374import Rel8.Query

@@ -336,6 +390,7 @@ import Rel8.Query.SQL (showQuery)

336import Rel8.Query.Set

390import Rel8.Query.Set

337import Rel8.Query.These

391import Rel8.Query.These

338import Rel8.Query.Values

392import Rel8.Query.Values

393+import Rel8.Query.Window

339import Rel8.Schema.Field

394import Rel8.Schema.Field

340import Rel8.Schema.HTable

395import Rel8.Schema.HTable

341import Rel8.Schema.Name

396import Rel8.Schema.Name

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

362import Rel8.Table.Maybe

417import Rel8.Table.Maybe

363import Rel8.Table.Name

418import Rel8.Table.Name

364import Rel8.Table.NonEmpty

419import Rel8.Table.NonEmpty

420+import Rel8.Table.Null

421+import Rel8.Table.Opaleye ( castTable )

365import Rel8.Table.Ord

422import Rel8.Table.Ord

366import Rel8.Table.Order

423import Rel8.Table.Order

367import Rel8.Table.Projection

424import Rel8.Table.Projection

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

369import Rel8.Table.Serialize

426import Rel8.Table.Serialize

370import Rel8.Table.These

427import Rel8.Table.These

371import Rel8.Table.Transpose

428import Rel8.Table.Transpose

429+import Rel8.Table.Window

372import Rel8.Type

430import Rel8.Type

373import Rel8.Type.Composite

431import Rel8.Type.Composite

374import Rel8.Type.Eq

432import Rel8.Type.Eq

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

383import Rel8.Type.Semigroup

441import Rel8.Type.Semigroup

384import Rel8.Type.String

442import Rel8.Type.String

385import Rel8.Type.Sum

443import Rel8.Type.Sum

444+import Rel8.Window

386

445

387

446

388-- $running

447-- $running

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

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

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

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

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

392-- `DuplicateRecordFields` language extension enabled.

451-- `DuplicateRecordFields` language extension enabled.

452+

453+-- $adts

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

455+--

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

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

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

459+--

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

461+--

462+-- @

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

464+-- deriving stock Generic

465+--

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

467+-- deriving stock Generic

468+-- deriving anyclass Rel8able

469+--

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

471+-- deriving stock Generic

472+-- deriving anyclass Rel8able

473+-- @

474+

475+-- $naming

476+--

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

478+--

479+-- @

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

481+-- thingSchema =

482+-- TableSchema

483+-- { schema = Nothing,

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

485+-- columns =

486+-- nameADT @Thing

487+-- \"tag\"

488+-- Employer

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

490+-- employerId = \"id\"

491+-- }

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

493+-- }

494+-- @

495+--

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

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

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

499+

500+-- $deconstruction

501+--

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

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

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

505+--

506+-- @

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

508+-- query = do

509+-- thingExpr <- each thingSchema

510+-- where_ $

511+-- deconstructADT @Thing

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

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

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

515+-- thingExpr

516+-- pure thingExpr

517+-- @

518+--

519+-- SQL output:

520+--

521+-- @

522+-- SELECT

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

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

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

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

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

528+-- FROM (SELECT

529+-- *

530+-- FROM (SELECT

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

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

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

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

535+-- "Mary" as "Mary4_1"

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

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

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

539+-- @

540+

541+-- $construction

542+--

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

544+--

545+-- @

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

547+-- @

548+--

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

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

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

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

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

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

555+--

556+-- @

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

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

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

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

561+-- @

562+--

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

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

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

566+--

567+-- @

568+-- > :t lit . Complete

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

570+-- @

571+--

572+--

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

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

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

576+-- query.

577+--

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

579+--

580+-- @

581+-- > :{

582+-- showQuery $ values

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

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

585+-- ]

586+-- :}

587+-- @

588+--

589+-- This produces the following SQL:

590+--

591+-- @

592+-- SELECT

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

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

595+-- FROM (SELECT

596+-- *

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

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

599+-- FROM

600+-- (VALUES

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

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

603+-- @

604+--

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

606+--

607+--

608+-- @

609+-- tag | Complete/_1/date

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

611+-- Pending |

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

613+-- (2 rows)

614+-- @

615+--

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

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

618+-- to make sense:

619+--

620+-- @

621+-- > :t constructADT @Task

622+-- constructADT @Task

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

624+-- @

625+--

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

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

628+-- might use it as follows:

629+--

630+-- @

631+-- let

632+-- pending :: ADT Task Expr

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

634+--

635+-- complete :: ADT Task Expr

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

637+-- @

638+--

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

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

641+--

642+

643+-- $misc-notes

644+--

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

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

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

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

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

650+--

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

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

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

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

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

656+-- matching in PostgreSQL.

src/Rel8/Aggregate.hs+11−19

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

2{-# language FlexibleContexts #-}

3{-# language FlexibleInstances #-}

4{-# language MultiParamTypeClasses #-}

5−{-# language NamedFieldPuns #-}

6{-# language RankNTypes #-}

5{-# language RankNTypes #-}

7{-# language StandaloneKindSignatures #-}

6{-# language StandaloneKindSignatures #-}

8{-# language TypeFamilies #-}

7{-# language TypeFamilies #-}

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

10

9

11module Rel8.Aggregate

10module Rel8.Aggregate

12 ( Aggregate(..), zipOutputs

11 ( Aggregate(..), zipOutputs

13− , Aggregator(..), unsafeMakeAggregate

12+ , unsafeMakeAggregate

14 , Aggregates

13 , Aggregates

15 )

14 )

16where

15where

@@ -21,10 +20,13 @@ import Data.Functor.Identity ( Identity( Identity ) )

21import Data.Kind ( Constraint, Type )

20import Data.Kind ( Constraint, Type )

22import Prelude

21import Prelude

23

22

23+-- profunctors

24+import Data.Profunctor ( dimap )

25+

24-- opaleye

26-- opaleye

25−import qualified Opaleye.Internal.Aggregate as Opaleye

27+import qualified Opaleye.Aggregate as Opaleye

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

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

27−import qualified Opaleye.Internal.PackMap as Opaleye

29+import qualified Opaleye.Internal.Column as Opaleye

28

30

29-- rel8

31-- rel8

30import Rel8.Expr ( Expr )

32import Rel8.Expr ( Expr )

@@ -69,23 +71,13 @@ zipOutputs :: ()

69zipOutputs f (Aggregate a) (Aggregate b) = Aggregate (liftA2 f a b)

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

70

72

71

73

72−type Aggregator :: Type

73−data Aggregator = Aggregator

74− { operation :: Opaleye.AggrOp

75− , ordering :: [Opaleye.OrderExpr]

76− , distinction :: Opaleye.AggrDistinct

77− }

78−

79−

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

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

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

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

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

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

83− -> Maybe Aggregator

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

84 -> Expr input

78 -> Expr input

85 -> Aggregate output

79 -> Aggregate output

86unsafeMakeAggregate input output aggregator expr =

80unsafeMakeAggregate input output aggregator expr =

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

81+ Aggregate $ dimap in_ out aggregator

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

82+ where out = output . Opaleye.unColumn

89− where

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

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

91− (operation, ordering, distinction)

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

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

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

1{-# language DataKinds #-}

2{-# language DerivingStrategies #-}

3+{-# language FlexibleContexts #-}

3{-# language FlexibleInstances #-}

4{-# language FlexibleInstances #-}

4{-# language MultiParamTypeClasses #-}

5{-# language MultiParamTypeClasses #-}

5{-# language ScopedTypeVariables #-}

6{-# language ScopedTypeVariables #-}

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

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

10 , and, or

11 , min, max

12 , sum, sumWhere

13+ , avg

13 , stringAgg

14 , stringAgg

14 , groupByExpr

15 , groupByExpr

15 , listAggExpr, nonEmptyAggExpr

16 , listAggExpr, nonEmptyAggExpr

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

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

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

24

25

25-- opaleye

26-- opaleye

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

27+import qualified Opaleye.Internal.Aggregate as Opaleye

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

29+import qualified Opaleye.Aggregate as Opaleye

27

30

28-- rel8

31-- rel8

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

32+import Rel8.Aggregate ( Aggregate, unsafeMakeAggregate )

30import Rel8.Expr ( Expr )

33import Rel8.Expr ( Expr )

31import Rel8.Expr.Bool ( caseExpr )

34import Rel8.Expr.Bool ( caseExpr )

32import Rel8.Expr.Opaleye

35import Rel8.Expr.Opaleye

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

50

53

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

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

52count :: Expr a -> Aggregate Int64

55count :: Expr a -> Aggregate Int64

53−count = unsafeMakeAggregate toPrimExpr fromPrimExpr $

56+count = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.count

54− Just Aggregator

55− { operation = Opaleye.AggrCount

56− , ordering = []

57− , distinction = Opaleye.AggrAll

58− }

59−

60

57

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

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

62-- @COUNT(DISTINCT a)@

59-- @COUNT(DISTINCT a)@

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

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

64countDistinct = unsafeMakeAggregate toPrimExpr fromPrimExpr $

61countDistinct = unsafeMakeAggregate toPrimExpr fromPrimExpr $

65− Just Aggregator

62+ Opaleye.distinctAggregator Opaleye.count

66− { operation = Opaleye.AggrCount

67− , ordering = []

68− , distinction = Opaleye.AggrDistinct

69− }

70

63

71

64

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

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

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

81

74

82-- | Corresponds to @bool_and@.

75-- | Corresponds to @bool_and@.

83and :: Expr Bool -> Aggregate Bool

76and :: Expr Bool -> Aggregate Bool

84−and = unsafeMakeAggregate toPrimExpr fromPrimExpr $

77+and = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.boolAnd

85− Just Aggregator

86− { operation = Opaleye.AggrBoolAnd

87− , ordering = []

88− , distinction = Opaleye.AggrAll

89− }

90

78

91

79

92-- | Corresponds to @bool_or@.

80-- | Corresponds to @bool_or@.

93or :: Expr Bool -> Aggregate Bool

81or :: Expr Bool -> Aggregate Bool

94−or = unsafeMakeAggregate toPrimExpr fromPrimExpr $

82+or = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.boolOr

95− Just Aggregator

96− { operation = Opaleye.AggrBoolOr

97− , ordering = []

98− , distinction = Opaleye.AggrAll

99− }

100

83

101

84

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

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

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

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

104−max = unsafeMakeAggregate toPrimExpr fromPrimExpr $

87+max = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.unsafeMax

105− Just Aggregator

106− { operation = Opaleye.AggrMax

107− , ordering = []

108− , distinction = Opaleye.AggrAll

109− }

110

88

111

89

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

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

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

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

114−min = unsafeMakeAggregate toPrimExpr fromPrimExpr $

92+min = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.unsafeMin

115− Just Aggregator

116− { operation = Opaleye.AggrMin

117− , ordering = []

118− , distinction = Opaleye.AggrAll

119− }

120

93

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

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

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

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

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

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

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

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

125-- your input.

98-- your input.

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

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

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

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

128− Just Aggregator

101+

129− { operation = Opaleye.AggrSum

130− , ordering = []

131− , distinction = Opaleye.AggrAll

132− }

133

102

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

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

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

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

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

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

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

134

110

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

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

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

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

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

142stringAgg :: Sql DBString a

118stringAgg :: Sql DBString a

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

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

144stringAgg delimiter =

120stringAgg delimiter =

145− unsafeMakeAggregate toPrimExpr (castExpr . fromPrimExpr) $

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

146− Just Aggregator

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

148− , ordering = []

149− , distinction = Opaleye.AggrAll

150− }

151

122

152

123

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

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

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

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

155−groupByExpr = unsafeMakeAggregate toPrimExpr fromPrimExpr Nothing

126+groupByExpr = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.groupBy

156

127

157

128

158-- | Collect expressions values as a list.

129-- | Collect expressions values as a list.

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

167

138

168slistAggExpr :: ()

139slistAggExpr :: ()

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

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

170−slistAggExpr info = unsafeMakeAggregate to fromPrimExpr $ Just

141+slistAggExpr info = unsafeMakeAggregate to fromPrimExpr Opaleye.arrayAgg

171− Aggregator

172− { operation = Opaleye.AggrArr

173− , ordering = []

174− , distinction = Opaleye.AggrAll

175− }

176 where

142 where

177 to = encodeArrayElement info . toPrimExpr

143 to = encodeArrayElement info . toPrimExpr

178

144

179

145

180snonEmptyAggExpr :: ()

146snonEmptyAggExpr :: ()

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

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

182−snonEmptyAggExpr info = unsafeMakeAggregate to fromPrimExpr $ Just

148+snonEmptyAggExpr info = unsafeMakeAggregate to fromPrimExpr Opaleye.arrayAgg

183− Aggregator

184− { operation = Opaleye.AggrArr

185− , ordering = []

186− , distinction = Opaleye.AggrAll

187− }

188 where

149 where

189 to = encodeArrayElement info . toPrimExpr

150 to = encodeArrayElement info . toPrimExpr

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

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

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

5

6module Rel8.Expr.Num

7+ ( fromIntegral

8+ , realToFrac

9+ , div, mod, divMod

10+ , quot, rem, quotRem

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

11+ , ceiling, floor, round, truncate

8 )

12 )

9where

13where

10

14

11-- base

15-- base

12−import Prelude ()

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

13

17

14-- rel

18-- rel

15import Rel8.Expr ( Expr( Expr ) )

19import Rel8.Expr ( Expr( Expr ) )

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

16import Rel8.Expr.Function ( function )

21import Rel8.Expr.Function ( function )

17import Rel8.Expr.Opaleye ( castExpr )

22import Rel8.Expr.Opaleye ( castExpr )

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

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

24+import Rel8.Table.Bool ( bool )

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

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

20

26

21

27

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

42ceiling = function "ceiling"

48ceiling = function "ceiling"

43

49

44

50

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

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

52+-- PostgreSQL.

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

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

47−div = function "div"

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

48

55

49

56

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

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

58+-- PostgreSQL.

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

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

52−mod = function "mod"

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

61+

62+

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

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

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

66+ where

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

68+

69+

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

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

72+-- 'Prelude.div'.

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

74+quot = function "div"

75+

76+

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

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

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

80+rem = function "mod"

81+

82+

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

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

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

53

86

54

87

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

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

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

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

10 , scastExpr, sunsafeCastExpr

11 , unsafeLiteral

12 , fromPrimExpr, toPrimExpr, mapPrimExpr, zipPrimExprsWith, traversePrimExpr

13− , toColumn, fromColumn

13+ , toColumn, fromColumn, traverseFieldP

14 )

15where

16

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

30

33

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

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

32castExpr = scastExpr typeInformation

35castExpr = scastExpr typeInformation

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

80traversePrimExpr f = fmap fromPrimExpr . f . toPrimExpr

83traversePrimExpr f = fmap fromPrimExpr . f . toPrimExpr

81

84

82

85

86+traverseFieldP :: Profunctor p

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

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

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

90+

91+

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

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

84toColumn = Opaleye.Column

93toColumn = Opaleye.Column

85

94

86

95

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

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

88fromColumn (Opaleye.Column a) = a

97fromColumn (Opaleye.Column a) = a

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

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

11import Rel8.Expr ( Expr )

12import Rel8.Expr.Function ( function )

13import Rel8.Expr.Serialize ( litExpr )

14+import Rel8.Expr.Text ( quoteIdent )

14

15

15-- text

16-- text

16import Data.Text ( pack )

17import Data.Text ( pack )

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

18

19

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

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

20nextval :: String -> Expr Int64

21nextval :: String -> Expr Int64

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

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

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

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

17 , pgClientEncoding, quoteIdent, quoteLiteral, quoteNullable, regexpReplace

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

19 , splitPart, strpos, substr, translate

20+

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

22+ , like, ilike

20 )

23 )

21where

24where

22

25

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

24import Data.Bool ( Bool )

27import Data.Bool ( Bool )

25import Data.Int ( Int32 )

28import Data.Int ( Int32 )

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

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

27−import Prelude ()

30+import Prelude ( flip )

28

31

29-- bytestring

32-- bytestring

30import Data.ByteString ( ByteString )

33import Data.ByteString ( ByteString )

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

49

52

50

53

51-- | Matches regular expression, case sensitive

54-- | Matches regular expression, case sensitive

52−--

55+--

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

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

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

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

55(~.) = binaryOperator "~."

58(~.) = binaryOperator "~."

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

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

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

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

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

275translate = function "translate"

278translate = function "translate"

279+

280+

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

282+--

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

284+-- you can write expressions like

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

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

287+like = flip (binaryOperator "LIKE")

288+

289+

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

291+--

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

293+-- you can write expressions like

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

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

296+ilike = flip (binaryOperator "ILIKE")

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

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

1+module Rel8.Expr.Window

2+ ( cumulative

3+ , rowNumber

4+ , rank

5+ , denseRank

6+ , percentRank

7+ , cumeDist

8+ , ntile

9+ , lag

10+ , lead

11+ , firstValue

12+ , lastValue

13+ , nthValue

14+ )

15+where

16+

17+-- base

18+import Data.Int ( Int32, Int64 )

19+import Prelude

20+

21+-- opaleye

22+import qualified Opaleye.Internal.Aggregate as Opaleye

23+import qualified Opaleye.Internal.PackMap as Opaleye

24+import qualified Opaleye.Internal.Window as Opaleye

25+import qualified Opaleye.Window as Opaleye

26+

27+-- profunctors

28+import Data.Profunctor (dimap)

29+

30+-- rel8

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

32+import Rel8.Expr ( Expr )

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

34+import Rel8.Schema.Null ( Nullify )

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

36+

37+

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

39+cumulative f =

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

41+

42+

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

44+rowNumber :: Window a (Expr Int64)

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

46+

47+

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

49+rank :: Window a (Expr Int64)

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

51+

52+

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

54+denseRank :: Window a (Expr Int64)

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

56+

57+

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

59+percentRank :: Window a (Expr Double)

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

61+

62+

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

64+cumeDist :: Window a (Expr Double)

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

66+

67+

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

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

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

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

72+

73+

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

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

76+lag offset def =

77+ fromWindowFunction $

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

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

80+

81+

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

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

84+lead offset def =

85+ fromWindowFunction $

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

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

88+

89+

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

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

92+firstValue =

93+ fromWindowFunction $

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

95+ Opaleye.firstValue

96+

97+

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

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

100+lastValue =

101+ fromWindowFunction $

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

103+ Opaleye.lastValue

104+

105+

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

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

108+nthValue n =

109+ fromWindowFunction $

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

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

112+

113+

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

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

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

117+

118+

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

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

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

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

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

1{-# language AllowAmbiguousTypes #-}

2{-# language BlockArguments #-}

3{-# language DataKinds #-}

4+{-# language FlexibleContexts #-}

4{-# language FlexibleInstances #-}

5{-# language FlexibleInstances #-}

5{-# language MultiParamTypeClasses #-}

6{-# language MultiParamTypeClasses #-}

6{-# language RankNTypes #-}

7{-# language RankNTypes #-}

src/Rel8/Generic/Record.hs+2

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

1{-# language AllowAmbiguousTypes #-}

2{-# language DataKinds #-}

3+{-# language FlexibleContexts #-}

3{-# language FlexibleInstances #-}

4{-# language FlexibleInstances #-}

4{-# language MultiParamTypeClasses #-}

5{-# language MultiParamTypeClasses #-}

5{-# language PolyKinds #-}

6{-# language PolyKinds #-}

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

141 uncount = id

142 uncount = id

142

143

144

145+type Record :: Type -> Type

144newtype Record a = Record

146newtype Record a = Record

145 { unrecord :: a

147 { unrecord :: a

146 }

148 }

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

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

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

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

67 -- which occurs when we have polymorphic Rel8ables

72 -- which occurs when we have polymorphic Rel8ables

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

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

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

141-- [Supplying @Rel8able@ instances]

146-- [Supplying @Rel8able@ instances]

142--

147--

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

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

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

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

145-- extensions:

150-- extensions:

146--

151--

147-- @

152-- @

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

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

1{-# language AllowAmbiguousTypes #-}

2{-# language DataKinds #-}

3+{-# language FlexibleContexts #-}

3{-# language FlexibleInstances #-}

4{-# language FlexibleInstances #-}

4{-# language LambdaCase #-}

5{-# language LambdaCase #-}

5{-# language MultiParamTypeClasses #-}

6{-# language MultiParamTypeClasses #-}

src/Rel8/Order.hs+1−8

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

4

5module Rel8.Order

6 ( Order(..)

7− , toOrderExprs

8 )

7 )

9where

8where

10

9

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

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

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

18

17

19-- opaleye

18-- opaleye

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

19+import qualified Opaleye.Order as Opaleye

21−import qualified Opaleye.Internal.Order as Opaleye

22

20

23

21

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

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

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

30type Order :: Type -> Type

28type Order :: Type -> Type

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

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

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

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

33−

34−

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

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

37− uncurry Opaleye.OrderExpr <$> order a

src/Rel8/Query.hs+23−10

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

1+{-# language FlexibleContexts #-}

1{-# language StandaloneKindSignatures #-}

2{-# language StandaloneKindSignatures #-}

3+{-# language UndecidableInstances #-}

2

4

3module Rel8.Query

5module Rel8.Query

4 ( Query( Query )

6 ( Query( Query )

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

15-- opaleye

17-- opaleye

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

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

17import qualified Opaleye.Internal.PackMap as Opaleye

19import qualified Opaleye.Internal.PackMap as Opaleye

18−import qualified Opaleye.Internal.PrimQuery as Opaleye

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

19import qualified Opaleye.Internal.QueryArr as Opaleye

21import qualified Opaleye.Internal.QueryArr as Opaleye

20import qualified Opaleye.Internal.Tag as Opaleye

22import qualified Opaleye.Internal.Tag as Opaleye

21

23

22-- rel8

24-- rel8

25+import Rel8.Expr ( Expr )

23import Rel8.Query.Set ( unionAll )

26import Rel8.Query.Set ( unionAll )

24import Rel8.Query.Opaleye ( fromOpaleye )

27import Rel8.Query.Opaleye ( fromOpaleye )

25import Rel8.Query.Values ( values )

28import Rel8.Query.Values ( values )

26−import Rel8.Table ( fromColumns, toColumns )

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

27import Rel8.Table.Alternative

30import Rel8.Table.Alternative

28 ( AltTable, (<|>:)

31 ( AltTable, (<|>:)

29 , AlternativeTable, emptyTable

32 , AlternativeTable, emptyTable

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

175

178

176

179

177instance Monad Query where

180instance Monad Query where

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

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

179 let

182 let

180− Opaleye.QueryArr qa = q dummies

183+ qa = q dummies

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

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

182 Query q' = f a

185 Query q' = f a

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

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

184 ( dummy : dummies

187 ( dummy : dummies

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

188+ , query <> Opaleye.aRebind bindings

186 , Opaleye.next tag'

189 , Opaleye.next tag'

187 )

190 )

188 where

191 where

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

190 where

193 where

191 random = Opaleye.FunExpr "random" []

194 random = Opaleye.FunExpr "random" []

192 name = Opaleye.extractAttr "dummy" tag'

195 name = Opaleye.extractAttr "dummy" tag'

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

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

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

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

195 query'''

198 query'''

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

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

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

200+ | otherwise = query <> query''

198 m'' = m <> m'

201 m'' = m <> m'

199 in

202 in

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

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

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

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

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

209instance AlternativeTable Query where

212instance AlternativeTable Query where

210 emptyTable = values []

213 emptyTable = values []

214+

215+

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

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

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

219+

220+

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

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

223+ mempty = emptyTable

src/Rel8/Query/Aggregate.hs+19

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

1{-# language FlexibleContexts #-}

2{-# language MonoLocalBinds #-}

3+{-# language ScopedTypeVariables #-}

4+{-# language TypeApplications #-}

3

5

4module Rel8.Query.Aggregate

6module Rel8.Query.Aggregate

5 ( aggregate

7 ( aggregate

6 , countRows

8 , countRows

9+ , mode

7 )

10 )

8where

11where

9

12

10-- base

13-- base

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

11import Data.Int ( Int64 )

15import Data.Int ( Int64 )

12import Prelude

16import Prelude

13

17

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

18import Rel8.Aggregate ( Aggregates )

22import Rel8.Aggregate ( Aggregates )

19import Rel8.Expr ( Expr )

23import Rel8.Expr ( Expr )

20import Rel8.Expr.Aggregate ( countStar )

24import Rel8.Expr.Aggregate ( countStar )

25+import Rel8.Expr.Order ( desc )

21import Rel8.Query ( Query )

26import Rel8.Query ( Query )

27+import Rel8.Query.Limit ( limit )

22import Rel8.Query.Maybe ( optional )

28import Rel8.Query.Maybe ( optional )

23import Rel8.Query.Opaleye ( mapOpaleye )

29import Rel8.Query.Opaleye ( mapOpaleye )

30+import Rel8.Query.Order ( orderBy )

31+import Rel8.Table ( toColumns )

32+import Rel8.Table.Aggregate ( hgroupBy )

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

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

24import Rel8.Table.Opaleye ( aggregator )

35import Rel8.Table.Opaleye ( aggregator )

25import Rel8.Table.Maybe ( maybeTable )

36import Rel8.Table.Maybe ( maybeTable )

26

37

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

35-- will return @0@.

46-- will return @0@.

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

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

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

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

49+

50+

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

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

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

54+ aggregate $ do

55+ row <- toColumns <$> rows

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

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

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

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

2−

3module Rel8.Query.Distinct

1module Rel8.Query.Distinct

4 ( distinct

2 ( distinct

5 , distinctOn

3 , distinctOn

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

8where

6where

9

7

10-- base

8-- base

11−import Prelude

9+import Prelude ()

12

10

13-- opaleye

11-- opaleye

14import qualified Opaleye.Distinct as Opaleye

12import qualified Opaleye.Distinct as Opaleye

15−import qualified Opaleye.Internal.Order as Opaleye

13+import qualified Opaleye.Order as Opaleye

16−import qualified Opaleye.Internal.QueryArr as Opaleye

17

14

18-- rel8

15-- rel8

19import Rel8.Order ( Order( Order ) )

16import Rel8.Order ( Order( Order ) )

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

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

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

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

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

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

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

36−distinctOn proj =

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

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

38

34

39

35

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

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

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

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

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

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

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

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

44−distinctOnBy proj (Order order) =

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

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

src/Rel8/Query/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 hiding ( exists )

15+import qualified Opaleye.Operators as Opaleye

16

17-- rel8

18import Rel8.Expr ( Expr )

src/Rel8/Query/Indexed.hs+5−18

@@ -4,31 +4,18 @@ module Rel8.Query.Indexed

4where

5

6-- base

7+import Control.Applicative ( liftA2 )

7import Data.Int ( Int64 )

8import Data.Int ( Int64 )

8import Prelude

9import Prelude

9

10

10−-- opaleye

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

12−import qualified Opaleye.Internal.PackMap as Opaleye

13−import qualified Opaleye.Internal.PrimQuery as Opaleye

14−import qualified Opaleye.Internal.QueryArr as Opaleye

15−import qualified Opaleye.Internal.Tag as Opaleye

16−

17-- rel8

11-- rel8

18import Rel8.Expr ( Expr )

12import Rel8.Expr ( Expr )

19−import Rel8.Expr.Opaleye ( fromPrimExpr )

13+import Rel8.Expr.Window ( rowNumber )

20import Rel8.Query ( Query )

14import Rel8.Query ( Query )

21−import Rel8.Query.Opaleye ( mapOpaleye )

15+import Rel8.Query.Window ( window )

16+import Rel8.Table.Window ( currentRow )

22

17

23

18

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

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

25indexed :: Query a -> Query (Expr Int64, a)

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

26−indexed = mapOpaleye $ \(Opaleye.QueryArr f) -> Opaleye.QueryArr $ \(_, tag) ->

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

27− let

28− (a, query, tag') = f ((), tag)

29− tag'' = Opaleye.next tag'

30− window = Opaleye.ConstExpr $ Opaleye.OtherLit "ROW_NUMBER() OVER () - 1"

31− (index, bindings) = Opaleye.run $ Opaleye.extractAttr "index" tag' window

32− query' lateral = Opaleye.Rebind True bindings . query lateral

33− in

34− ((fromPrimExpr index, a), query', tag'')

src/Rel8/Query/Null.hs+15

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

1+{-# language FlexibleContexts #-}

2+

1module Rel8.Query.Null

3module Rel8.Query.Null

2 ( catNull

4 ( catNull

5+ , catNullTable

3 )

6 )

4where

7where

5

8

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

9-- rel8

12-- rel8

10import Rel8.Expr ( Expr )

13import Rel8.Expr ( Expr )

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

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

15+import Rel8.Table ( Table )

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

12import Rel8.Query ( Query )

17import Rel8.Query ( Query )

13import Rel8.Query.Filter ( where_ )

18import Rel8.Query.Filter ( where_ )

14

19

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

21catNull a = do

26catNull a = do

22 where_ $ isNonNull a

27 where_ $ isNonNull a

23 pure $ unsafeUnnullify a

28 pure $ unsafeUnnullify a

29+

30+

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

32+-- @nullTable@s.

33+--

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

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

36+catNullTable a = do

37+ where_ $ isNonNullTable a

38+ pure $ unsafeUnnullifyTable a

src/Rel8/Query/Opaleye.hs+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− Opaleye.QueryArr f -> case f ((), Opaleye.start) of

44+ f -> case Opaleye.runStateQueryArr 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.QueryArr qa) = Opaleye.QueryArr $ \(_, tag) ->

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

52 let

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

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

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

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

55 in

56− qa' ((), tag)

56+ Opaleye.runStateQueryArr q' () 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@(Opaleye.QueryArr qa) q'@(Opaleye.QueryArr qa') =

62+zipping f q q' =

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

63+ Opaleye.stateQueryArr $ \_ tag ->

64 let

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

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

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

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

67 m'' = m <> m'

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

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

69 in

70− qa'' ((), tag)

70+ Opaleye.runStateQueryArr q'' () tag

src/Rel8/Query/Rebind.hs+5−13

@@ -7,29 +7,21 @@ where

7

8-- base

9import Prelude

10+import Control.Arrow ((<<<))

10

11

11-- opaleye

12-- opaleye

12−import qualified Opaleye.Internal.PackMap as Opaleye

13+import qualified Opaleye.Internal.Rebind as Opaleye

13−import qualified Opaleye.Internal.PrimQuery as Opaleye

14−import qualified Opaleye.Internal.QueryArr as Opaleye

15−import qualified Opaleye.Internal.Tag as Opaleye

16−import qualified Opaleye.Internal.Unpackspec as Opaleye

17

14

18-- rel8

15-- rel8

19import Rel8.Expr ( Expr )

16import Rel8.Expr ( Expr )

20−import Rel8.Query ( Query( Query ) )

17+import Rel8.Query ( Query )

21import Rel8.Table ( Table )

18import Rel8.Table ( Table )

22import Rel8.Table.Opaleye ( unpackspec )

19import Rel8.Table.Opaleye ( unpackspec )

20+import Rel8.Query.Opaleye (fromOpaleye)

23

21

24

22

25-- | 'rebind' takes a variable name, some expressions, and binds each of them

23-- | 'rebind' takes a variable name, some expressions, and binds each of them

26-- to a new variable in the SQL. The @a@ returned consists only of these

24-- to a new variable in the SQL. The @a@ returned consists only of these

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

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

28rebind :: Table Expr a => String -> a -> Query a

26rebind :: Table Expr a => String -> a -> Query a

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

27+rebind prefix a = fromOpaleye (Opaleye.rebindExplicitPrefix prefix unpackspec <<< pure a)

30− let

31− tag' = Opaleye.next tag

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

33− Opaleye.runUnpackspec unpackspec (Opaleye.extractAttr prefix tag) a

34− in

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

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 @x UNION b@.

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

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

28union = zipOpaleyeWith (Opaleye.unionExplicit binaryspec)

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 @x UNION ALL b@.

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

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

34unionAll = zipOpaleyeWith (Opaleye.unionAllExplicit binaryspec)

35

36

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

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

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

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

40intersect = zipOpaleyeWith (Opaleye.intersectExplicit binaryspec)

41

42

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

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

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

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

46intersectAll = zipOpaleyeWith (Opaleye.intersectAllExplicit binaryspec)

47

48

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

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

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

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

52except = zipOpaleyeWith (Opaleye.exceptExplicit binaryspec)

53

54

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

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

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

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

58exceptAll = zipOpaleyeWith (Opaleye.exceptAllExplicit binaryspec)

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

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

48alignBy :: ()

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

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

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

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

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

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

53 where

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

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

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

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

56 MaybeTable hasHere a = ma

57 MaybeTable hasThere b = mb

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

@@ -60,15 +60,15 @@ alignBy condition = zipOpaleyeWith $ \left right -> Opaleye.QueryArr $ \i -> cas

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

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

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

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

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

64 where

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

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

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

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

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

68 ma' = MaybeTable hasHere' a

69 mb' = MaybeTable hasThere' b

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

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

71+ join' = Opaleye.aProduct join

72

73

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

src/Rel8/Query/Window.hsnew file+26

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

1+module Rel8.Query.Window

2+ ( window

3+ )

4+where

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/HTable.hs+29−2

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

16module Rel8.Schema.HTable

17 ( HTable (HField, HConstrainTable)

18 , hfield, htabulate, htraverse, hdicts, hspecs

19− , hmap, htabulateA

19+ , hfoldMap, hmap, htabulateA, htraverseP, htraversePWithField

20 )

21where

22

23-- base

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

24import Data.Kind ( Constraint, Type )

25import Data.Kind ( Constraint, Type )

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

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

26import Data.Proxy ( Proxy )

27import Data.Proxy ( Proxy )

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

32 )

33 )

33import Prelude

34import Prelude

34

35

36+-- profunctors

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

38+

39+-- product-profunctors

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

41+

35-- rel8

42-- rel8

36import Rel8.Schema.Dict ( Dict )

43import Rel8.Schema.Dict ( Dict )

37import Rel8.Schema.Spec ( Spec )

44import Rel8.Schema.Spec ( Spec )

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

41-- semigroupoids

48-- semigroupoids

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

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

43

50

44−

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

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

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

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

47-- specified ('hspecs').

53-- specified ('hspecs').

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

114 {-# INLINABLE hspecs #-}

120 {-# INLINABLE hspecs #-}

115

121

116

122

123+hfoldMap :: (HTable t, Semigroup s)

124+ => (forall a. context a -> s) -> t context -> s

125+hfoldMap f a = getConst $ htraverse (Const . f) a

126+

127+

117hmap :: HTable t

128hmap :: HTable t

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

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

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

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

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

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

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

125{-# INLINABLE htabulateA #-}

136{-# INLINABLE htabulateA #-}

126

137

138+newtype ApplyP p a b = ApplyP { unApplyP :: p a b }

139+

140+instance Profunctor p => Functor (ApplyP p a) where

141+ fmap f = ApplyP . rmap f . unApplyP

142+

143+instance ProductProfunctor p => Apply (ApplyP p a) where

144+ ApplyP f <.> ApplyP x = ApplyP (rmap id f **** x)

145+

146+htraverseP :: (HTable t, ProductProfunctor p)

147+ => (forall a. p (f a) (g a)) -> p (t f) (t g)

148+htraverseP f = htraversePWithField (const f)

149+

150+htraversePWithField :: (HTable t, ProductProfunctor p)

151+ => (forall a. HField t a -> p (f a) (g a)) -> p (t f) (t g)

152+htraversePWithField f = unApplyP $ htabulateA $ \field -> ApplyP $

153+ lmap (flip hfield field) (f field)

127

154

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

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

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

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

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

@@ -27,7 +27,7 @@ module Rel8.Schema.HTable.Vectorize

27where

28

29-- base

30−import Data.Kind ( Type )

30+import Data.Kind ( Constraint, Type )

31import Data.List.NonEmpty ( NonEmpty )

32import GHC.Generics (Generic)

33import Prelude

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

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

54

55

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

56class Vector list where

57class Vector list where

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

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

58 vectorTypeInformation :: ()

59 vectorTypeInformation :: ()

src/Rel8/Schema/Table.hs+3

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

2{-# language DerivingStrategies #-}

3{-# language DisambiguateRecordFields #-}

4{-# language NamedFieldPuns #-}

5+{-# language StandaloneKindSignatures #-}

5

6

6module Rel8.Schema.Table

7module Rel8.Schema.Table

7 ( TableSchema(..)

8 ( TableSchema(..)

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

10where

11where

11

12

12-- base

13-- base

14+import Data.Kind ( Type )

13import Prelude

15import Prelude

14

16

15-- opaleye

17-- opaleye

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

26--

28--

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

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

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

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

31+type TableSchema :: Type -> Type

29data TableSchema names = TableSchema

32data TableSchema names = TableSchema

30 { name :: String

33 { name :: String

31 -- ^ The name of the table.

34 -- ^ The name of the table.

src/Rel8/Statement/Select.hs+5−3

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

3{-# language FlexibleContexts #-}

4{-# language MonoLocalBinds #-}

5{-# language ScopedTypeVariables #-}

6+{-# language StandaloneKindSignatures #-}

6{-# language TypeApplications #-}

7{-# language TypeApplications #-}

7

8

8module Rel8.Statement.Select

9module Rel8.Statement.Select

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

17

18

18-- base

19-- base

19import Data.Foldable ( toList )

20import Data.Foldable ( toList )

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

21+import Data.Kind ( Type )

21import Data.Void ( Void )

22import Data.Void ( Void )

22import Prelude hiding ( undefined )

23import Prelude hiding ( undefined )

23

24

@@ -90,7 +91,7 @@ ppSelect query =

90ppRows :: Table Expr a => Query a -> Doc

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

91ppRows query = case optimize primQuery of

92ppRows query = case optimize primQuery of

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

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

93− Optimized (Opaleye.Product ((_, Opaleye.Values symbols rows) :| []) [])

94+ Optimized (Opaleye.Values symbols rows)

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

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

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

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

96 _ -> ppSelect query

97 _ -> ppSelect query

@@ -116,8 +117,9 @@ ppPrimSelect query =

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

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

117

118

119

120+type Optimized :: Type -> Type

119data Optimized a = Empty | Unit | Optimized a

121data Optimized a = Empty | Unit | Optimized a

120− deriving stock (Functor, Foldable, Traversable)

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

121

123

122

124

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

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

src/Rel8/Statement/View.hs+30−5

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

3

4module Rel8.Statement.View

5 ( createView

6+ , createOrReplaceView

6 )

7 )

7where

8where

8

9

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

29import Data.Text.Encoding ( encodeUtf8 )

30import Data.Text.Encoding ( encodeUtf8 )

30

31

32

33+data CreateView = Create | CreateOrReplace

34+

35+

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

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

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

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

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

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

35createView :: Selects names exprs

39createView :: Selects names exprs

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

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

41+createView =

42+ createViewGeneric Create

43+

44+

45+-- | Given a 'TableSchema' and 'Query', @createOrReplaceView@ runs a

46+-- @CREATE OR REPLACE VIEW@ statement that will save the given query

47+-- as a view, replacing the current view definition if it exists and

48+-- adheres to the restrictions in place for replacing a view in

49+-- PostgreSQL.

50+createOrReplaceView :: Selects names exprs

51+ => TableSchema names -> Query exprs -> Hasql.Statement () ()

52+createOrReplaceView =

53+ createViewGeneric CreateOrReplace

54+

55+

56+createViewGeneric :: Selects names exprs

57+ => CreateView -> TableSchema names -> Query exprs -> Hasql.Statement () ()

58+createViewGeneric replace schema query =

37−createView schema query = Hasql.Statement bytes params decode prepare

59+ Hasql.Statement bytes params decode prepare

38 where

60 where

39 bytes = encodeUtf8 (Text.pack sql)

61 bytes = encodeUtf8 (Text.pack sql)

40 params = Hasql.noParams

62 params = Hasql.noParams

41 decode = Hasql.noResult

63 decode = Hasql.noResult

42 prepare = False

64 prepare = False

43 sql = show doc

65 sql = show doc

44− doc = ppCreateView schema query

66+ doc = ppCreateView schema query replace

45

67

46

68

47ppCreateView :: Selects names exprs

69ppCreateView :: Selects names exprs

48− => TableSchema names -> Query exprs -> Doc

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

49−ppCreateView schema query =

71+ppCreateView schema query replace =

50− text "CREATE VIEW" <+>

72+ createOrReplace replace <+>

51 ppInto schema $$

73 ppInto schema $$

52 text "AS" <+>

74 text "AS" <+>

53 ppSelect query

75 ppSelect query

76+ where

77+ createOrReplace Create = text "CREATE VIEW"

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

src/Rel8/Table/Aggregate.hs+12

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

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

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

41 => exprs -> aggregates

53 => exprs -> aggregates

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

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

src/Rel8/Table/HKD.hs+1

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

157 => HKDable a

158

159

160+type Top_ :: Constraint

160class Top_

161class Top_

161instance Top_

162instance Top_

162

163

src/Rel8/Table/Maybe.hs+6

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

15 ( MaybeTable(..)

16 , maybeTable, nothingTable, justTable

17 , isNothingTable, isJustTable

18+ , fromMaybeTable

18 , ($?)

19 , ($?)

19 , aggregateMaybeTable

20 , aggregateMaybeTable

20 , nameMaybeTable

21 , nameMaybeTable

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

206justTable = MaybeTable mempty . pure

207justTable = MaybeTable mempty . pure

207

208

209

210+-- | 'Data.Maybe.fromMaybe' for 'MaybeTable's.

211+fromMaybeTable :: Table Expr a => a -> MaybeTable Expr a -> a

212+fromMaybeTable fallback = maybeTable fallback id

213+

214+

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

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

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

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

211-- @null@.

217-- @null@.

src/Rel8/Table/Null.hsnew file+147

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

1+{-# language DataKinds #-}

2+{-# language FlexibleContexts #-}

3+{-# language FlexibleInstances #-}

4+{-# language MultiParamTypeClasses #-}

5+{-# language ScopedTypeVariables #-}

6+{-# language StandaloneKindSignatures #-}

7+{-# language TypeApplications #-}

8+{-# language TypeFamilies #-}

9+{-# language UndecidableInstances #-}

10+

11+module Rel8.Table.Null

12+ ( NullTable(..)

13+ , nullableTable, nullTable, nullifyTable, unsafeUnnullifyTable

14+ , isNullTable, isNonNullTable

15+ , nameNullTable

16+ , toMaybeTable, toNullTable

17+ )

18+where

19+

20+-- base

21+import Data.Kind ( Type )

22+import Prelude hiding ( null, undefined )

23+

24+-- comonad

25+import Control.Comonad ( extract )

26+

27+-- rel8

28+import Rel8.Expr ( Expr )

29+import Rel8.Expr.Bool ( not_ )

30+import Rel8.Kind.Context ( Reifiable )

31+import qualified Rel8.Schema.Kind as K

32+import Rel8.Schema.Name ( Name )

33+import Rel8.Table

34+ ( Table, Columns, Context, fromColumns, toColumns

35+ , FromExprs, fromResult, toResult

36+ , Transpose

37+ )

38+import Rel8.Table.Alternative

39+ ( AltTable, (<|>:)

40+ , AlternativeTable, emptyTable

41+ )

42+import Rel8.Table.Bool ( bool )

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

44+import Rel8.Table.Maybe ( MaybeTable, justTable, maybeTable, nothingTable )

45+import Rel8.Table.Nullify ( Nullify, isNull )

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

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

48+import Rel8.Table.Serialize ( ToExprs )

49+import Rel8.Table.Undefined ( undefined )

50+

51+

52+-- | @NullTable t@ is the table @t@, but where all the columns in @t@ have the

53+-- possibility of being 'Rel8.null'. This is very similar to

54+-- 'Rel8.MaybeTable', except that it does not use an extra tag field, so it

55+-- cannot distinguish between @Nothing@ and @Just Nothing@ if nested. In other

56+-- words, if all of the columns of the @t@ passed to @NullTable@ are already

57+-- nullable, then @NullTable@ has no effect.

58+type NullTable :: K.Context -> Type -> Type

59+newtype NullTable context a = NullTable (Nullify context a)

60+

61+

62+instance Projectable (NullTable context) where

63+ project f (NullTable a) = NullTable (project f a)

64+

65+

66+instance context ~ Expr => AltTable (NullTable context) where

67+ ma <|>: mb = bool ma mb (isNullTable ma)

68+

69+

70+instance context ~ Expr => AlternativeTable (NullTable context) where

71+ emptyTable = nullTable

72+

73+

74+instance (Table context a, Reifiable context, context ~ context') =>

75+ Table context' (NullTable context a)

76+ where

77+ type Columns (NullTable context a) = Columns (Nullify context a)

78+ type Context (NullTable context a) = Context (Nullify context a)

79+ type FromExprs (NullTable context a) = FromExprs (Nullify context a)

80+ type Transpose to (NullTable context a) = NullTable to (Transpose to a)

81+

82+ toColumns (NullTable a) = toColumns a

83+ fromColumns = NullTable . fromColumns

84+

85+ toResult = toResult @_ @(Nullify context a)

86+ fromResult = fromResult @_ @(Nullify context a)

87+

88+

89+instance (EqTable a, context ~ Expr) => EqTable (NullTable context a) where

90+ eqTable = eqTable @(Nullify context a)

91+

92+

93+instance (OrdTable a, context ~ Expr) => OrdTable (NullTable context a) where

94+ ordTable = ordTable @(Nullify context a)

95+

96+

97+instance (ToExprs exprs a, context ~ Expr) =>

98+ ToExprs (NullTable context exprs) (Maybe a)

99+

100+

101+-- | Check if any of the non-nullable fields of @a@ are 'Rel8.null' under the

102+-- 'NullTable'. Returns 'Rel8.false' if @a@ has no non-nullable fields.

103+isNullTable :: Table Expr a => NullTable Expr a -> Expr Bool

104+isNullTable (NullTable a) = isNull a

105+

106+

107+-- | The inverse of 'isNullTable'.

108+isNonNullTable :: Table Expr a => NullTable Expr a -> Expr Bool

109+isNonNullTable = not_ . isNullTable

110+

111+

112+-- | Like 'Rel8.nullable'.

113+nullableTable :: (Table Expr a, Table Expr b)

114+ => b -> (a -> b) -> NullTable Expr a -> b

115+nullableTable b f ma@(NullTable a) = bool (f (extract a)) b (isNullTable ma)

116+

117+

118+-- | The null table. Like 'Rel8.null'.

119+nullTable :: Table Expr a => NullTable Expr a

120+nullTable = NullTable (pure undefined)

121+

122+

123+-- | Lift any table into 'NullTable'. Like 'Rel8.nullify'.

124+nullifyTable :: a -> NullTable Expr a

125+nullifyTable = NullTable . pure

126+

127+

128+unsafeUnnullifyTable :: NullTable Expr a -> a

129+unsafeUnnullifyTable (NullTable a) = extract a

130+

131+

132+-- | Construct a 'NullTable' in the 'Name' context. This can be useful if you

133+-- have a 'NullTable' that you are storing in a table and need to construct a

134+-- 'TableSchema'.

135+nameNullTable :: a -> NullTable Name a

136+nameNullTable = NullTable . pure

137+

138+

139+-- | Convert a 'NullTable' to a 'MaybeTable'.

140+toMaybeTable :: Table Expr a => NullTable Expr a -> MaybeTable Expr a

141+toMaybeTable = nullableTable nothingTable justTable

142+

143+

144+-- | Convert a 'MaybeTable' to a 'NullTable'. Note that if the underlying @a@

145+-- has no non-nullable fields, this is a lossy conversion.

146+toNullTable :: Table Expr a => MaybeTable Expr a -> NullTable Expr a

147+toNullTable = maybeTable nullTable nullifyTable

src/Rel8/Table/Nullify.hs+27

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

1{-# language DataKinds #-}

2+{-# language FlexibleContexts #-}

2{-# language FlexibleInstances #-}

3{-# language FlexibleInstances #-}

3{-# language LambdaCase #-}

4{-# language LambdaCase #-}

4{-# language MultiParamTypeClasses #-}

5{-# language MultiParamTypeClasses #-}

6+{-# language NamedFieldPuns #-}

5{-# language ScopedTypeVariables #-}

7{-# language ScopedTypeVariables #-}

6{-# language StandaloneKindSignatures #-}

8{-# language StandaloneKindSignatures #-}

7{-# language TypeApplications #-}

9{-# language TypeApplications #-}

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

12 ( Nullify

14 ( Nullify

13 , aggregateNullify

15 , aggregateNullify

14 , guard

16 , guard

17+ , isNull

15 )

18 )

16where

19where

17

20

18-- base

21-- base

19import Control.Applicative ( liftA2 )

22import Control.Applicative ( liftA2 )

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

20import Data.Functor.Identity ( runIdentity )

24import Data.Functor.Identity ( runIdentity )

21import Data.Kind ( Type )

25import Data.Kind ( Type )

22import Prelude

26import Prelude

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

27-- rel8

31-- rel8

28import Rel8.Aggregate ( Aggregate )

32import Rel8.Aggregate ( Aggregate )

29import Rel8.Expr ( Expr )

33import Rel8.Expr ( Expr )

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

35+import qualified Rel8.Expr.Null as Expr

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

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

31import Rel8.Schema.Context.Nullify

37import Rel8.Schema.Context.Nullify

32 ( Nullifiability( NAggregate, NExpr )

38 ( Nullifiability( NAggregate, NExpr )

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

45 , hproject

51 , hproject

46 )

52 )

47import qualified Rel8.Schema.Kind as K

53import qualified Rel8.Schema.Kind as K

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

48import qualified Rel8.Schema.Result as R

55import qualified Rel8.Schema.Result as R

49import Rel8.Table

56import Rel8.Table

50 ( Table, Columns, Context, toColumns, fromColumns

57 ( Table, Columns, Context, toColumns, fromColumns

51 , FromExprs, fromResult, toResult

58 , FromExprs, fromResult, toResult

52 , Transpose

59 , Transpose

53 )

60 )

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

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

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

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

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

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

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

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

182 -> HNullify t context

190 -> HNullify t context

183guard tag isNonNull isNonNullExpr =

191guard tag isNonNull isNonNullExpr =

184 hguard (guarder contextSing tag isNonNull isNonNullExpr)

192 hguard (guarder contextSing tag isNonNull isNonNullExpr)

193+

194+

195+isNull :: forall a. Table Expr a => Nullify Expr a -> Expr Bool

196+isNull =

197+ maybe false getAny .

198+ getConst .

199+ hunnullify (\Spec {nullity} a -> Const $ case nullity of

200+ NotNull -> Just $ Any $ Expr.isNull a

201+ Null -> Nothing) .

202+ toColumns

203+

204+

205+newtype Any = Any

206+ { getAny :: Expr Bool

207+ }

208+

209+

210+instance Semigroup Any where

211+ Any a <> Any b = Any (a ||. b)

src/Rel8/Table/Opaleye.hs+31−47

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

7{-# language TypeFamilies #-}

8{-# language ViewPatterns #-}

9

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

11+

10module Rel8.Table.Opaleye

12module Rel8.Table.Opaleye

11 ( aggregator

13 ( aggregator

12 , attributes

14 , attributes

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

26-- base

28-- base

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

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

28import Data.List.NonEmpty ( NonEmpty )

30import Data.List.NonEmpty ( NonEmpty )

29−import Prelude hiding ( undefined )

31+import Prelude

30

32

31-- opaleye

33-- opaleye

34+import qualified Opaleye.Adaptors as Opaleye

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

32import qualified Opaleye.Internal.Aggregate as Opaleye

36import qualified Opaleye.Internal.Aggregate as Opaleye

33−import qualified Opaleye.Internal.Binary as Opaleye

34−import qualified Opaleye.Internal.Distinct as Opaleye

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

37import 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.Internal.Table as Opaleye

39+import qualified Opaleye.Table as Opaleye

40

41-- profunctors

42import Data.Profunctor ( dimap, lmap )

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

46import Rel8.Expr ( Expr )

47import Rel8.Expr.Opaleye

48 ( fromPrimExpr, toPrimExpr

49− , traversePrimExpr

50− , fromColumn, toColumn

51− , scastExpr

49+ , scastExpr, traverseFieldP

52 )

50 )

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

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

52+ htraverseP, htraversePWithField )

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

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

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

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

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

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

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

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

58−import Rel8.Table.Undefined ( undefined )

57+import Rel8.Type.Information ( typeName )

59

58

60-- semigroupoids

59-- semigroupoids

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

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

61+import Data.Profunctor.Product ( ProductProfunctor )

62

63

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

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

65+aggregator = dimap toColumns fromColumns $

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

66+ htraverseP $

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

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

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

69− inner f ()

70

68

71

69

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

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

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

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

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

78

76

79

77

78+fromOpaleyespec :: (ProductProfunctor p, Table Expr a)

79+ => p (Opaleye.Field_ n x) (Opaleye.Field_ n x)

80+ -> p a a

81+fromOpaleyespec x =

82+ dimap toColumns fromColumns (htraverseP (traverseFieldP x))

83+

84+

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

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

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

86+binaryspec = fromOpaleyespec Opaleye.binaryspecField

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)

86

87

88

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

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

89−distinctspec =

90+distinctspec = fromOpaleyespec Opaleye.distinctspecField

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

96

91

97

92

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

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

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

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

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

112table (TableSchema name schema columns) =

107table (TableSchema name schema columns) =

113 case schema of

108 case schema of

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

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

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

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

116

111

117

112

118tableFields :: Selects names exprs

113tableFields :: Selects names exprs

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

124 where

119 where

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

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

126 go (Name name) =

121 go (Name name) =

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

122+ traverseFieldP $

128 Opaleye.requiredTableField name

123 Opaleye.requiredTableField name

129

124

130

125

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

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

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

127+unpackspec = fromOpaleyespec Opaleye.unpackspecField

133− fmap fromColumns .

134− unwrapApplicative .

135− htraverse (WrapApplicative . traversePrimExpr f) .

136− toColumns

137{-# INLINABLE unpackspec #-}

128{-# INLINABLE unpackspec #-}

138

129

139

130

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

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

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

132+valuesspec = dimap toColumns fromColumns $

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

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

142

135

143

136

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

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

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

147 Name column -> fromPrimExpr $ Opaleye.BaseTableAttrExpr column

140 Name column -> fromPrimExpr $ Opaleye.BaseTableAttrExpr column

148

141

149

142

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−

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

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

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

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

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

145-- 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 a b (a <: b)

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

150

151

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

153greatest :: OrdTable a => a -> a -> a

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

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

src/Rel8/Table/Projection.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 b) b)

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

39 )

40 => Projecting a b

41

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

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

20 , isThisTable, isThatTable, isThoseTable

21 , hasHereTable, hasThereTable

22 , justHereTable, justThereTable

23+ , alignMaybeTable

23 , aggregateTheseTable

24 , aggregateTheseTable

24 , nameTheseTable

25 , nameTheseTable

25 )

26 )

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

29import Data.Bifunctor ( Bifunctor, bimap )

30import Data.Bifunctor ( Bifunctor, bimap )

30import Data.Kind ( Type )

31import Data.Kind ( Type )

31import Data.Maybe ( isJust )

32import Data.Maybe ( isJust )

32−import Prelude hiding ( undefined )

33+import Prelude hiding ( null, undefined )

33

34

34-- rel8

35-- rel8

35import Rel8.Aggregate ( Aggregate )

36import Rel8.Aggregate ( Aggregate )

36import Rel8.Expr ( Expr )

37import Rel8.Expr ( Expr )

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

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

38−import Rel8.Expr.Null ( isNonNull )

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

39import Rel8.Kind.Context ( Reifiable )

40import Rel8.Kind.Context ( Reifiable )

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

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

41import Rel8.Schema.Dict ( Dict( Dict ) )

42import Rel8.Schema.Dict ( Dict( Dict ) )

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

288justThereTable = there

289justThereTable = there

289

290

291

292+-- | Construct a @TheseTable@ from two 'MaybeTable's.

293+alignMaybeTable :: ()

294+ => MaybeTable Expr a

295+ -> MaybeTable Expr b

296+ -> MaybeTable Expr (TheseTable Expr a b)

297+alignMaybeTable a b = MaybeTable tag (pure (TheseTable a b))

298+ where

299+ tag = boolExpr null mempty (isJustTable a ||. isJustTable b)

300+

301+

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

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

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

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

293thisTable a = TheseTable (justTable a) nothingTable

304thisTable a = TheseTable (justTable a) nothingTable

src/Rel8/Table/Window.hsnew file+43

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

1+{-# language MonoLocalBinds #-}

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

@@ -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 ( fromMaybe )

61+import Data.Maybe ( fromJust, fromMaybe )

62import Prelude hiding ( lookup, zip, zipWith )

63

64-- bifunctors

@@ -69,9 +69,7 @@ import Control.Comonad ( extract )

69

70-- opaleye

71import qualified Opaleye.Aggregate as Opaleye

72−import qualified Opaleye.Internal.Order as Opaleye

72+import qualified Opaleye.Order as Opaleye ( orderBy, distinctOnExplicit )

73−import qualified Opaleye.Internal.QueryArr as Opaleye

74−import qualified Opaleye.Order as Opaleye ( orderBy )

75

73

76-- profunctors

74-- profunctors

77import Data.Profunctor ( dimap, lmap )

75import Data.Profunctor ( dimap, lmap )

@@ -92,10 +90,10 @@ import Rel8.Order ( Order( Order ) )

92import Rel8.Query ( Query )

90import Rel8.Query ( Query )

93import qualified Rel8.Query.Exists as Q ( exists, present, absent )

91import qualified Rel8.Query.Exists as Q ( exists, present, absent )

94import Rel8.Query.Filter ( where_ )

92import Rel8.Query.Filter ( where_ )

95−import Rel8.Query.Limit ( limit )

96import Rel8.Query.List ( catNonEmptyTable )

93import Rel8.Query.List ( catNonEmptyTable )

97import qualified Rel8.Query.Maybe as Q ( optional )

94import qualified Rel8.Query.Maybe as Q ( optional )

98import Rel8.Query.Opaleye ( mapOpaleye, unsafePeekQuery )

95import Rel8.Query.Opaleye ( mapOpaleye, unsafePeekQuery )

96+import Rel8.Query.Rebind ( rebind )

99import Rel8.Query.These ( alignBy )

97import Rel8.Query.These ( alignBy )

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

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

101import Rel8.Table.Aggregate ( hgroupBy, listAgg, nonEmptyAgg )

99import Rel8.Table.Aggregate ( hgroupBy, listAgg, nonEmptyAgg )

@@ -236,7 +234,13 @@ instance EqTable k => Monad (Tabulation k) where

236-- | If @'Tabulation' k a@ is @Map k (NonEmpty a)@, then @(<|>:)@ is

234-- | If @'Tabulation' k a@ is @Map k (NonEmpty a)@, then @(<|>:)@ is

237-- @unionWith (<>)@.

235-- @unionWith (<>)@.

238instance EqTable k => AltTable (Tabulation k) where

236instance 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

239− as <|>: bs = catNonEmptyTable `through` ((<>) `on` some) as bs

243+ _ -> catNonEmptyTable `through` ((<>) `on` some) tas tbs

240

244

241

245

242instance EqTable k => AlternativeTable (Tabulation k) where

246instance EqTable k => AlternativeTable (Tabulation k) where

@@ -345,19 +349,8 @@ aggregate (Tabulation f) = Tabulation $

345-- \"first\" value it encounters for each key, but note that \"first\" is

349-- \"first\" value it encounters for each key, but note that \"first\" is

346-- undefined unless you first call 'order'.

350-- undefined unless you first call 'order'.

347distinct :: EqTable k => Tabulation k a -> Tabulation k a

351distinct :: EqTable k => Tabulation k a -> Tabulation k a

348−distinct (Tabulation f) = Tabulation $ \p ->

352+distinct (Tabulation f) = Tabulation $

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

356− ( Opaleye.distinctOn (key unpackspec) fst

353+ mapOpaleye (Opaleye.distinctOnExplicit (key unpackspec) fst) . f

357− . Opaleye.runSimpleQueryArr q

358− )

359− )

360− (f p)

361

354

362

355

363-- | 'order' orders the /values/ of a 'Tabulation' within their

356-- | 'order' orders the /values/ of a 'Tabulation' within their

@@ -516,8 +509,8 @@ alignWith :: EqTable k

516 -> Tabulation k a -> Tabulation k b -> Tabulation k c

509 -> Tabulation k a -> Tabulation k b -> Tabulation k c

517alignWith f (Tabulation as) (Tabulation bs) = Tabulation $ \p -> do

510alignWith f (Tabulation as) (Tabulation bs) = Tabulation $ \p -> do

518 tkab <- liftF2 (alignBy condition) as bs p

511 tkab <- liftF2 (alignBy condition) as bs p

512+ k <- traverse (rebind "key") $ recover $ bimap fst fst tkab

519 let

513 let

520− k = recover $ bimap fst fst tkab

521 tab = bimap snd snd tkab

514 tab = bimap snd snd tkab

522 pure (k, f tab)

515 pure (k, f tab)

523 where

516 where

@@ -635,3 +628,13 @@ similarity a b = a <* present b

635-- @do@-notation.

628-- @do@-notation.

636difference :: EqTable k => Tabulation k a -> Tabulation k b -> Tabulation k a

629difference :: EqTable k => Tabulation k a -> Tabulation k b -> Tabulation k a

637difference a b = a <* absent b

630difference a b = a <* absent b

631+

632+

633+-- | 'Tabulation's can be produced with either 'fromQuery' or 'liftQuery', and

634+-- in some cases we might want to treat these differently. 'peek' uses

635+-- 'unsafePeekQuery' to determine which type of 'Tabulation' we have.

636+peek :: Tabulation k a -> Tabulation k (Either (Query a) (Query (k, a)))

637+peek (Tabulation f) = Tabulation $ \p ->

638+ pure $ (empty,) $ case unsafePeekQuery (f p) of

639+ (Nothing, _) -> Left $ fmap snd (f p)

640+ (Just _, _) -> Right $ fmap (first fromJust) (f p)

src/Rel8/Type.hs+9−8

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

1+{-# language FlexibleContexts #-}

1{-# language FlexibleInstances #-}

2{-# language FlexibleInstances #-}

2{-# language MonoLocalBinds #-}

3{-# language MonoLocalBinds #-}

3{-# language MultiWayIf #-}

4{-# language MultiWayIf #-}

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

127instance DBType Float where

128instance DBType Float where

128 typeInformation = TypeInformation

129 typeInformation = TypeInformation

129 { encode = \x -> Opaleye.ConstExpr

130 { encode = \x -> Opaleye.ConstExpr

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

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

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

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

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

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

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

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

134 , decode = Hasql.float4

135 , decode = Hasql.float4

135 , typeName = "float4"

136 , typeName = "float4"

136 }

137 }

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

140instance DBType Double where

141instance DBType Double where

141 typeInformation = TypeInformation

142 typeInformation = TypeInformation

142 { encode = \x -> Opaleye.ConstExpr

143 { encode = \x -> Opaleye.ConstExpr

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

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

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

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

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

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

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

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

147 , decode = Hasql.float8

148 , decode = Hasql.float8

148 , typeName = "float8"

149 , typeName = "float8"

149 }

150 }

src/Rel8/Type/Enum.hs+1

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

106

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

108-- fields).

109+type Enumable :: Type -> Constraint

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

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

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

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

111

112

src/Rel8/Type/JSONBEncoded.hs+4

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

1+{-# language StandaloneKindSignatures #-}

2+

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

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

2

4

3-- aeson

5-- aeson

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

6

8

7-- base

9-- base

8import Data.Bifunctor ( first )

10import Data.Bifunctor ( first )

11+import Data.Kind ( Type )

9import Prelude

12import Prelude

10

13

11-- hasql

14-- hasql

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

20

23

21

24

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

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

26+type JSONBEncoded :: Type -> Type

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

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

24

28

25

29

src/Rel8/Type/JSONEncoded.hs+4

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

1+{-# language StandaloneKindSignatures #-}

2+

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

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

2

4

3-- aeson

5-- aeson

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

5import Data.Aeson.Types ( parseEither )

7import Data.Aeson.Types ( parseEither )

6

8

7-- base

9-- base

10+import Data.Kind ( Type )

8import Prelude

11import Prelude

9

12

10-- rel8

13-- rel8

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

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

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

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

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

17-- classes.

20-- classes.

21+type JSONEncoded :: Type -> Type

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

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

19

23

20

24

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

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

18

19-- rel8

20import Rel8.Type ( DBType )

21+import Rel8.Type.Ord ( DBOrd )

21

22

22-- scientific

23-- scientific

23import Data.Scientific ( Scientific )

24import Data.Scientific ( Scientific )

@@ -39,13 +40,14 @@ instance DBNum Scientific

39-- expressions. This is a Rel8 concept, and allows us to provide

40-- expressions. This is a Rel8 concept, and allows us to provide

40-- 'fromIntegral'.

41-- 'fromIntegral'.

41type DBIntegral :: Type -> Constraint

42type DBIntegral :: Type -> Constraint

42−class DBNum a => DBIntegral a

43+class (DBNum a, DBOrd a) => DBIntegral a

43instance DBIntegral Int16

44instance DBIntegral Int16

44instance DBIntegral Int32

45instance DBIntegral Int32

45instance DBIntegral Int64

46instance DBIntegral Int64

46

47

48

48-- | The class of database types that support the @/@ operator.

49-- | The class of database types that support the @/@ operator.

50+type DBFractional :: Type -> Constraint

49class DBNum a => DBFractional a

51class DBNum a => DBFractional a

50instance DBFractional Float

52instance DBFractional Float

51instance DBFractional Double

53instance DBFractional Double

@@ -53,6 +55,7 @@ instance DBFractional Scientific

53

55

54

56

55-- | The class of database types that support the @/@ operator.

57-- | The class of database types that support the @/@ operator.

58+type DBFloating :: Type -> Constraint

56class DBFractional a => DBFloating a

59class DBFractional a => DBFloating a

57instance DBFloating Float

60instance DBFloating Float

58instance DBFloating Double

61instance DBFloating Double

src/Rel8/Type/ReadShow.hs+3

@@ -1,10 +1,12 @@

1{-# language ScopedTypeVariables #-}

2+{-# language StandaloneKindSignatures #-}

2{-# language TypeApplications #-}

3{-# language TypeApplications #-}

3{-# language ViewPatterns #-}

4{-# language ViewPatterns #-}

4

5

5module Rel8.Type.ReadShow ( ReadShow(..) ) where

6module Rel8.Type.ReadShow ( ReadShow(..) ) where

6

7

7-- base

8-- base

9+import Data.Kind ( Type )

8import Data.Proxy ( Proxy( Proxy ) )

10import Data.Proxy ( Proxy( Proxy ) )

9import Data.Typeable ( Typeable, typeRep )

11import Data.Typeable ( Typeable, typeRep )

10import Prelude

12import Prelude

@@ -20,6 +22,7 @@ import qualified Data.Text as Text

20

22

21-- | A deriving-via helper type for column types that store a Haskell value

23-- | A deriving-via helper type for column types that store a Haskell value

22-- using a Haskell's 'Read' and 'Show' type classes.

24-- using a Haskell's 'Read' and 'Show' type classes.

25+type ReadShow :: Type -> Type

23newtype ReadShow a = ReadShow { fromReadShow :: a }

26newtype ReadShow a = ReadShow { fromReadShow :: a }

24

27

25

28

src/Rel8/Type/Tag.hs+1

@@ -90,6 +90,7 @@ instance DBMonoid MaybeTag where

90 memptyExpr = litExpr mempty

91

92

93+type Tag :: Type

93newtype Tag = Tag Text

94newtype Tag = Tag Text

94 deriving newtype

95 deriving newtype

95 ( Eq, Ord, Read, Show

96 ( Eq, Ord, Read, Show

src/Rel8/Window.hsnew file+97

@@ -0,0 +1,97 @@

1+{-# language DerivingVia #-}

2+{-# language FlexibleContexts #-}

3+{-# language GeneralizedNewtypeDeriving #-}

4+{-# language ScopedTypeVariables #-}

5+{-# language StandaloneKindSignatures #-}

6+{-# language TypeApplications #-}

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+70

@@ -6,6 +6,7 @@

6{-# language FlexibleContexts #-}

7{-# language FlexibleInstances #-}

8{-# language MonoLocalBinds #-}

9+{-# language NamedFieldPuns #-}

9{-# language OverloadedStrings #-}

10{-# language OverloadedStrings #-}

10{-# language RecordWildCards #-}

11{-# language RecordWildCards #-}

11{-# language ScopedTypeVariables #-}

12{-# language ScopedTypeVariables #-}

@@ -37,6 +38,7 @@ import qualified Data.ByteString.Lazy

37import Data.CaseInsensitive ( mk )

38import Data.CaseInsensitive ( mk )

38

39

39-- containers

40-- containers

41+import Data.Containers.ListUtils ( nubOrdOn )

40import qualified Data.Map.Strict as Map

42import qualified Data.Map.Strict as Map

41

43

42-- hasql

44-- hasql

@@ -120,6 +122,7 @@ tests =

120 , testLogicalFixities getTestDatabase

122 , testLogicalFixities getTestDatabase

121 , testUpdate getTestDatabase

123 , testUpdate getTestDatabase

122 , testDelete getTestDatabase

124 , testDelete getTestDatabase

125+ , testUpsert getTestDatabase

123 , testSelectNestedPairs getTestDatabase

126 , testSelectNestedPairs getTestDatabase

124 , testSelectArray getTestDatabase

127 , testSelectArray getTestDatabase

125 , testNestedMaybeTable getTestDatabase

128 , testNestedMaybeTable getTestDatabase

@@ -135,6 +138,7 @@ tests =

135 flip run conn do

138 flip run conn do

136 sql "CREATE EXTENSION citext"

139 sql "CREATE EXTENSION citext"

137 sql "CREATE TABLE test_table ( column1 text not null, column2 bool not null )"

140 sql "CREATE TABLE test_table ( column1 text not null, column2 bool not null )"

141+ sql "CREATE TABLE unique_table ( \"key\" text not null unique, \"value\" text not null )"

138 sql "CREATE SEQUENCE test_seq"

142 sql "CREATE SEQUENCE test_seq"

139

143

140 return db

144 return db

@@ -709,6 +713,72 @@ testDelete = databasePropertyTest "Can DELETE TestTable" \transaction -> do

709 sort (deleted <> selected) === sort rows

713 sort (deleted <> selected) === sort rows

710

714

711

715

716+data UniqueTable f = UniqueTable

717+ { uniqueTableKey :: Rel8.Column f Text

718+ , uniqueTableValue :: Rel8.Column f Text

719+ }

720+ deriving stock Generic

721+ deriving anyclass Rel8.Rel8able

722+

723+

724+deriving stock instance Eq (UniqueTable Result)

725+deriving stock instance Ord (UniqueTable Result)

726+deriving stock instance Show (UniqueTable Result)

727+

728+

729+uniqueTableSchema :: Rel8.TableSchema (UniqueTable Rel8.Name)

730+uniqueTableSchema =

731+ Rel8.TableSchema

732+ { name = "unique_table"

733+ , schema = Nothing

734+ , columns = UniqueTable

735+ { uniqueTableKey = "key"

736+ , uniqueTableValue = "value"

737+ }

738+ }

739+

740+

741+genUniqueTable :: Gen (UniqueTable Result)

742+genUniqueTable = do

743+ uniqueTableKey <- Gen.text (Range.linear 0 5) Gen.alphaNum

744+ uniqueTableValue <- Gen.text (Range.linear 0 5) Gen.alphaNum

745+ pure UniqueTable {..}

746+

747+

748+testUpsert :: IO TmpPostgres.DB -> TestTree

749+testUpsert = databasePropertyTest "Can UPSERT UniqueTable" \transaction -> do

750+ as <- unique $ forAll $ Gen.list (Range.linear 0 20) genUniqueTable

751+ bs <- unique $ forAll $ Gen.list (Range.linear 0 20) genUniqueTable

752+

753+ transaction do

754+ selected <- lift do

755+ statement () $ Rel8.insert Rel8.Insert

756+ { into = uniqueTableSchema

757+ , rows = Rel8.values $ Rel8.lit <$> as

758+ , onConflict = Rel8.DoNothing

759+ , returning = pure ()

760+ }

761+

762+ statement () $ Rel8.insert Rel8.Insert

763+ { into = uniqueTableSchema

764+ , rows = Rel8.values $ Rel8.lit <$> bs

765+ , onConflict = Rel8.DoUpdate Rel8.Upsert

766+ { index = uniqueTableKey

767+ , set = \UniqueTable {uniqueTableValue} old -> old {uniqueTableValue}

768+ , updateWhere = \_ _ -> Rel8.true

769+ }

770+ , returning = pure ()

771+ }

772+

773+ statement () $ Rel8.select do

774+ Rel8.each uniqueTableSchema

775+

776+ fromUniqueTables selected === fromUniqueTables bs <> fromUniqueTables as

777+ where

778+ unique = fmap (nubOrdOn uniqueTableKey)

779+ fromUniqueTables = Map.fromList . map \(UniqueTable key value) -> (key, value)

780+

781+

712newtype HKNestedPair f = HKNestedPair { pairOne :: (TestTable f, TestTable f) }

782newtype HKNestedPair f = HKNestedPair { pairOne :: (TestTable f, TestTable f) }

713 deriving stock Generic

783 deriving stock Generic

714 deriving anyclass Rel8.Rel8able

784 deriving anyclass Rel8.Rel8able

tests/Rel8/Generic/Rel8able/Test.hs+10−1

@@ -5,6 +5,7 @@

5{-# language DuplicateRecordFields #-}

6{-# language FlexibleInstances #-}

7{-# language MultiParamTypeClasses #-}

8+{-# language StandaloneKindSignatures #-}

8{-# language TypeFamilies #-}

9{-# language TypeFamilies #-}

9{-# language UndecidableInstances #-}

10{-# language UndecidableInstances #-}

10

11

@@ -171,9 +172,17 @@ data NestedTableTestB f = NestedTableTestB

171 deriving anyclass Rel8able

172 deriving anyclass Rel8able

172

173

174

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