master..35c6127 · rel8

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

since splitsnapshots

unifiedsplit

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

9 persist-credentials: false

10 submodules: true

11

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

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

13 with:

14 nix_path: nixpkgs=channel:nixos-unstable

15 extra_nix_config: |

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

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

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

18

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

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

20 with:

21 name: rel8

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

Changelog.md−86

@@ -1,89 +1,3 @@

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−

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

74−

75−## Bug fixes

76−

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

78−

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

80−

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

82−

83−## Breaking changes

84−

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

86−

87# 1.1.0.0 (2021-07-16)

1# 1.1.0.0 (2021-07-16)

88

2

89## New features

3## New features

cabal.project+5

@@ -1 +1,6 @@

1packages: .

2+

3+allow-newer: generic-monoid:base

4+allow-newer: cryptohash-sha1:base

5+allow-newer: cryptohash-md5:base

6+allow-newer: entropy:Cabal

cabal.project.haskell-nix+6

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

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

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

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

5+

6+source-repository-package

7+ type: git

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

9+ tag: f99b05454874192e3511bd133555dfb6cc6a6ecb

10+ --sha256: 0yy2i2jbllwavv5d2176rf8lmm4l1ws90lxkmdlfgvfzqxidx0gi

default.nix+2−2

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

1let

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

3

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

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

5

6 nixpkgsArgs = haskellNix.nixpkgsArgs;

7

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

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

9

10 pkgs = import nixpkgsSrc nixpkgsArgs;

11

docs/cookbook.rst+7−9

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

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

143posts. We want our query to return:

144

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

145+1. The latest 5 blog posts.

1462. For each blog post, all tags.

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

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

148

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

150

151 latestBlogPosts = do

152 post <- each postSchema

153

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

155− tags <- some $ do

154+ tags <- aggregate do

156 tag <- each tagSchema

155 tag <- each tagSchema

157 where_ (tagPostId tag ==. postId post)

156 where_ (tagPostId tag ==. postId post)

158− return (tagName tag)

157+ return (listAgg (tagName tag))

159

158

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

161− latestComments <-

159+ latestComments <-

162− many $

160+ many $

163− limit 3 $

161+ limit 3 $

164 orderBy (commentCreatedAt >$< desc) do

162 orderBy (commentCreatedAt >$< desc) do

165 comment <- each commentSchema

163 comment <- each commentSchema

166 where_ (commentPostId comment ==. postId post)

164 where_ (commentPostId comment ==. postId post)

nix/sources.json+9−9

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

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

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

7 "repo": "haskell.nix",

8− "rev": "0837156c56cb5350dd9bd84eb424187e00aa1e8a",

8+ "rev": "3856d2d24dca0ecc71fcfc314253a2a2d07a3c4f",

9− "sha256": "1djmv5a0vfj78csw2cad6nicrs8iqrp928b9b3v4h7lwwhhzliwl",

9+ "sha256": "0s69nasqhkv8n0qmdv075k83p3z584ja9vkzdnp2291mymghvx87",

10 "type": "tarball",

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

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

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

13 },

14 "niv": {

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

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

18 "owner": "nmattia",

19 "repo": "niv",

20− "rev": "acdb1726783637852c01e0ad639ac9cbec28d8c8",

20+ "rev": "e0ca65c81a2d7a4d82a189f1e23a48d59ad42070",

21− "sha256": "1wszl8q70z6wfgkh2dvgmhhry6qp9nar421qq2ifd17hq2jj9ck3",

21+ "sha256": "1pq9nh1d8nn3xvbdny8fafzw87mj7gsmp6pxkdl65w2g18rmcmzx",

22 "type": "tarball",

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

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

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

25 },

26 "nixpkgs": {

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

29 "homepage": null,

30 "owner": "nixos",

31 "repo": "nixpkgs",

32− "rev": "1c1f5649bb9c1b0d98637c8c365228f57126f361",

32+ "rev": "59b8d9cf24e9fcf10341a0923c9bdca088dca8c8",

33− "sha256": "0f2nvdijyxfgl5kwyb4465pppd5vkhqxddx6v40k2s0z9jfhj0xl",

33+ "sha256": "08f38v4b2kcxnbapdwrb54bglka92cxj9qlnqlk5px206jyq9v4c",

34 "type": "tarball",

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

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

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

37 }

38}

nix/sources.nix+1−21

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

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

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

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

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

35− submoduleArg =

36− let

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

38− emptyArgWithWarning =

39− if submodules == true

40− then

41− builtins.trace

42− (

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

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

45− + "does not support them"

46− )

47− {}

48− else {};

49− in

50− if nixSupportsSubmodules

51− then { inherit submodules; }

52− else emptyArgWithWarning;

53 in

34 in

54− builtins.fetchGit

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

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

56

36

57 fetch_local = spec: spec.path;

37 fetch_local = spec: spec.path;

58

38

rel8.cabal+5−15

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

1cabal-version: 2.0

2name: rel8

3−version: 1.4.0.0

3+version: 1.1.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 || ^>=4.16

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

24 , bifunctors

25 , bytestring

26 , case-insensitive

27 , comonad

28 , contravariant

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

29+ , hasql ^>= 1.4.5.1

30− , opaleye ^>= 0.9.6.1

30+ , opaleye ^>= 0.7.3.0

31 , pretty

32 , profunctors

33 , product-profunctors

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

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

47 -Wno-monomorphism-restriction

48 -Wno-missing-local-signatures

49− -Wno-missing-kind-signatures

50 hs-source-dirs:

49 hs-source-dirs:

51 src

50 src

52 exposed-modules:

51 exposed-modules:

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

66 Rel8.Column.List

65 Rel8.Column.List

67 Rel8.Column.Maybe

66 Rel8.Column.Maybe

68 Rel8.Column.NonEmpty

67 Rel8.Column.NonEmpty

69− Rel8.Column.Null

70 Rel8.Column.These

68 Rel8.Column.These

71

69

72 Rel8.Expr

70 Rel8.Expr

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

82 Rel8.Expr.Order

80 Rel8.Expr.Order

83 Rel8.Expr.Sequence

81 Rel8.Expr.Sequence

84 Rel8.Expr.Serialize

82 Rel8.Expr.Serialize

85− Rel8.Expr.Window

86

83

87 Rel8.FCF

84 Rel8.FCF

88

85

@@ -116,12 +113,10 @@ library

116 Rel8.Query.Null

113 Rel8.Query.Null

117 Rel8.Query.Opaleye

114 Rel8.Query.Opaleye

118 Rel8.Query.Order

115 Rel8.Query.Order

119− Rel8.Query.Rebind

120 Rel8.Query.Set

116 Rel8.Query.Set

121 Rel8.Query.SQL

117 Rel8.Query.SQL

122 Rel8.Query.These

118 Rel8.Query.These

123 Rel8.Query.Values

119 Rel8.Query.Values

124− Rel8.Query.Window

125

120

126 Rel8.Schema.Context.Nullify

121 Rel8.Schema.Context.Nullify

127 Rel8.Schema.Dict

122 Rel8.Schema.Dict

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

170 Rel8.Table.Maybe

165 Rel8.Table.Maybe

171 Rel8.Table.Name

166 Rel8.Table.Name

172 Rel8.Table.NonEmpty

167 Rel8.Table.NonEmpty

173− Rel8.Table.Null

174 Rel8.Table.Nullify

168 Rel8.Table.Nullify

175 Rel8.Table.Opaleye

169 Rel8.Table.Opaleye

176 Rel8.Table.Ord

170 Rel8.Table.Ord

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

181 Rel8.Table.These

175 Rel8.Table.These

182 Rel8.Table.Transpose

176 Rel8.Table.Transpose

183 Rel8.Table.Undefined

177 Rel8.Table.Undefined

184− Rel8.Table.Window

185

178

186 Rel8.Type

179 Rel8.Type

187 Rel8.Type.Array

180 Rel8.Type.Array

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

200 Rel8.Type.Sum

193 Rel8.Type.Sum

201 Rel8.Type.Tag

194 Rel8.Type.Tag

202

195

203− Rel8.Window

204−

205−

206test-suite tests

196test-suite tests

207 type: exitcode-stdio-1.0

197 type: exitcode-stdio-1.0

208 build-depends:

198 build-depends:

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

212 , containers

202 , containers

213 , hasql

203 , hasql

214 , hasql-transaction

204 , hasql-transaction

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

205+ , hedgehog ^>=1.0.2

216 , mmorph

206 , mmorph

217 , rel8

207 , rel8

218 , scientific

208 , scientific

shell.nix+1−1

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

1let

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

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

3+ pkgs = import sources.nixpkgs {};

4 hsPkgs = import ./default.nix;

5in

6 hsPkgs.shellFor {

src/Rel8.hs+8−273

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

38 , HMaybe

39 , HList

40 , HNonEmpty

41− , HNull

42 , HThese

41 , HThese

43 , Lift

42 , Lift

44

43

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

47 , Transposes

46 , Transposes

48 , AltTable((<|>:))

47 , AltTable((<|>:))

49 , AlternativeTable( emptyTable )

48 , AlternativeTable( emptyTable )

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

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

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

50+ , OrdTable, ascTable, descTable

52 , lit

51 , lit

53 , bool

52 , bool

54 , case_

53 , case_

55− , castTable

56

54

57 -- ** @MaybeTable@

55 -- ** @MaybeTable@

58 , MaybeTable

56 , MaybeTable

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

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

60 , isNothingTable, isJustTable

58 , isNothingTable, isJustTable

61− , fromMaybeTable

62 , optional

59 , optional

63 , catMaybeTable

60 , catMaybeTable

64 , traverseMaybeTable

61 , traverseMaybeTable

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

81 , isThisTable, isThatTable, isThoseTable

78 , isThisTable, isThatTable, isThoseTable

82 , hasHereTable, hasThereTable

79 , hasHereTable, hasThereTable

83 , justHereTable, justThereTable

80 , justHereTable, justThereTable

84− , alignMaybeTable

85 , alignBy

81 , alignBy

86 , keepHereTable, loseHereTable

82 , keepHereTable, loseHereTable

87 , keepThereTable, loseThereTable

83 , keepThereTable, loseThereTable

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

94

90

95 -- ** @ListTable@

91 -- ** @ListTable@

96 , ListTable

92 , ListTable

97− , listTable, ($*)

93+ , listTable

98 , nameListTable

94 , nameListTable

99 , many

95 , many

100 , manyExpr

96 , manyExpr

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

103

99

104 -- ** @NonEmptyTable@

100 -- ** @NonEmptyTable@

105 , NonEmptyTable

101 , NonEmptyTable

106− , nonEmptyTable, ($+)

102+ , nonEmptyTable

107 , nameNonEmptyTable

103 , nameNonEmptyTable

108 , some

104 , some

109 , someExpr

105 , someExpr

110 , catNonEmptyTable

106 , catNonEmptyTable

111 , catNonEmpty

107 , catNonEmpty

112

108

113− -- ** @NullTable@

109+ -- ** @ADT@

114− , NullTable

115− , nullableTable, nullTable, nullifyTable

116− , isNullTable, isNonNullTable

117− , catNullTable

118− , nameNullTable

119− , toNullTable, toMaybeTable

120−

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

122− -- $adts

123−

124− -- *** Naming of ADTs

125− -- $naming

126− , NameADT, nameADT

127 , ADT, ADTable

110 , ADT, ADTable

128−

129− -- *** Deconstruction of ADTs

130− -- $deconstruction

131− , DeconstructADT, deconstructADT

132−

133− -- *** Construction of ADTs

134− -- $construction

135 , BuildADT, buildADT

111 , BuildADT, buildADT

136 , ConstructADT, constructADT

112 , ConstructADT, constructADT

137−

113+ , DeconstructADT, deconstructADT

138− -- *** Other ADT operations

114+ , NameADT, nameADT

139 , AggregateADT, aggregateADT

115 , AggregateADT, aggregateADT

140

116

141− -- *** Miscellaneous notes

142− -- $misc-notes

143−

144 -- ** @HKD@

117 -- ** @HKD@

145 , HKD, HKDable

118 , HKD, HKDable

146 , BuildHKD, buildHKD

119 , BuildHKD, buildHKD

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

165 -- ** @null@

138 -- ** @null@

166 , NotNull

139 , NotNull

167 , Nullable

140 , Nullable

168− , Homonullable

169 , null

141 , null

170 , nullify

142 , nullify

171 , nullable

143 , nullable

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

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

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

185 , in_

157 , in_

186 , boolExpr, caseExpr

158 , boolExpr, caseExpr

187− , like, ilike

188

159

189 -- ** Ordering

160 -- ** Ordering

190 , DBOrd

161 , DBOrd

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

253 , countRows

224 , countRows

254 , groupBy

225 , groupBy

255 , listAgg, listAggExpr

226 , listAgg, listAggExpr

256− , mode

257 , nonEmptyAgg, nonEmptyAggExpr

227 , nonEmptyAgg, nonEmptyAggExpr

258 , DBMax, max

228 , DBMax, max

259 , DBMin, min

229 , DBMin, min

260− , DBSum, sum, sumWhere, avg

230+ , DBSum, sum, sumWhere

261 , DBString, stringAgg

231 , DBString, stringAgg

262 , count

232 , count

263 , countStar

233 , countStar

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

275 , nullsLast

245 , nullsLast

276

246

277 -- ** Window functions

247 -- ** Window functions

278− , Window

279− , window

280− , Partition

281− , over

282− , partitionBy

283− , orderPartitionBy

284− , cumulative

285− , cumulative_

286− , currentRow

287− , rowNumber

288− , rank

289− , denseRank

290− , percentRank

291− , cumeDist

292− , ntile

293− , lag

294− , lead

295− , firstValue

296− , lastValue

297− , nthValue

298 , indexed

248 , indexed

299

249

300 -- ** Bindings

250 -- ** Bindings

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

334

284

335 -- ** @CREATE VIEW@

285 -- ** @CREATE VIEW@

336 , createView

286 , createView

337− , createOrReplaceView

338

287

339 -- ** Sequences

288 -- ** Sequences

340 , nextval

289 , nextval

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

353import Rel8.Column.List

302import Rel8.Column.List

354import Rel8.Column.Maybe

303import Rel8.Column.Maybe

355import Rel8.Column.NonEmpty

304import Rel8.Column.NonEmpty

356−import Rel8.Column.Null

357import Rel8.Column.These

305import Rel8.Column.These

358import Rel8.Expr

306import Rel8.Expr

359import Rel8.Expr.Aggregate

307import Rel8.Expr.Aggregate

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

367import Rel8.Expr.Order

315import Rel8.Expr.Order

368import Rel8.Expr.Serialize

316import Rel8.Expr.Serialize

369import Rel8.Expr.Sequence

317import Rel8.Expr.Sequence

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

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

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

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

373import Rel8.Order

319import Rel8.Order

374import Rel8.Query

320import Rel8.Query

@@ -385,12 +331,10 @@ import Rel8.Query.List

385import Rel8.Query.Maybe

331import Rel8.Query.Maybe

386import Rel8.Query.Null

332import Rel8.Query.Null

387import Rel8.Query.Order

333import Rel8.Query.Order

388−import Rel8.Query.Rebind

389import Rel8.Query.SQL (showQuery)

334import Rel8.Query.SQL (showQuery)

390import Rel8.Query.Set

335import Rel8.Query.Set

391import Rel8.Query.These

336import Rel8.Query.These

392import Rel8.Query.Values

337import Rel8.Query.Values

393−import Rel8.Query.Window

394import Rel8.Schema.Field

338import Rel8.Schema.Field

395import Rel8.Schema.HTable

339import Rel8.Schema.HTable

396import Rel8.Schema.Name

340import Rel8.Schema.Name

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

417import Rel8.Table.Maybe

361import Rel8.Table.Maybe

418import Rel8.Table.Name

362import Rel8.Table.Name

419import Rel8.Table.NonEmpty

363import Rel8.Table.NonEmpty

420−import Rel8.Table.Null

421−import Rel8.Table.Opaleye ( castTable )

422import Rel8.Table.Ord

364import Rel8.Table.Ord

423import Rel8.Table.Order

365import Rel8.Table.Order

424import Rel8.Table.Projection

366import Rel8.Table.Projection

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

426import Rel8.Table.Serialize

368import Rel8.Table.Serialize

427import Rel8.Table.These

369import Rel8.Table.These

428import Rel8.Table.Transpose

370import Rel8.Table.Transpose

429−import Rel8.Table.Window

430import Rel8.Type

371import Rel8.Type

431import Rel8.Type.Composite

372import Rel8.Type.Composite

432import Rel8.Type.Eq

373import Rel8.Type.Eq

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

441import Rel8.Type.Semigroup

382import Rel8.Type.Semigroup

442import Rel8.Type.String

383import Rel8.Type.String

443import Rel8.Type.Sum

384import Rel8.Type.Sum

444−import Rel8.Window

445

385

446

386

447-- $running

387-- $running

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

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

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

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

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

451-- `DuplicateRecordFields` language extension enabled.

391-- `DuplicateRecordFields` language extension enabled.

452−

453−-- $adts

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

455−--

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

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

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

459−--

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

461−--

462−-- @

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

464−-- deriving stock Generic

465−--

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

467−-- deriving stock Generic

468−-- deriving anyclass Rel8able

469−--

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

471−-- deriving stock Generic

472−-- deriving anyclass Rel8able

473−-- @

474−

475−-- $naming

476−--

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

478−--

479−-- @

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

481−-- thingSchema =

482−-- TableSchema

483−-- { schema = Nothing,

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

485−-- columns =

486−-- nameADT @Thing

487−-- \"tag\"

488−-- Employer

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

490−-- employerId = \"id\"

491−-- }

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

493−-- }

494−-- @

495−--

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

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

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

499−

500−-- $deconstruction

501−--

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

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

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

505−--

506−-- @

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

508−-- query = do

509−-- thingExpr <- each thingSchema

510−-- where_ $

511−-- deconstructADT @Thing

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

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

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

515−-- thingExpr

516−-- pure thingExpr

517−-- @

518−--

519−-- SQL output:

520−--

521−-- @

522−-- SELECT

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

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

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

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

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

528−-- FROM (SELECT

529−-- *

530−-- FROM (SELECT

531−-- "tag" as "tag0_1",

532−-- "id" as "id1_1",

533−-- "name" as "name2_1",

534−-- "size" as "size3_1",

535−-- "Mary" as "Mary4_1"

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

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

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

539−-- @

540−

541−-- $construction

542−--

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

544−--

545−-- @

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

547−-- @

548−--

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

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

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

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

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

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

555−--

556−-- @

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

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

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

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

561−-- @

562−--

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

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

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

566−--

567−-- @

568−-- > :t lit . Complete

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

570−-- @

571−--

572−--

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

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

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

576−-- query.

577−--

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

579−--

580−-- @

581−-- > :{

582−-- showQuery $ values

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

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

585−-- ]

586−-- :}

587−-- @

588−--

589−-- This produces the following SQL:

590−--

591−-- @

592−-- SELECT

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

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

595−-- FROM (SELECT

596−-- *

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

598−-- \"column2\" as \"values1_1\"

599−-- FROM

600−-- (VALUES

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

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

603−-- @

604−--

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

606−--

607−--

608−-- @

609−-- tag | Complete/_1/date

610−-- ----------+-------------------------------

611−-- Pending |

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

613−-- (2 rows)

614−-- @

615−--

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

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

618−-- to make sense:

619−--

620−-- @

621−-- > :t constructADT @Task

622−-- constructADT @Task

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

624−-- @

625−--

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

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

628−-- might use it as follows:

629−--

630−-- @

631−-- let

632−-- pending :: ADT Task Expr

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

634−--

635−-- complete :: ADT Task Expr

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

637−-- @

638−--

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

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

641−--

642−

643−-- $misc-notes

644−--

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

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

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

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

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

650−--

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

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

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

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

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

656−-- matching in PostgreSQL.

src/Rel8/Aggregate.hs+43−19

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

2{-# language FlexibleContexts #-}

3{-# language FlexibleInstances #-}

4{-# language MultiParamTypeClasses #-}

5+{-# language NamedFieldPuns #-}

5{-# language RankNTypes #-}

6{-# language RankNTypes #-}

6{-# language StandaloneKindSignatures #-}

7{-# language StandaloneKindSignatures #-}

7{-# language TypeFamilies #-}

8{-# language TypeFamilies #-}

8{-# language UndecidableInstances #-}

9{-# language UndecidableInstances #-}

9

10

10module Rel8.Aggregate

11module Rel8.Aggregate

11− ( Aggregate(..), zipOutputs

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

12− , unsafeMakeAggregate

13+ , Aggregator(..), unsafeMakeAggregate

13 , Aggregates

14 , Aggregates

14 )

15 )

15where

16where

16

17

17-- base

18-- base

18−import Control.Applicative ( liftA2 )

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

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

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

20import Data.Kind ( Constraint, Type )

21import Data.Kind ( Constraint, Type )

21import Prelude

22import Prelude

22

23

23−-- profunctors

24−import Data.Profunctor ( dimap )

25−

26-- opaleye

24-- opaleye

27−import qualified Opaleye.Aggregate as Opaleye

25+import qualified Opaleye.Internal.Aggregate as Opaleye

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

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

29−import qualified Opaleye.Internal.Column as Opaleye

27+import qualified Opaleye.Internal.PackMap as Opaleye

30

28

31-- rel8

29-- rel8

32import Rel8.Expr ( Expr )

30import Rel8.Expr ( Expr )

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

42import Rel8.Type ( DBType )

40import Rel8.Type ( DBType )

43

41

44

42

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

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

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

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

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

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

46type Aggregate :: K.Context

48type Aggregate :: K.Context

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

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

48

50

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

59 fromResult (HIdentity (Identity a)) = a

61 fromResult (HIdentity (Identity a)) = a

60

62

61

63

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

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

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

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

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

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

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

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

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

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

67

69

68

70

69−zipOutputs :: ()

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

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

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

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

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

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

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

76+ where

77+ detuplize (operation, ordering, distinction) =

78+ Aggregator {operation, ordering, distinction}

79+

80+

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

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

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

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

85+ f (fmap transform input)

86+

87+

88+type Aggregator :: Type

89+data Aggregator = Aggregator

90+ { operation :: Opaleye.AggrOp

91+ , ordering :: [Opaleye.OrderExpr]

92+ , distinction :: Opaleye.AggrDistinct

93+ }

72

94

73

95

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

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

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

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

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

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

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

99+ -> Maybe Aggregator

78 -> Expr input

100 -> Expr input

79 -> Aggregate output

101 -> Aggregate output

80unsafeMakeAggregate input output aggregator expr =

102unsafeMakeAggregate input output aggregator expr =

81− Aggregate $ dimap in_ out aggregator

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

82− where out = output . Opaleye.unColumn

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

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

105+ where

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

107+ (operation, ordering, distinction)

src/Rel8/Column/Null.hsdeleted−26

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

1−{-# language DataKinds #-}

2−{-# language StandaloneKindSignatures #-}

3−{-# language TypeFamilyDependencies #-}

4−

5−module Rel8.Column.Null

6− ( HNull

7− )

8−where

9−

10−-- base

11−import Data.Kind ( Type )

12−import Prelude

13−

14−-- rel8

15−import qualified Rel8.Schema.Kind as K

16−import Rel8.Schema.Result ( Result )

17−import Rel8.Table.Null ( NullTable )

18−

19−

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

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

22−-- context.

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

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

25− HNull Result = Maybe

26− HNull context = NullTable context

src/Rel8/Expr.hs−1

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

1{-# language DataKinds #-}

2{-# language DerivingStrategies #-}

3−{-# language FlexibleContexts #-}

4{-# language FlexibleInstances #-}

3{-# language FlexibleInstances #-}

5{-# language MultiParamTypeClasses #-}

4{-# language MultiParamTypeClasses #-}

6{-# language ScopedTypeVariables #-}

5{-# language ScopedTypeVariables #-}

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

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

10 , and, or

11 , min, max

12 , sum, sumWhere

13− , avg

14 , stringAgg

13 , stringAgg

15 , groupByExpr

14 , groupByExpr

16 , listAggExpr, nonEmptyAggExpr

15 , listAggExpr, nonEmptyAggExpr

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

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

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

25

24

26-- opaleye

25-- opaleye

27−import qualified Opaleye.Internal.Aggregate as Opaleye

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

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

29−import qualified Opaleye.Aggregate as Opaleye

30

27

31-- rel8

28-- rel8

32−import Rel8.Aggregate ( Aggregate, unsafeMakeAggregate )

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

33import Rel8.Expr ( Expr )

30import Rel8.Expr ( Expr )

34import Rel8.Expr.Bool ( caseExpr )

31import Rel8.Expr.Bool ( caseExpr )

35import Rel8.Expr.Opaleye

32import Rel8.Expr.Opaleye

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

53

50

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

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

55count :: Expr a -> Aggregate Int64

52count :: Expr a -> Aggregate Int64

56−count = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.count

53+count = unsafeMakeAggregate toPrimExpr fromPrimExpr $

54+ Just Aggregator

55+ { operation = Opaleye.AggrCount

56+ , ordering = []

57+ , distinction = Opaleye.AggrAll

58+ }

59+

57

60

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

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

59-- @COUNT(DISTINCT a)@

62-- @COUNT(DISTINCT a)@

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

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

61countDistinct = unsafeMakeAggregate toPrimExpr fromPrimExpr $

64countDistinct = unsafeMakeAggregate toPrimExpr fromPrimExpr $

62− Opaleye.distinctAggregator Opaleye.count

65+ Just Aggregator

66+ { operation = Opaleye.AggrCount

67+ , ordering = []

68+ , distinction = Opaleye.AggrDistinct

69+ }

63

70

64

71

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

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

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

74

81

75-- | Corresponds to @bool_and@.

82-- | Corresponds to @bool_and@.

76and :: Expr Bool -> Aggregate Bool

83and :: Expr Bool -> Aggregate Bool

77−and = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.boolAnd

84+and = unsafeMakeAggregate toPrimExpr fromPrimExpr $

85+ Just Aggregator

86+ { operation = Opaleye.AggrBoolAnd

87+ , ordering = []

88+ , distinction = Opaleye.AggrAll

89+ }

78

90

79

91

80-- | Corresponds to @bool_or@.

92-- | Corresponds to @bool_or@.

81or :: Expr Bool -> Aggregate Bool

93or :: Expr Bool -> Aggregate Bool

82−or = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.boolOr

94+or = unsafeMakeAggregate toPrimExpr fromPrimExpr $

95+ Just Aggregator

96+ { operation = Opaleye.AggrBoolOr

97+ , ordering = []

98+ , distinction = Opaleye.AggrAll

99+ }

83

100

84

101

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

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

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

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

87−max = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.unsafeMax

104+max = unsafeMakeAggregate toPrimExpr fromPrimExpr $

105+ Just Aggregator

106+ { operation = Opaleye.AggrMax

107+ , ordering = []

108+ , distinction = Opaleye.AggrAll

109+ }

88

110

89

111

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

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

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

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

92−min = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.unsafeMin

114+min = unsafeMakeAggregate toPrimExpr fromPrimExpr $

115+ Just Aggregator

116+ { operation = Opaleye.AggrMin

117+ , ordering = []

118+ , distinction = Opaleye.AggrAll

119+ }

93

120

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

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

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

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

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

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

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

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

98-- your input.

125-- your input.

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

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

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

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

101−

128+ Just Aggregator

129+ { operation = Opaleye.AggrSum

130+ , ordering = []

131+ , distinction = Opaleye.AggrAll

132+ }

102

133

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

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

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

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

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

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

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

110

134

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

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

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

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

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

118stringAgg :: Sql DBString a

142stringAgg :: Sql DBString a

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

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

120stringAgg delimiter =

144stringAgg delimiter =

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

145+ unsafeMakeAggregate toPrimExpr (castExpr . fromPrimExpr) $

146+ Just Aggregator

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

148+ , ordering = []

149+ , distinction = Opaleye.AggrAll

150+ }

122

151

123

152

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

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

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

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

126−groupByExpr = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.groupBy

155+groupByExpr = unsafeMakeAggregate toPrimExpr fromPrimExpr Nothing

127

156

128

157

129-- | Collect expressions values as a list.

158-- | Collect expressions values as a list.

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

138

167

139slistAggExpr :: ()

168slistAggExpr :: ()

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

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

141−slistAggExpr info = unsafeMakeAggregate to fromPrimExpr Opaleye.arrayAgg

170+slistAggExpr info = unsafeMakeAggregate to fromPrimExpr $ Just

171+ Aggregator

172+ { operation = Opaleye.AggrArr

173+ , ordering = []

174+ , distinction = Opaleye.AggrAll

175+ }

142 where

176 where

143 to = encodeArrayElement info . toPrimExpr

177 to = encodeArrayElement info . toPrimExpr

144

178

145

179

146snonEmptyAggExpr :: ()

180snonEmptyAggExpr :: ()

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

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

148−snonEmptyAggExpr info = unsafeMakeAggregate to fromPrimExpr Opaleye.arrayAgg

182+snonEmptyAggExpr info = unsafeMakeAggregate to fromPrimExpr $ Just

183+ Aggregator

184+ { operation = Opaleye.AggrArr

185+ , ordering = []

186+ , distinction = Opaleye.AggrAll

187+ }

149 where

188 where

150 to = encodeArrayElement info . toPrimExpr

189 to = encodeArrayElement info . toPrimExpr

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

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

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

5

6module Rel8.Expr.Num

7− ( fromIntegral

8− , realToFrac

9− , div, mod, divMod

10− , quot, rem, quotRem

11− , ceiling, floor, round, truncate

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

12 )

8 )

13where

9where

14

10

15-- base

11-- base

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

12+import Prelude ()

17

13

18-- rel

14-- rel

19import Rel8.Expr ( Expr( Expr ) )

15import Rel8.Expr ( Expr( Expr ) )

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

21import Rel8.Expr.Function ( function )

16import Rel8.Expr.Function ( function )

22import Rel8.Expr.Opaleye ( castExpr )

17import Rel8.Expr.Opaleye ( castExpr )

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

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

24−import Rel8.Table.Bool ( bool )

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

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

26

20

27

21

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

48ceiling = function "ceiling"

42ceiling = function "ceiling"

49

43

50

44

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

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

52−-- PostgreSQL.

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

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

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

47+div = function "div"

55

48

56

49

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

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

58−-- PostgreSQL.

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

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

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

52+mod = function "mod"

61−

62−

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

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

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

66− where

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

68−

69−

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

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

72−-- 'Prelude.div'.

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

74−quot = function "div"

75−

76−

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

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

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

80−rem = function "mod"

81−

82−

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

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

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

86

53

87

54

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

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

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

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

10 , scastExpr, sunsafeCastExpr

11 , unsafeLiteral

12 , fromPrimExpr, toPrimExpr, mapPrimExpr, zipPrimExprsWith, traversePrimExpr

13− , toColumn, fromColumn, traverseFieldP

13+ , toColumn, fromColumn

14 )

15where

16

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

27import Rel8.Type ( DBType, typeInformation )

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

29

30−-- profunctors

31−import Data.Profunctor ( Profunctor, dimap )

32−

33

30

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

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

35castExpr = scastExpr typeInformation

32castExpr = scastExpr typeInformation

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

83traversePrimExpr f = fmap fromPrimExpr . f . toPrimExpr

80traversePrimExpr f = fmap fromPrimExpr . f . toPrimExpr

84

81

85

82

86−traverseFieldP :: Profunctor p

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

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

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

90−

91−

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

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

93toColumn = Opaleye.Column

84toColumn = Opaleye.Column

94

85

95

86

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

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

97fromColumn (Opaleye.Column a) = a

88fromColumn (Opaleye.Column a) = a

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

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

11import Rel8.Expr ( Expr )

12import Rel8.Expr.Function ( function )

13import Rel8.Expr.Serialize ( litExpr )

14−import Rel8.Expr.Text ( quoteIdent )

15

14

16-- text

15-- text

17import Data.Text ( pack )

16import Data.Text ( pack )

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

19

18

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

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

21nextval :: String -> Expr Int64

20nextval :: String -> Expr Int64

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

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

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

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

17 , pgClientEncoding, quoteIdent, quoteLiteral, quoteNullable, regexpReplace

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

19 , splitPart, strpos, substr, translate

20−

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

22− , like, ilike

23 )

20 )

24where

21where

25

22

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

27import Data.Bool ( Bool )

24import Data.Bool ( Bool )

28import Data.Int ( Int32 )

25import Data.Int ( Int32 )

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

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

30−import Prelude ( flip )

27+import Prelude ()

31

28

32-- bytestring

29-- bytestring

33import Data.ByteString ( ByteString )

30import Data.ByteString ( ByteString )

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

52

49

53

50

54-- | Matches regular expression, case sensitive

51-- | Matches regular expression, case sensitive

55−--

52+--

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

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

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

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

58(~.) = binaryOperator "~."

55(~.) = binaryOperator "~."

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

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

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

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

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

278translate = function "translate"

275translate = function "translate"

279−

280−

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

282−--

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

284−-- you can write expressions like

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

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

287−like = flip (binaryOperator "LIKE")

288−

289−

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

291−--

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

293−-- you can write expressions like

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

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

296−ilike = flip (binaryOperator "ILIKE")

src/Rel8/Expr/Window.hsdeleted−121

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

1−module Rel8.Expr.Window

2− ( cumulative

3− , rowNumber

4− , rank

5− , denseRank

6− , percentRank

7− , cumeDist

8− , ntile

9− , lag

10− , lead

11− , firstValue

12− , lastValue

13− , nthValue

14− )

15−where

16−

17−-- base

18−import Data.Int ( Int32, Int64 )

19−import Prelude

20−

21−-- opaleye

22−import qualified Opaleye.Internal.Aggregate as Opaleye

23−import qualified Opaleye.Internal.PackMap as Opaleye

24−import qualified Opaleye.Internal.Window as Opaleye

25−import qualified Opaleye.Window as Opaleye

26−

27−-- profunctors

28−import Data.Profunctor (dimap)

29−

30−-- rel8

31−import Rel8.Aggregate ( Aggregate( Aggregate ) )

32−import Rel8.Expr ( Expr )

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

34−import Rel8.Schema.Null ( Nullify )

35−import Rel8.Window ( Window( Window ) )

36−

37−

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

39−cumulative f =

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

41−

42−

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

44−rowNumber :: Window a (Expr Int64)

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

46−

47−

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

49−rank :: Window a (Expr Int64)

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

51−

52−

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

54−denseRank :: Window a (Expr Int64)

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

56−

57−

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

59−percentRank :: Window a (Expr Double)

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

61−

62−

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

64−cumeDist :: Window a (Expr Double)

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

66−

67−

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

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

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

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

72−

73−

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

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

76−lag offset def =

77− fromWindowFunction $

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

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

80−

81−

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

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

84−lead offset def =

85− fromWindowFunction $

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

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

88−

89−

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

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

92−firstValue =

93− fromWindowFunction $

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

95− Opaleye.firstValue

96−

97−

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

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

100−lastValue =

101− fromWindowFunction $

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

103− Opaleye.lastValue

104−

105−

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

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

108−nthValue n =

109− fromWindowFunction $

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

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

112−

113−

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

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

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

117−

118−

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

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

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

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

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

1{-# language AllowAmbiguousTypes #-}

2{-# language BlockArguments #-}

3{-# language DataKinds #-}

4−{-# language FlexibleContexts #-}

5{-# language FlexibleInstances #-}

4{-# language FlexibleInstances #-}

6{-# language MultiParamTypeClasses #-}

5{-# language MultiParamTypeClasses #-}

7{-# language RankNTypes #-}

6{-# language RankNTypes #-}

src/Rel8/Generic/Record.hs−2

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

1{-# language AllowAmbiguousTypes #-}

2{-# language DataKinds #-}

3−{-# language FlexibleContexts #-}

4{-# language FlexibleInstances #-}

3{-# language FlexibleInstances #-}

5{-# language MultiParamTypeClasses #-}

4{-# language MultiParamTypeClasses #-}

6{-# language PolyKinds #-}

5{-# language PolyKinds #-}

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

142 uncount = id

141 uncount = id

143

142

144

143

145−type Record :: Type -> Type

146newtype Record a = Record

144newtype Record a = Record

147 { unrecord :: a

145 { unrecord :: a

148 }

146 }

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

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

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

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

65type family a == b where

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

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

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

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

70−

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

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

72 -- which occurs when we have polymorphic Rel8ables

67 -- which occurs when we have polymorphic Rel8ables

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

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

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

146-- [Supplying @Rel8able@ instances]

141-- [Supplying @Rel8able@ instances]

147--

142--

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

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

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

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

150-- extensions:

145-- extensions:

151--

146--

152-- @

147-- @

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

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

1{-# language AllowAmbiguousTypes #-}

2{-# language DataKinds #-}

3−{-# language FlexibleContexts #-}

4{-# language FlexibleInstances #-}

3{-# language FlexibleInstances #-}

5{-# language LambdaCase #-}

4{-# language LambdaCase #-}

6{-# language MultiParamTypeClasses #-}

5{-# language MultiParamTypeClasses #-}

src/Rel8/Order.hs+8−1

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

4

5module Rel8.Order

6 ( Order(..)

7+ , toOrderExprs

7 )

8 )

8where

9where

9

10

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

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

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

17

18

18-- opaleye

19-- opaleye

19−import qualified Opaleye.Order as Opaleye

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

21+import qualified Opaleye.Internal.Order as Opaleye

20

22

21

23

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

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

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

28type Order :: Type -> Type

30type Order :: Type -> Type

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

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

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

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

33+

34+

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

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

37+ uncurry Opaleye.OrderExpr <$> order a

src/Rel8/Query.hs+10−23

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

1−{-# language FlexibleContexts #-}

2{-# language StandaloneKindSignatures #-}

1{-# language StandaloneKindSignatures #-}

3−{-# language UndecidableInstances #-}

4

2

5module Rel8.Query

3module Rel8.Query

6 ( Query( Query )

4 ( Query( Query )

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

17-- opaleye

15-- opaleye

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

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

19import qualified Opaleye.Internal.PackMap as Opaleye

17import qualified Opaleye.Internal.PackMap as Opaleye

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

18+import qualified Opaleye.Internal.PrimQuery as Opaleye

21import qualified Opaleye.Internal.QueryArr as Opaleye

19import qualified Opaleye.Internal.QueryArr as Opaleye

22import qualified Opaleye.Internal.Tag as Opaleye

20import qualified Opaleye.Internal.Tag as Opaleye

23

21

24-- rel8

22-- rel8

25−import Rel8.Expr ( Expr )

26import Rel8.Query.Set ( unionAll )

23import Rel8.Query.Set ( unionAll )

27import Rel8.Query.Opaleye ( fromOpaleye )

24import Rel8.Query.Opaleye ( fromOpaleye )

28import Rel8.Query.Values ( values )

25import Rel8.Query.Values ( values )

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

26+import Rel8.Table ( fromColumns, toColumns )

30import Rel8.Table.Alternative

27import Rel8.Table.Alternative

31 ( AltTable, (<|>:)

28 ( AltTable, (<|>:)

32 , AlternativeTable, emptyTable

29 , AlternativeTable, emptyTable

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

178

175

179

176

180instance Monad Query where

177instance Monad Query where

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

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

182 let

179 let

183− qa = q dummies

180+ Opaleye.QueryArr qa = q dummies

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

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

185 Query q' = f a

182 Query q' = f a

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

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

187 ( dummy : dummies

184 ( dummy : dummies

188− , query <> Opaleye.aRebind bindings

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

189 , Opaleye.next tag'

186 , Opaleye.next tag'

190 )

187 )

191 where

188 where

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

193 where

190 where

194 random = Opaleye.FunExpr "random" []

191 random = Opaleye.FunExpr "random" []

195 name = Opaleye.extractAttr "dummy" tag'

192 name = Opaleye.extractAttr "dummy" tag'

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

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

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

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

198 query'''

195 query'''

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

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

200− | otherwise = query <> query''

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

201 m'' = m <> m'

198 m'' = m <> m'

202 in

199 in

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

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

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

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

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

212instance AlternativeTable Query where

209instance AlternativeTable Query where

213 emptyTable = values []

210 emptyTable = values []

214−

215−

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

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

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

219−

220−

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

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

223− mempty = emptyTable

src/Rel8/Query/Aggregate.hs−19

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

1{-# language FlexibleContexts #-}

2{-# language MonoLocalBinds #-}

3−{-# language ScopedTypeVariables #-}

4−{-# language TypeApplications #-}

5

3

6module Rel8.Query.Aggregate

4module Rel8.Query.Aggregate

7 ( aggregate

5 ( aggregate

8 , countRows

6 , countRows

9− , mode

10 )

7 )

11where

8where

12

9

13-- base

10-- base

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

15import Data.Int ( Int64 )

11import Data.Int ( Int64 )

16import Prelude

12import Prelude

17

13

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

22import Rel8.Aggregate ( Aggregates )

18import Rel8.Aggregate ( Aggregates )

23import Rel8.Expr ( Expr )

19import Rel8.Expr ( Expr )

24import Rel8.Expr.Aggregate ( countStar )

20import Rel8.Expr.Aggregate ( countStar )

25−import Rel8.Expr.Order ( desc )

26import Rel8.Query ( Query )

21import Rel8.Query ( Query )

27−import Rel8.Query.Limit ( limit )

28import Rel8.Query.Maybe ( optional )

22import Rel8.Query.Maybe ( optional )

29import Rel8.Query.Opaleye ( mapOpaleye )

23import Rel8.Query.Opaleye ( mapOpaleye )

30−import Rel8.Query.Order ( orderBy )

31−import Rel8.Table ( toColumns )

32−import Rel8.Table.Aggregate ( hgroupBy )

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

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

35import Rel8.Table.Opaleye ( aggregator )

24import Rel8.Table.Opaleye ( aggregator )

36import Rel8.Table.Maybe ( maybeTable )

25import Rel8.Table.Maybe ( maybeTable )

37

26

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

46-- will return @0@.

35-- will return @0@.

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

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

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

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

49−

50−

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

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

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

54− aggregate $ do

55− row <- toColumns <$> rows

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

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

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

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

2+

1module Rel8.Query.Distinct

3module Rel8.Query.Distinct

2 ( distinct

4 ( distinct

3 , distinctOn

5 , distinctOn

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

6where

8where

7

9

8-- base

10-- base

9−import Prelude ()

11+import Prelude

10

12

11-- opaleye

13-- opaleye

12import qualified Opaleye.Distinct as Opaleye

14import qualified Opaleye.Distinct as Opaleye

13−import qualified Opaleye.Order as Opaleye

15+import qualified Opaleye.Internal.Order as Opaleye

16+import qualified Opaleye.Internal.QueryArr as Opaleye

14

17

15-- rel8

18-- rel8

16import Rel8.Order ( Order( Order ) )

19import Rel8.Order ( Order( Order ) )

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

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

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

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

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

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

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

36+distinctOn proj =

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

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

34

38

35

39

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

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

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

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

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

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

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

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

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

44+distinctOnBy proj (Order order) =

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

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

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

3

4module Rel8.Query.Evaluate

5 ( evaluate

6+ , rebind

6 )

7 )

7where

8where

8

9

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

15

16

16-- opaleye

17-- opaleye

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

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

19+import qualified Opaleye.Internal.PackMap as Opaleye

20+import qualified Opaleye.Internal.PrimQuery as Opaleye

21+import qualified Opaleye.Internal.QueryArr as Opaleye

22+import qualified Opaleye.Internal.Tag as Opaleye

23+import qualified Opaleye.Internal.Unpackspec as Opaleye

18

24

19-- rel8

25-- rel8

20import Rel8.Expr ( Expr )

26import Rel8.Expr ( Expr )

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

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

22import Rel8.Expr.Opaleye ( fromPrimExpr )

28import Rel8.Expr.Opaleye ( fromPrimExpr )

23import Rel8.Query ( Query( Query ) )

29import Rel8.Query ( Query( Query ) )

24−import Rel8.Query.Rebind ( rebind )

25import Rel8.Table ( Table )

30import Rel8.Table ( Table )

26import Rel8.Table.Bool ( case_ )

31import Rel8.Table.Bool ( case_ )

27−import Rel8.Table.Undefined ( undefined )

32+import Rel8.Table.Opaleye ( unpackspec )

33+import Rel8.Table.Undefined

28

34

29

35

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

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

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

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

32-- effects and can safely be reused.

38-- effects and can safely be reused.

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

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

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

40+evaluate = laterally >=> rebind

35

41

36

42

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

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

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

45 go = fromPrimExpr . Opaleye.UnExpr Opaleye.OpIsNotNull

51 go = fromPrimExpr . Opaleye.UnExpr Opaleye.OpIsNotNull

46

52

47

53

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

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

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

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

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

59+ let

60+ tag' = Opaleye.next tag

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

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

63+ in

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

65+

66+

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

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

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

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

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

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

12

13-- opaleye

14import qualified Opaleye.Exists as Opaleye

15−import qualified Opaleye.Operators as Opaleye

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

16

17-- rel8

18import Rel8.Expr ( Expr )

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

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

4where

5

6-- base

7−import Control.Applicative ( liftA2 )

8import Data.Int ( Int64 )

7import Data.Int ( Int64 )

9import Prelude

8import Prelude

10

9

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+

11-- rel8

17-- rel8

12import Rel8.Expr ( Expr )

18import Rel8.Expr ( Expr )

13−import Rel8.Expr.Window ( rowNumber )

19+import Rel8.Expr.Opaleye ( fromPrimExpr )

14import Rel8.Query ( Query )

20import Rel8.Query ( Query )

15−import Rel8.Query.Window ( window )

21+import Rel8.Query.Opaleye ( mapOpaleye )

16−import Rel8.Table.Window ( currentRow )

17

22

18

23

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

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

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

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

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

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

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/List.hs+7−9

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

24import Rel8.Expr.Opaleye ( mapPrimExpr )

25import Rel8.Query ( Query )

26import Rel8.Query.Aggregate ( aggregate )

27+import Rel8.Query.Evaluate ( rebind )

27import Rel8.Query.Maybe ( optional )

28import Rel8.Query.Maybe ( optional )

28−import Rel8.Query.Rebind ( rebind )

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

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

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

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

85--

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

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

88−catListTable (ListTable as) =

89− rebind "unnest" $ fromColumns $ runIdentity $

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

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

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

91

90

92

91

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

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

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

95--

94--

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

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

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

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

98−catNonEmptyTable (NonEmptyTable as) =

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

99− rebind "unnest" $ fromColumns $ runIdentity $

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

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

101

99

102

100

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

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

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

105--

103--

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

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

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

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

108−catList = rebind "unnest" . sunnest typeInformation

106+catList = rebind . sunnest typeInformation

109

107

110

108

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

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

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

113--

111--

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

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

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

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

116−catNonEmpty = rebind "unnest" . sunnest typeInformation

114+catNonEmpty = rebind . sunnest typeInformation

117

115

118

116

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

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

src/Rel8/Query/Null.hs−15

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

1−{-# language FlexibleContexts #-}

2−

3module Rel8.Query.Null

1module Rel8.Query.Null

4 ( catNull

2 ( catNull

5− , catNullTable

6 )

3 )

7where

4where

8

5

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

12-- rel8

9-- rel8

13import Rel8.Expr ( Expr )

10import Rel8.Expr ( Expr )

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

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

15−import Rel8.Table ( Table )

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

17import Rel8.Query ( Query )

12import Rel8.Query ( Query )

18import Rel8.Query.Filter ( where_ )

13import Rel8.Query.Filter ( where_ )

19

14

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

26catNull a = do

21catNull a = do

27 where_ $ isNonNull a

22 where_ $ isNonNull a

28 pure $ unsafeUnnullify a

23 pure $ unsafeUnnullify a

29−

30−

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

32−-- @nullTable@s.

33−--

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

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

36−catNullTable a = do

37− where_ $ isNonNullTable a

38− pure $ unsafeUnnullifyTable a

src/Rel8/Query/Opaleye.hs+11−11

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

41

42unsafePeekQuery :: Query a -> a

43unsafePeekQuery (Query q) = case q mempty of

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

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

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

46

47

48mapping :: ()

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

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

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

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

52 let

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

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

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

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

55 in

56− Opaleye.runStateQueryArr q' () tag

56+ qa' ((), tag)

57

58

59zipping :: Semigroup m

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

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

62−zipping f q q' =

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

63− Opaleye.stateQueryArr $ \_ tag ->

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

64 let

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

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

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

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

67 m'' = m <> m'

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

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

69 in

70− Opaleye.runStateQueryArr q'' () tag

70+ qa'' ((), tag)

src/Rel8/Query/Rebind.hsdeleted−27

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

1−{-# language FlexibleContexts #-}

2−

3−module Rel8.Query.Rebind

4− ( rebind

5− )

6−where

7−

8−-- base

9−import Prelude

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

11−

12−-- opaleye

13−import qualified Opaleye.Internal.Rebind as Opaleye

14−

15−-- rel8

16−import Rel8.Expr ( Expr )

17−import Rel8.Query ( Query )

18−import Rel8.Table ( Table )

19−import Rel8.Table.Opaleye ( unpackspec )

20−import Rel8.Query.Opaleye (fromOpaleye)

21−

22−

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

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

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

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

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

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

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

23

24

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

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

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

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

28union = zipOpaleyeWith (Opaleye.unionExplicit binaryspec)

29

30

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

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

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

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

34unionAll = zipOpaleyeWith (Opaleye.unionAllExplicit binaryspec)

35

36

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

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

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

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

40intersect = zipOpaleyeWith (Opaleye.intersectExplicit binaryspec)

41

42

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

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

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

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

46intersectAll = zipOpaleyeWith (Opaleye.intersectAllExplicit binaryspec)

47

48

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

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

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

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

52except = zipOpaleyeWith (Opaleye.exceptExplicit binaryspec)

53

54

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

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

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

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

58exceptAll = zipOpaleyeWith (Opaleye.exceptAllExplicit binaryspec)

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

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

48alignBy :: ()

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

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

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

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

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

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

53 where

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

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

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

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

56 MaybeTable hasHere a = ma

57 MaybeTable hasThere b = mb

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

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

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

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

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

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

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

64 where

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

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

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

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

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

68 ma' = MaybeTable hasHere' a

69 mb' = MaybeTable hasThere' b

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

71− join' = Opaleye.aProduct join

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

72

73

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

src/Rel8/Query/Window.hsdeleted−26

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

1−module Rel8.Query.Window

2− ( window

3− )

4−where

5−

6−-- base

7−import Prelude ()

8−

9−-- opaleye

10−import qualified Opaleye.Window as Opaleye

11−

12−-- rel8

13−import Rel8.Query ( Query )

14−import Rel8.Query.Opaleye ( mapOpaleye )

15−import Rel8.Window ( Window( Window ) )

16−

17−

18−-- | 'window' runs a query composed of expressions containing

19−-- [window functions](https://www.postgresql.org/docs/current/tutorial-window.html).

20−-- 'window' is similar to 'Rel8.aggregate', with the main difference being

21−-- that in a window query, each input row corresponds to one output row,

22−-- whereas aggregation queries fold the entire input query down into a single

23−-- row. To put this into a Haskell context, 'Rel8.aggregate' is to 'foldl' as

24−-- 'window' is to 'scanl'.

25−window :: Window a b -> Query a -> Query b

26−window (Window a) = mapOpaleye (Opaleye.runWindows a)

src/Rel8/Schema/Context/Nullify.hs+14−6

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

18import Data.Bool ( bool )

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

20import Data.Kind ( Constraint, Type )

21+import Data.Monoid ( getFirst )

21import Prelude hiding ( null )

22import Prelude hiding ( null )

22

23

23-- opaleye

24-- opaleye

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

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

25

26

26-- rel8

27-- rel8

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

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

28import Rel8.Expr ( Expr )

29import Rel8.Expr ( Expr )

29import Rel8.Expr.Bool ( boolExpr )

30import Rel8.Expr.Bool ( boolExpr )

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

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

31−import Rel8.Expr.Opaleye ( fromPrimExpr )

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

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

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

33import Rel8.Schema.Field ( Field )

34import Rel8.Schema.Field ( Field )

34import qualified Rel8.Schema.Kind as K

35import qualified Rel8.Schema.Kind as K

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

94 -> context (Maybe a)

95 -> context (Maybe a)

96 -> context (Maybe a)

96guarder = \case

97guarder = \case

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

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

99+ let

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

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

102+ in

103+ mapInputs (toPrimExpr . run . fromPrimExpr) $

104+ Aggregate $

105+ run <$> a

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

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

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

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

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

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

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

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

102 Identity (bool Nothing a (isNonNull tag))

110 Identity (bool Nothing a (isNonNull tag))

103

111

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

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

16module Rel8.Schema.HTable

17 ( HTable (HField, HConstrainTable)

18 , hfield, htabulate, htraverse, hdicts, hspecs

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

19+ , hmap, htabulateA

20 )

21where

22

23-- base

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

25import Data.Kind ( Constraint, Type )

24import Data.Kind ( Constraint, Type )

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

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

27import Data.Proxy ( Proxy )

26import Data.Proxy ( Proxy )

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

33 )

32 )

34import Prelude

33import Prelude

35

34

36−-- profunctors

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

38−

39−-- product-profunctors

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

41−

42-- rel8

35-- rel8

43import Rel8.Schema.Dict ( Dict )

36import Rel8.Schema.Dict ( Dict )

44import Rel8.Schema.Spec ( Spec )

37import Rel8.Schema.Spec ( Spec )

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

48-- semigroupoids

41-- semigroupoids

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

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

50

43

44+

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

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

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

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

53-- specified ('hspecs').

47-- specified ('hspecs').

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

120 {-# INLINABLE hspecs #-}

114 {-# INLINABLE hspecs #-}

121

115

122

116

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

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

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

126−

127−

128hmap :: HTable t

117hmap :: HTable t

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

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

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

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

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

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

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

136{-# INLINABLE htabulateA #-}

125{-# INLINABLE htabulateA #-}

137

126

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

139−

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

141− fmap f = ApplyP . rmap f . unApplyP

142−

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

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

145−

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

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

148−htraverseP f = htraversePWithField (const f)

149−

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

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

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

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

154

127

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

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

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

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

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

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

22 , hvectorize, hunvectorize

23 , happend, hempty

24 , hproject

25− , hcolumn

26 )

25 )

27where

26where

28

27

29-- base

28-- base

30−import Data.Kind ( Constraint, Type )

29+import Data.Kind ( Type )

31import Data.List.NonEmpty ( NonEmpty )

30import Data.List.NonEmpty ( NonEmpty )

32import GHC.Generics (Generic)

31import GHC.Generics (Generic)

33import Prelude

32import Prelude

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

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

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

38import qualified Rel8.Schema.Kind as K

37import qualified Rel8.Schema.Kind as K

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

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

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

41import Rel8.Schema.HTable.MapTable

39import Rel8.Schema.HTable.MapTable

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

40+ ( HMapTable, HMapTableField( HMapTableField )

43 , MapSpec, mapInfo

41 , MapSpec, mapInfo

44− , Precompose( Precompose )

45 )

42 )

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

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

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

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

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

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

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

54

51

55

52

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

57class Vector list where

53class Vector list where

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

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

59 vectorTypeInformation :: ()

55 vectorTypeInformation :: ()

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

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

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

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

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

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

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

140−

141−

142−hcolumn :: HVectorize list (HIdentity a) context -> context (list a)

143−hcolumn (HVectorize (HMapTable (HIdentity (Precompose a)))) = a

src/Rel8/Schema/Table.hs−3

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

2{-# language DerivingStrategies #-}

3{-# language DisambiguateRecordFields #-}

4{-# language NamedFieldPuns #-}

5−{-# language StandaloneKindSignatures #-}

6

5

7module Rel8.Schema.Table

6module Rel8.Schema.Table

8 ( TableSchema(..)

7 ( TableSchema(..)

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

11where

10where

12

11

13-- base

12-- base

14−import Data.Kind ( Type )

15import Prelude

13import Prelude

16

14

17-- opaleye

15-- opaleye

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

28--

26--

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

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

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

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

31−type TableSchema :: Type -> Type

32data TableSchema names = TableSchema

29data TableSchema names = TableSchema

33 { name :: String

30 { name :: String

34 -- ^ The name of the table.

31 -- ^ The name of the table.

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

@@ -3,7 +3,6 @@

3{-# language FlexibleContexts #-}

4{-# language MonoLocalBinds #-}

5{-# language ScopedTypeVariables #-}

6−{-# language StandaloneKindSignatures #-}

7{-# language TypeApplications #-}

6{-# language TypeApplications #-}

8

7

9module Rel8.Statement.Select

8module Rel8.Statement.Select

@@ -18,7 +17,7 @@ where

18

17

19-- base

18-- base

20import Data.Foldable ( toList )

19import Data.Foldable ( toList )

21−import Data.Kind ( Type )

20+import Data.List.NonEmpty ( NonEmpty( (:|) ) )

22import Data.Void ( Void )

21import Data.Void ( Void )

23import Prelude hiding ( undefined )

22import Prelude hiding ( undefined )

24

23

@@ -91,7 +90,7 @@ ppSelect query =

91ppRows :: Table Expr a => Query a -> Doc

90ppRows :: Table Expr a => Query a -> Doc

92ppRows query = case optimize primQuery of

91ppRows query = case optimize primQuery of

93 -- Special case VALUES because we can't use DEFAULT inside a SELECT

92 -- Special case VALUES because we can't use DEFAULT inside a SELECT

94− Optimized (Opaleye.Values symbols rows)

93+ Optimized (Opaleye.Product ((_, Opaleye.Values symbols rows) :| []) [])

95 | eqSymbols symbols (toList (T.exprs a)) ->

94 | eqSymbols symbols (toList (T.exprs a)) ->

96 Opaleye.ppValues_ (map Opaleye.sqlExpr <$> toList rows)

95 Opaleye.ppValues_ (map Opaleye.sqlExpr <$> toList rows)

97 _ -> ppSelect query

96 _ -> ppSelect query

@@ -117,9 +116,8 @@ ppPrimSelect query =

117 (a, primQuery, _) = Opaleye.runSimpleQueryArrStart (toOpaleye query) ()

116 (a, primQuery, _) = Opaleye.runSimpleQueryArrStart (toOpaleye query) ()

118

117

119

118

120−type Optimized :: Type -> Type

121data Optimized a = Empty | Unit | Optimized a

119data Optimized a = Empty | Unit | Optimized a

122− deriving stock (Functor, Foldable, Traversable, Show)

120+ deriving stock (Functor, Foldable, Traversable)

123

121

124

122

125optimize :: Opaleye.PrimQuery' a -> Optimized (Opaleye.PrimQuery' Void)

123optimize :: Opaleye.PrimQuery' a -> Optimized (Opaleye.PrimQuery' Void)

src/Rel8/Statement/View.hs+5−30

@@ -3,7 +3,6 @@

3

4module Rel8.Statement.View

5 ( createView

6− , createOrReplaceView

7 )

6 )

8where

7where

9

8

@@ -30,49 +29,25 @@ import qualified Data.Text as Text

30import Data.Text.Encoding ( encodeUtf8 )

29import Data.Text.Encoding ( encodeUtf8 )

31

30

32

31

33−data CreateView = Create | CreateOrReplace

34−

35−

36-- | Given a 'TableSchema' and 'Query', @createView@ runs a @CREATE VIEW@

32-- | Given a 'TableSchema' and 'Query', @createView@ runs a @CREATE VIEW@

37-- statement that will save the given query as a view. This can be useful if

33-- statement that will save the given query as a view. This can be useful if

38-- you want to share Rel8 queries with other applications.

34-- you want to share Rel8 queries with other applications.

39createView :: Selects names exprs

35createView :: Selects names exprs

40 => TableSchema names -> Query exprs -> Hasql.Statement () ()

36 => TableSchema names -> Query exprs -> Hasql.Statement () ()

41−createView =

42− createViewGeneric Create

43−

44−

45−-- | Given a 'TableSchema' and 'Query', @createOrReplaceView@ runs a

46−-- @CREATE OR REPLACE VIEW@ statement that will save the given query

47−-- as a view, replacing the current view definition if it exists and

48−-- adheres to the restrictions in place for replacing a view in

49−-- PostgreSQL.

50−createOrReplaceView :: Selects names exprs

51− => TableSchema names -> Query exprs -> Hasql.Statement () ()

52−createOrReplaceView =

53− createViewGeneric CreateOrReplace

54−

55−

56−createViewGeneric :: Selects names exprs

57− => CreateView -> TableSchema names -> Query exprs -> Hasql.Statement () ()

58−createViewGeneric replace schema query =

59− Hasql.Statement bytes params decode prepare

37+createView schema query = Hasql.Statement bytes params decode prepare

60 where

38 where

61 bytes = encodeUtf8 (Text.pack sql)

39 bytes = encodeUtf8 (Text.pack sql)

62 params = Hasql.noParams

40 params = Hasql.noParams

63 decode = Hasql.noResult

41 decode = Hasql.noResult

64 prepare = False

42 prepare = False

65 sql = show doc

43 sql = show doc

66− doc = ppCreateView schema query replace

44+ doc = ppCreateView schema query

67

45

68

46

69ppCreateView :: Selects names exprs

47ppCreateView :: Selects names exprs

70− => TableSchema names -> Query exprs -> CreateView -> Doc

48+ => TableSchema names -> Query exprs -> Doc

71−ppCreateView schema query replace =

49+ppCreateView schema query =

72− createOrReplace replace <+>

50+ text "CREATE VIEW" <+>

73 ppInto schema $$

51 ppInto schema $$

74 text "AS" <+>

52 text "AS" <+>

75 ppSelect query

53 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,18 +37,6 @@ import Rel8.Type.Eq ( DBEq )

37

38-- | Group equal tables together. This works by aggregating each column in the

39-- given table with 'groupByExpr'.

40−--

41−-- For example, if we have a table of items, we could group the items by the

42−-- order they belong to:

43−--

44−-- @

45−-- itemsByOrder :: Query (OrderId Expr, ListTable Expr (Item Expr))

46−-- itemsByOrder = aggregate $ do

47−-- item <- each itemSchema

48−-- let orderId = groupBy (itemOrderId item)

49−-- let orderItems = listAgg item

50−-- pure (orderId, orderItems)

51−-- @

52groupBy :: forall exprs aggregates. (EqTable exprs, Aggregates aggregates exprs)

40groupBy :: forall exprs aggregates. (EqTable exprs, Aggregates aggregates exprs)

53 => exprs -> aggregates

41 => exprs -> aggregates

54groupBy = fromColumns . hgroupBy (eqTable @exprs) . toColumns

42groupBy = fromColumns . hgroupBy (eqTable @exprs) . toColumns

src/Rel8/Table/HKD.hs−1

@@ -157,7 +157,6 @@ instance

157 => HKDable a

158

159

160−type Top_ :: Constraint

161class Top_

160class Top_

162instance Top_

161instance Top_

163

162

src/Rel8/Table/List.hs+3−14

@@ -11,9 +11,7 @@

11

12module Rel8.Table.List

13 ( ListTable(..)

14− , ($*)

15− , listTable

16− , nameListTable

14+ , listTable, nameListTable

17 )

15 )

18where

16where

19

17

@@ -30,7 +28,7 @@ import Rel8.Schema.HTable.List ( HListTable )

30import Rel8.Schema.HTable.Vectorize

28import Rel8.Schema.HTable.Vectorize

31 ( hvectorize, hunvectorize

29 ( hvectorize, hunvectorize

32 , happend, hempty

30 , happend, hempty

33− , hproject, hcolumn

31+ , hproject

34 )

32 )

35import qualified Rel8.Schema.Kind as K

33import qualified Rel8.Schema.Kind as K

36import Rel8.Schema.Name ( Name( Name ) )

34import Rel8.Schema.Name ( Name( Name ) )

@@ -48,9 +46,7 @@ import Rel8.Table.Alternative

48 )

46 )

49import Rel8.Table.Eq ( EqTable, eqTable )

47import Rel8.Table.Eq ( EqTable, eqTable )

50import Rel8.Table.Ord ( OrdTable, ordTable )

48import Rel8.Table.Ord ( OrdTable, ordTable )

51−import Rel8.Table.Projection

49+import Rel8.Table.Projection ( Projectable, project, apply )

52− ( Projectable, Projecting, Projection, project, apply

53− )

54import Rel8.Table.Serialize ( ToExprs )

50import Rel8.Table.Serialize ( ToExprs )

55

51

56

52

@@ -120,13 +116,6 @@ instance (context ~ Expr, Table Expr a) =>

120 mempty = ListTable $ hempty $ \Spec {info} -> sempty info

116 mempty = ListTable $ hempty $ \Spec {info} -> sempty info

121

117

122

118

123−-- | Project a single expression out of a 'ListTable'.

124−($*) :: Projecting a (Expr b)

125− => Projection a (Expr b) -> ListTable Expr a -> Expr [b]

126−f $* ListTable a = hcolumn $ hproject (apply f) a

127−infixl 4 $*

128−

129−

130-- | Construct a @ListTable@ from a list of expressions.

119-- | Construct a @ListTable@ from a list of expressions.

131listTable :: Table Expr a => [a] -> ListTable Expr a

120listTable :: Table Expr a => [a] -> ListTable Expr a

132listTable =

121listTable =

src/Rel8/Table/Maybe.hs−6

@@ -15,7 +15,6 @@ module Rel8.Table.Maybe

15 ( MaybeTable(..)

16 , maybeTable, nothingTable, justTable

17 , isNothingTable, isJustTable

18− , fromMaybeTable

19 , ($?)

18 , ($?)

20 , aggregateMaybeTable

19 , aggregateMaybeTable

21 , nameMaybeTable

20 , nameMaybeTable

@@ -207,11 +206,6 @@ justTable :: a -> MaybeTable Expr a

207justTable = MaybeTable mempty . pure

206justTable = MaybeTable mempty . pure

208

207

209

208

210−-- | 'Data.Maybe.fromMaybe' for 'MaybeTable's.

211−fromMaybeTable :: Table Expr a => a -> MaybeTable Expr a -> a

212−fromMaybeTable fallback = maybeTable fallback id

213−

214−

215-- | Project a single expression out of a 'MaybeTable'. You can think of this

209-- | Project a single expression out of a 'MaybeTable'. You can think of this

216-- operator like the '$' operator, but it also has the ability to return

210-- operator like the '$' operator, but it also has the ability to return

217-- @null@.

211-- @null@.

src/Rel8/Table/NonEmpty.hs+3−14

@@ -11,9 +11,7 @@

11

12module Rel8.Table.NonEmpty

13 ( NonEmptyTable(..)

14− , ($+)

15− , nonEmptyTable

16− , nameNonEmptyTable

14+ , nonEmptyTable, nameNonEmptyTable

17 )

15 )

18where

16where

19

17

@@ -31,7 +29,7 @@ import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable )

31import Rel8.Schema.HTable.Vectorize

29import Rel8.Schema.HTable.Vectorize

32 ( hvectorize, hunvectorize

30 ( hvectorize, hunvectorize

33 , happend

31 , happend

34− , hproject, hcolumn

32+ , hproject

35 )

33 )

36import qualified Rel8.Schema.Kind as K

34import qualified Rel8.Schema.Kind as K

37import Rel8.Schema.Name ( Name( Name ) )

35import Rel8.Schema.Name ( Name( Name ) )

@@ -46,9 +44,7 @@ import Rel8.Table

46import Rel8.Table.Alternative ( AltTable, (<|>:) )

44import Rel8.Table.Alternative ( AltTable, (<|>:) )

47import Rel8.Table.Eq ( EqTable, eqTable )

45import Rel8.Table.Eq ( EqTable, eqTable )

48import Rel8.Table.Ord ( OrdTable, ordTable )

46import Rel8.Table.Ord ( OrdTable, ordTable )

49−import Rel8.Table.Projection

47+import Rel8.Table.Projection ( Projectable, project, apply )

50− ( Projectable, Projecting, Projection, project, apply

51− )

52import Rel8.Table.Serialize ( ToExprs )

48import Rel8.Table.Serialize ( ToExprs )

53

49

54

50

@@ -114,13 +110,6 @@ instance (Table Expr a, context ~ Expr) => Semigroup (NonEmptyTable context a)

114 happend (const sappend1) as bs

110 happend (const sappend1) as bs

115

111

116

112

117−-- | Project a single expression out of a 'NonEmptyTable'.

118−($+) :: Projecting a (Expr b)

119− => Projection a (Expr b) -> NonEmptyTable Expr a -> Expr (NonEmpty b)

120−f $+ NonEmptyTable a = hcolumn $ hproject (apply f) a

121−infixl 4 $+

122−

123−

124-- | Construct a @NonEmptyTable@ from a non-empty list of expressions.

113-- | Construct a @NonEmptyTable@ from a non-empty list of expressions.

125nonEmptyTable :: Table Expr a => NonEmpty a -> NonEmptyTable Expr a

114nonEmptyTable :: Table Expr a => NonEmpty a -> NonEmptyTable Expr a

126nonEmptyTable =

115nonEmptyTable =

src/Rel8/Table/Null.hsdeleted−147

@@ -1,147 +0,0 @@

1−{-# language DataKinds #-}

2−{-# language FlexibleContexts #-}

3−{-# language FlexibleInstances #-}

4−{-# language MultiParamTypeClasses #-}

5−{-# language ScopedTypeVariables #-}

6−{-# language StandaloneKindSignatures #-}

7−{-# language TypeApplications #-}

8−{-# language TypeFamilies #-}

9−{-# language UndecidableInstances #-}

10−

11−module Rel8.Table.Null

12− ( NullTable(..)

13− , nullableTable, nullTable, nullifyTable, unsafeUnnullifyTable

14− , isNullTable, isNonNullTable

15− , nameNullTable

16− , toMaybeTable, toNullTable

17− )

18−where

19−

20−-- base

21−import Data.Kind ( Type )

22−import Prelude hiding ( null, undefined )

23−

24−-- comonad

25−import Control.Comonad ( extract )

26−

27−-- rel8

28−import Rel8.Expr ( Expr )

29−import Rel8.Expr.Bool ( not_ )

30−import Rel8.Kind.Context ( Reifiable )

31−import qualified Rel8.Schema.Kind as K

32−import Rel8.Schema.Name ( Name )

33−import Rel8.Table

34− ( Table, Columns, Context, fromColumns, toColumns

35− , FromExprs, fromResult, toResult

36− , Transpose

37− )

38−import Rel8.Table.Alternative

39− ( AltTable, (<|>:)

40− , AlternativeTable, emptyTable

41− )

42−import Rel8.Table.Bool ( bool )

43−import Rel8.Table.Eq ( EqTable, eqTable )

44−import Rel8.Table.Maybe ( MaybeTable, justTable, maybeTable, nothingTable )

45−import Rel8.Table.Nullify ( Nullify, isNull )

46−import Rel8.Table.Ord ( OrdTable, ordTable )

47−import Rel8.Table.Projection ( Projectable, project )

48−import Rel8.Table.Serialize ( ToExprs )

49−import Rel8.Table.Undefined ( undefined )

50−

51−

52−-- | @NullTable t@ is the table @t@, but where all the columns in @t@ have the

53−-- possibility of being 'Rel8.null'. This is very similar to

54−-- 'Rel8.MaybeTable', except that it does not use an extra tag field, so it

55−-- cannot distinguish between @Nothing@ and @Just Nothing@ if nested. In other

56−-- words, if all of the columns of the @t@ passed to @NullTable@ are already

57−-- nullable, then @NullTable@ has no effect.

58−type NullTable :: K.Context -> Type -> Type

59−newtype NullTable context a = NullTable (Nullify context a)

60−

61−

62−instance Projectable (NullTable context) where

63− project f (NullTable a) = NullTable (project f a)

64−

65−

66−instance context ~ Expr => AltTable (NullTable context) where

67− ma <|>: mb = bool ma mb (isNullTable ma)

68−

69−

70−instance context ~ Expr => AlternativeTable (NullTable context) where

71− emptyTable = nullTable

72−

73−

74−instance (Table context a, Reifiable context, context ~ context') =>

75− Table context' (NullTable context a)

76− where

77− type Columns (NullTable context a) = Columns (Nullify context a)

78− type Context (NullTable context a) = Context (Nullify context a)

79− type FromExprs (NullTable context a) = FromExprs (Nullify context a)

80− type Transpose to (NullTable context a) = NullTable to (Transpose to a)

81−

82− toColumns (NullTable a) = toColumns a

83− fromColumns = NullTable . fromColumns

84−

85− toResult = toResult @_ @(Nullify context a)

86− fromResult = fromResult @_ @(Nullify context a)

87−

88−

89−instance (EqTable a, context ~ Expr) => EqTable (NullTable context a) where

90− eqTable = eqTable @(Nullify context a)

91−

92−

93−instance (OrdTable a, context ~ Expr) => OrdTable (NullTable context a) where

94− ordTable = ordTable @(Nullify context a)

95−

96−

97−instance (ToExprs exprs a, context ~ Expr) =>

98− ToExprs (NullTable context exprs) (Maybe a)

99−

100−

101−-- | Check if any of the non-nullable fields of @a@ are 'Rel8.null' under the

102−-- 'NullTable'. Returns 'Rel8.false' if @a@ has no non-nullable fields.

103−isNullTable :: Table Expr a => NullTable Expr a -> Expr Bool

104−isNullTable (NullTable a) = isNull a

105−

106−

107−-- | The inverse of 'isNullTable'.

108−isNonNullTable :: Table Expr a => NullTable Expr a -> Expr Bool

109−isNonNullTable = not_ . isNullTable

110−

111−

112−-- | Like 'Rel8.nullable'.

113−nullableTable :: (Table Expr a, Table Expr b)

114− => b -> (a -> b) -> NullTable Expr a -> b

115−nullableTable b f ma@(NullTable a) = bool (f (extract a)) b (isNullTable ma)

116−

117−

118−-- | The null table. Like 'Rel8.null'.

119−nullTable :: Table Expr a => NullTable Expr a

120−nullTable = NullTable (pure undefined)

121−

122−

123−-- | Lift any table into 'NullTable'. Like 'Rel8.nullify'.

124−nullifyTable :: a -> NullTable Expr a

125−nullifyTable = NullTable . pure

126−

127−

128−unsafeUnnullifyTable :: NullTable Expr a -> a

129−unsafeUnnullifyTable (NullTable a) = extract a

130−

131−

132−-- | Construct a 'NullTable' in the 'Name' context. This can be useful if you

133−-- have a 'NullTable' that you are storing in a table and need to construct a

134−-- 'TableSchema'.

135−nameNullTable :: a -> NullTable Name a

136−nameNullTable = NullTable . pure

137−

138−

139−-- | Convert a 'NullTable' to a 'MaybeTable'.

140−toMaybeTable :: Table Expr a => NullTable Expr a -> MaybeTable Expr a

141−toMaybeTable = nullableTable nothingTable justTable

142−

143−

144−-- | Convert a 'MaybeTable' to a 'NullTable'. Note that if the underlying @a@

145−-- has no non-nullable fields, this is a lossy conversion.

146−toNullTable :: Table Expr a => MaybeTable Expr a -> NullTable Expr a

147−toNullTable = maybeTable nullTable nullifyTable

src/Rel8/Table/Nullify.hs−27

@@ -1,9 +1,7 @@

1{-# language DataKinds #-}

2−{-# language FlexibleContexts #-}

3{-# language FlexibleInstances #-}

2{-# language FlexibleInstances #-}

4{-# language LambdaCase #-}

3{-# language LambdaCase #-}

5{-# language MultiParamTypeClasses #-}

4{-# language MultiParamTypeClasses #-}

6−{-# language NamedFieldPuns #-}

7{-# language ScopedTypeVariables #-}

5{-# language ScopedTypeVariables #-}

8{-# language StandaloneKindSignatures #-}

6{-# language StandaloneKindSignatures #-}

9{-# language TypeApplications #-}

7{-# language TypeApplications #-}

@@ -14,13 +12,11 @@ module Rel8.Table.Nullify

14 ( Nullify

12 ( Nullify

15 , aggregateNullify

13 , aggregateNullify

16 , guard

14 , guard

17− , isNull

18 )

15 )

19where

16where

20

17

21-- base

18-- base

22import Control.Applicative ( liftA2 )

19import Control.Applicative ( liftA2 )

23−import Data.Functor.Const ( Const( Const ), getConst )

24import Data.Functor.Identity ( runIdentity )

20import Data.Functor.Identity ( runIdentity )

25import Data.Kind ( Type )

21import Data.Kind ( Type )

26import Prelude

22import Prelude

@@ -31,8 +27,6 @@ import Control.Comonad ( Comonad, duplicate, extract, ComonadApply, (<@>) )

31-- rel8

27-- rel8

32import Rel8.Aggregate ( Aggregate )

28import Rel8.Aggregate ( Aggregate )

33import Rel8.Expr ( Expr )

29import Rel8.Expr ( Expr )

34−import Rel8.Expr.Bool ( (||.), false )

35−import qualified Rel8.Expr.Null as Expr

36import Rel8.Kind.Context ( Reifiable, contextSing )

30import Rel8.Kind.Context ( Reifiable, contextSing )

37import Rel8.Schema.Context.Nullify

31import Rel8.Schema.Context.Nullify

38 ( Nullifiability( NAggregate, NExpr )

32 ( Nullifiability( NAggregate, NExpr )

@@ -51,14 +45,12 @@ import Rel8.Schema.HTable.Nullify

51 , hproject

45 , hproject

52 )

46 )

53import qualified Rel8.Schema.Kind as K

47import qualified Rel8.Schema.Kind as K

54−import Rel8.Schema.Null ( Nullity( NotNull, Null ) )

55import qualified Rel8.Schema.Result as R

48import qualified Rel8.Schema.Result as R

56import Rel8.Table

49import Rel8.Table

57 ( Table, Columns, Context, toColumns, fromColumns

50 ( Table, Columns, Context, toColumns, fromColumns

58 , FromExprs, fromResult, toResult

51 , FromExprs, fromResult, toResult

59 , Transpose

52 , Transpose

60 )

53 )

61−import Rel8.Schema.Spec ( Spec( Spec, nullity ) )

62import Rel8.Table.Eq ( EqTable, eqTable )

54import Rel8.Table.Eq ( EqTable, eqTable )

63import Rel8.Table.Ord ( OrdTable, ordTable )

55import Rel8.Table.Ord ( OrdTable, ordTable )

64import Rel8.Table.Projection ( Projectable, apply, project )

56import Rel8.Table.Projection ( Projectable, apply, project )

@@ -190,22 +182,3 @@ guard :: (Reifiable context, HTable t)

190 -> HNullify t context

182 -> HNullify t context

191guard tag isNonNull isNonNullExpr =

183guard tag isNonNull isNonNullExpr =

192 hguard (guarder contextSing tag isNonNull isNonNullExpr)

184 hguard (guarder contextSing tag isNonNull isNonNullExpr)

193−

194−

195−isNull :: forall a. Table Expr a => Nullify Expr a -> Expr Bool

196−isNull =

197− maybe false getAny .

198− getConst .

199− hunnullify (\Spec {nullity} a -> Const $ case nullity of

200− NotNull -> Just $ Any $ Expr.isNull a

201− Null -> Nothing) .

202− toColumns

203−

204−

205−newtype Any = Any

206− { getAny :: Expr Bool

207− }

208−

209−

210−instance Semigroup Any where

211− Any a <> Any b = Any (a ||. b)

src/Rel8/Table/Opaleye.hs+47−31

@@ -7,8 +7,6 @@

7{-# language TypeFamilies #-}

8{-# language ViewPatterns #-}

9

10−{-# options_ghc -Wno-deprecations #-}

11−

12module Rel8.Table.Opaleye

10module Rel8.Table.Opaleye

13 ( aggregator

11 ( aggregator

14 , attributes

12 , attributes

@@ -28,15 +26,17 @@ where

28-- base

26-- base

29import Data.Functor.Const ( Const( Const ), getConst )

27import Data.Functor.Const ( Const( Const ), getConst )

30import Data.List.NonEmpty ( NonEmpty )

28import Data.List.NonEmpty ( NonEmpty )

31−import Prelude

29+import Prelude hiding ( undefined )

32

30

33-- opaleye

31-- opaleye

34−import qualified Opaleye.Adaptors as Opaleye

35−import qualified Opaleye.Field as Opaleye ( Field_ )

36import qualified Opaleye.Internal.Aggregate as Opaleye

32import qualified Opaleye.Internal.Aggregate as Opaleye

33+import qualified Opaleye.Internal.Binary as Opaleye

34+import qualified Opaleye.Internal.Distinct as Opaleye

37import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye

35import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye

36+import qualified Opaleye.Internal.PackMap as Opaleye

37+import qualified Opaleye.Internal.Unpackspec as Opaleye

38import qualified Opaleye.Internal.Values as Opaleye

39−import qualified Opaleye.Table as Opaleye

39+import qualified Opaleye.Internal.Table as Opaleye

40

41-- profunctors

42import Data.Profunctor ( dimap, lmap )

@@ -46,25 +46,27 @@ import Rel8.Aggregate ( Aggregate( Aggregate ), Aggregates )

46import Rel8.Expr ( Expr )

47import Rel8.Expr.Opaleye

48 ( fromPrimExpr, toPrimExpr

49+ , traversePrimExpr

50+ , fromColumn, toColumn

49− , scastExpr, traverseFieldP

51+ , scastExpr

50 )

52 )

51−import Rel8.Schema.HTable ( htabulateA, hfield, hspecs, htabulate,

53+import Rel8.Schema.HTable ( htabulateA, hfield, htraverse, hspecs, htabulate )

52− htraverseP, htraversePWithField )

53import Rel8.Schema.Name ( Name( Name ), Selects, ppColumn )

54import Rel8.Schema.Name ( Name( Name ), Selects, ppColumn )

54import Rel8.Schema.Spec ( Spec(..) )

55import Rel8.Schema.Spec ( Spec(..) )

55import Rel8.Schema.Table ( TableSchema(..), ppTable )

56import Rel8.Schema.Table ( TableSchema(..), ppTable )

56import Rel8.Table ( Table, fromColumns, toColumns )

57import Rel8.Table ( Table, fromColumns, toColumns )

57−import Rel8.Type.Information ( typeName )

58+import Rel8.Table.Undefined ( undefined )

58

59

59-- semigroupoids

60-- semigroupoids

60import Data.Functor.Apply ( WrappedApplicative(..) )

61import Data.Functor.Apply ( WrappedApplicative(..) )

61−import Data.Profunctor.Product ( ProductProfunctor )

62

63

64aggregator :: Aggregates aggregates exprs => Opaleye.Aggregator aggregates exprs

65−aggregator = dimap toColumns fromColumns $

65+aggregator = Opaleye.Aggregator $ Opaleye.PackMap $ \f aggregates ->

66− htraverseP $

66+ fmap fromColumns $ unwrapApplicative $ htabulateA $ \field ->

67− lmap (\(Aggregate a) -> (a, ())) Opaleye.aggregatorApply

67+ WrapApplicative $ case hfield (toColumns aggregates) field of

68+ Aggregate (Opaleye.Aggregator (Opaleye.PackMap inner)) ->

69+ inner f ()

68

70

69

71

70attributes :: Selects names exprs => TableSchema names -> exprs

72attributes :: Selects names exprs => TableSchema names -> exprs

@@ -75,19 +77,22 @@ attributes schema@TableSchema {columns} = fromColumns $ htabulate $ \field ->

75 show (ppTable schema) <> "." <> show (ppColumn column)

77 show (ppTable schema) <> "." <> show (ppColumn column)

76

78

77

79

78−fromOpaleyespec :: (ProductProfunctor p, Table Expr a)

79− => p (Opaleye.Field_ n x) (Opaleye.Field_ n x)

80− -> p a a

81−fromOpaleyespec x =

82− dimap toColumns fromColumns (htraverseP (traverseFieldP x))

83−

84−

85binaryspec :: Table Expr a => Opaleye.Binaryspec a a

80binaryspec :: Table Expr a => Opaleye.Binaryspec a a

86−binaryspec = fromOpaleyespec Opaleye.binaryspecField

81+binaryspec = Opaleye.Binaryspec $ Opaleye.PackMap $ \f (as, bs) ->

82+ fmap fromColumns $ unwrapApplicative $ htabulateA $ \field ->

83+ WrapApplicative $

84+ case (hfield (toColumns as) field, hfield (toColumns bs) field) of

85+ (a, b) -> fromPrimExpr <$> f (toPrimExpr a, toPrimExpr b)

87

86

88

87

89distinctspec :: Table Expr a => Opaleye.Distinctspec a a

88distinctspec :: Table Expr a => Opaleye.Distinctspec a a

90−distinctspec = fromOpaleyespec Opaleye.distinctspecField

89+distinctspec =

90+ Opaleye.Distinctspec $ Opaleye.Aggregator $ Opaleye.PackMap $ \f ->

91+ fmap fromColumns .

92+ unwrapApplicative .

93+ htraverse

94+ (\a -> WrapApplicative $ fromPrimExpr <$> f (Nothing, toPrimExpr a)) .

95+ toColumns

91

96

92

97

93exprs :: Table Expr a => a -> NonEmpty Opaleye.PrimExpr

98exprs :: Table Expr a => a -> NonEmpty Opaleye.PrimExpr

@@ -106,8 +111,8 @@ exprsWithNames names as = getConst $ htabulateA $ \field ->

106table :: Selects names exprs => TableSchema names -> Opaleye.Table exprs exprs

111table :: Selects names exprs => TableSchema names -> Opaleye.Table exprs exprs

107table (TableSchema name schema columns) =

112table (TableSchema name schema columns) =

108 case schema of

113 case schema of

109− Nothing -> Opaleye.table name (tableFields columns)

114+ Nothing -> Opaleye.Table name (tableFields columns)

110− Just schemaName -> Opaleye.tableWithSchema schemaName name (tableFields columns)

115+ Just schemaName -> Opaleye.TableWithSchema schemaName name (tableFields columns)

111

116

112

117

113tableFields :: Selects names exprs

118tableFields :: Selects names exprs

@@ -119,19 +124,21 @@ tableFields (toColumns -> names) = dimap toColumns fromColumns $

119 where

124 where

120 go :: Name a -> Opaleye.TableFields (Expr a) (Expr a)

125 go :: Name a -> Opaleye.TableFields (Expr a) (Expr a)

121 go (Name name) =

126 go (Name name) =

122− traverseFieldP $

127+ dimap (toColumn . toPrimExpr) (fromPrimExpr . fromColumn) $

123 Opaleye.requiredTableField name

128 Opaleye.requiredTableField name

124

129

125

130

126unpackspec :: Table Expr a => Opaleye.Unpackspec a a

131unpackspec :: Table Expr a => Opaleye.Unpackspec a a

127−unpackspec = fromOpaleyespec Opaleye.unpackspecField

132+unpackspec = Opaleye.Unpackspec $ Opaleye.PackMap $ \f ->

133+ fmap fromColumns .

134+ unwrapApplicative .

135+ htraverse (WrapApplicative . traversePrimExpr f) .

136+ toColumns

128{-# INLINABLE unpackspec #-}

137{-# INLINABLE unpackspec #-}

129

138

130

139

131−valuesspec :: Table Expr a => Opaleye.Valuesspec a a

140+valuesspec :: Table Expr a => Opaleye.ValuesspecSafe a a

132−valuesspec = dimap toColumns fromColumns $

141+valuesspec = Opaleye.ValuesspecSafe (toPackMap undefined) unpackspec

133− htraversePWithField (traverseFieldP . Opaleye.valuesspecFieldType . typeName)

134− where typeName = Rel8.Type.Information.typeName . info . hfield hspecs

135

142

136

143

137view :: Selects names exprs => names -> exprs

144view :: Selects names exprs => names -> exprs

@@ -140,6 +147,15 @@ view columns = fromColumns $ htabulate $ \field ->

140 Name column -> fromPrimExpr $ Opaleye.BaseTableAttrExpr column

147 Name column -> fromPrimExpr $ Opaleye.BaseTableAttrExpr column

141

148

142

149

150+toPackMap :: Table Expr a

151+ => a -> Opaleye.PackMap Opaleye.PrimExpr Opaleye.PrimExpr () a

152+toPackMap as = Opaleye.PackMap $ \f () ->

153+ fmap fromColumns $

154+ unwrapApplicative .

155+ htraverse (WrapApplicative . traversePrimExpr f) $

156+ toColumns as

157+

158+

143-- | Transform a table by adding 'CAST' to all columns. This is most useful for

159-- | Transform a table by adding 'CAST' to all columns. This is most useful for

144-- finalising a SELECT or RETURNING statement, guaranteed that the output

160-- finalising a SELECT or RETURNING statement, guaranteed that the output

145-- matches what is encoded in each columns TypeInformation.

161-- matches what is encoded in each columns TypeInformation.

src/Rel8/Table/Ord.hs+2−2

@@ -146,9 +146,9 @@ infix 4 >=:

146

147-- | Given two 'Table's, return the table that sorts before the other.

148least :: OrdTable a => a -> a -> a

149−least a b = bool b a (a <: b)

149+least a b = bool a b (a <: b)

150

151

152-- | Given two 'Table's, return the table that sorts after the other.

153greatest :: OrdTable a => a -> a -> a

154−greatest a b = bool b a (a >: b)

154+greatest a b = bool a b (a >: b)

src/Rel8/Table/Projection.hs+1−1

@@ -35,7 +35,7 @@ class

35 => Projecting a b

36instance

37 ( Transposes (Context a) (Field a) a (Transpose (Field a) a)

38− , Transposes (Context a) (Field a) b (Transpose (Field a) b)

38+ , Transposes (Context a) (Field a) b (Transpose (Field b) b)

39 )

40 => Projecting a b

41

src/Rel8/Table/These.hs+3−14

@@ -20,7 +20,6 @@ module Rel8.Table.These

20 , isThisTable, isThatTable, isThoseTable

21 , hasHereTable, hasThereTable

22 , justHereTable, justThereTable

23− , alignMaybeTable

24 , aggregateTheseTable

23 , aggregateTheseTable

25 , nameTheseTable

24 , nameTheseTable

26 )

25 )

@@ -30,13 +29,13 @@ where

30import Data.Bifunctor ( Bifunctor, bimap )

29import Data.Bifunctor ( Bifunctor, bimap )

31import Data.Kind ( Type )

30import Data.Kind ( Type )

32import Data.Maybe ( isJust )

31import Data.Maybe ( isJust )

33−import Prelude hiding ( null, undefined )

32+import Prelude hiding ( undefined )

34

33

35-- rel8

34-- rel8

36import Rel8.Aggregate ( Aggregate )

35import Rel8.Aggregate ( Aggregate )

37import Rel8.Expr ( Expr )

36import Rel8.Expr ( Expr )

38−import Rel8.Expr.Bool ( (&&.), (||.), boolExpr, not_ )

37+import Rel8.Expr.Bool ( (&&.), not_ )

39−import Rel8.Expr.Null ( null, isNonNull )

38+import Rel8.Expr.Null ( isNonNull )

40import Rel8.Kind.Context ( Reifiable )

39import Rel8.Kind.Context ( Reifiable )

41import Rel8.Schema.Context.Nullify ( Nullifiable )

40import Rel8.Schema.Context.Nullify ( Nullifiable )

42import Rel8.Schema.Dict ( Dict( Dict ) )

41import Rel8.Schema.Dict ( Dict( Dict ) )

@@ -289,16 +288,6 @@ justThereTable :: TheseTable context a b -> MaybeTable context b

289justThereTable = there

288justThereTable = there

290

289

291

290

292−-- | Construct a @TheseTable@ from two 'MaybeTable's.

293−alignMaybeTable :: ()

294− => MaybeTable Expr a

295− -> MaybeTable Expr b

296− -> MaybeTable Expr (TheseTable Expr a b)

297−alignMaybeTable a b = MaybeTable tag (pure (TheseTable a b))

298− where

299− tag = boolExpr null mempty (isJustTable a ||. isJustTable b)

300−

301−

302-- | Construct a @TheseTable@. Corresponds to 'This'.

291-- | Construct a @TheseTable@. Corresponds to 'This'.

303thisTable :: Table Expr b => a -> TheseTable Expr a b

292thisTable :: Table Expr b => a -> TheseTable Expr a b

304thisTable a = TheseTable (justTable a) nothingTable

293thisTable a = TheseTable (justTable a) nothingTable

src/Rel8/Table/Window.hsdeleted−43

@@ -1,43 +0,0 @@

1−{-# language MonoLocalBinds #-}

2−

3−module Rel8.Table.Window

4− ( cumulative

5− , cumulative_

6− , currentRow

7− )

8−where

9−

10−-- base

11−import Prelude

12−

13−-- opaleye

14−import qualified Opaleye.Window as Opaleye

15−

16−-- rel8

17−import Rel8.Aggregate ( Aggregates )

18−import qualified Rel8.Expr.Window as Expr

19−import Rel8.Schema.HTable ( hfield, htabulateA )

20−import Rel8.Table ( fromColumns, toColumns )

21−import Rel8.Window ( Window( Window ) )

22−

23−

24−-- | 'cumulative' allows the use of aggregation functions in 'Window'

25−-- expressions. In particular, @'cumulative' 'Rel8.sum'@

26−-- (when combined with 'Rel8.Window.orderPartitionBy') gives a running total,

27−-- also known as a \"cumulative sum\", hence the name @cumulative@.

28−cumulative :: Aggregates aggregates exprs => (a -> aggregates) -> Window a exprs

29−cumulative f =

30− fmap fromColumns $

31− htabulateA $ \field ->

32− Expr.cumulative ((`hfield` field) . toColumns . f)

33−

34−

35−-- | A version of 'cumulative' for use with nullary aggregators like

36−-- 'Rel8.Expr.Aggregate.countStar'.

37−cumulative_ :: Aggregates aggregates exprs => aggregates -> Window a exprs

38−cumulative_ = cumulative . const

39−

40−

41−-- | Return every column of the current row of a window query.

42−currentRow :: Window a a

43−currentRow = Window $ Opaleye.over (Opaleye.noWindowFunction id) mempty mempty

src/Rel8/Tabulate.hs+20−23

@@ -58,7 +58,7 @@ import Data.Function ( on )

58import Data.Functor.Contravariant ( Contravariant, (>$<), contramap )

59import Data.Int ( Int64 )

60import Data.Kind ( Type )

61−import Data.Maybe ( fromJust, fromMaybe )

61+import Data.Maybe ( fromMaybe )

62import Prelude hiding ( lookup, zip, zipWith )

63

64-- bifunctors

@@ -69,7 +69,9 @@ import Control.Comonad ( extract )

69

70-- opaleye

71import qualified Opaleye.Aggregate as Opaleye

72−import qualified Opaleye.Order as Opaleye ( orderBy, distinctOnExplicit )

72+import qualified Opaleye.Internal.Order as Opaleye

73+import qualified Opaleye.Internal.QueryArr as Opaleye

74+import qualified Opaleye.Order as Opaleye ( orderBy )

73

75

74-- profunctors

76-- profunctors

75import Data.Profunctor ( dimap, lmap )

77import Data.Profunctor ( dimap, lmap )

@@ -90,10 +92,10 @@ import Rel8.Order ( Order( Order ) )

90import Rel8.Query ( Query )

92import Rel8.Query ( Query )

91import qualified Rel8.Query.Exists as Q ( exists, present, absent )

93import qualified Rel8.Query.Exists as Q ( exists, present, absent )

92import Rel8.Query.Filter ( where_ )

94import Rel8.Query.Filter ( where_ )

95+import Rel8.Query.Limit ( limit )

93import Rel8.Query.List ( catNonEmptyTable )

96import Rel8.Query.List ( catNonEmptyTable )

94import qualified Rel8.Query.Maybe as Q ( optional )

97import qualified Rel8.Query.Maybe as Q ( optional )

95import Rel8.Query.Opaleye ( mapOpaleye, unsafePeekQuery )

98import Rel8.Query.Opaleye ( mapOpaleye, unsafePeekQuery )

96−import Rel8.Query.Rebind ( rebind )

97import Rel8.Query.These ( alignBy )

99import Rel8.Query.These ( alignBy )

98import Rel8.Table ( Table, fromColumns, toColumns )

100import Rel8.Table ( Table, fromColumns, toColumns )

99import Rel8.Table.Aggregate ( hgroupBy, listAgg, nonEmptyAgg )

101import Rel8.Table.Aggregate ( hgroupBy, listAgg, nonEmptyAgg )

@@ -234,13 +236,7 @@ instance EqTable k => Monad (Tabulation k) where

234-- | If @'Tabulation' k a@ is @Map k (NonEmpty a)@, then @(<|>:)@ is

236-- | If @'Tabulation' k a@ is @Map k (NonEmpty a)@, then @(<|>:)@ is

235-- @unionWith (<>)@.

237-- @unionWith (<>)@.

236instance EqTable k => AltTable (Tabulation k) where

238instance EqTable k => AltTable (Tabulation k) where

237− tas <|>: tbs = do

238− eas <- peek tas

239− ebs <- peek tbs

240− case (eas, ebs) of

241− (Left as, Left bs) -> liftQuery $ as <|>: bs

242− (Right as, Right bs) -> fromQuery $ as <|>: bs

243− _ -> catNonEmptyTable `through` ((<>) `on` some) tas tbs

239+ as <|>: bs = catNonEmptyTable `through` ((<>) `on` some) as bs

244

240

245

241

246instance EqTable k => AlternativeTable (Tabulation k) where

242instance EqTable k => AlternativeTable (Tabulation k) where

@@ -349,8 +345,19 @@ aggregate (Tabulation f) = Tabulation $

349-- \"first\" value it encounters for each key, but note that \"first\" is

345-- \"first\" value it encounters for each key, but note that \"first\" is

350-- undefined unless you first call 'order'.

346-- undefined unless you first call 'order'.

351distinct :: EqTable k => Tabulation k a -> Tabulation k a

347distinct :: EqTable k => Tabulation k a -> Tabulation k a

352−distinct (Tabulation f) = Tabulation $

348+distinct (Tabulation f) = Tabulation $ \p ->

349+ -- workaround for https://github.com/tomjaguarpaw/haskell-opaleye/pull/518

350+ case fst (unsafePeekQuery (f p)) of

351+ Nothing -> limit 1 (f p)

352+ Just _ ->

353+ mapOpaleye

354+ (\q ->

355+ Opaleye.productQueryArr

353− mapOpaleye (Opaleye.distinctOnExplicit (key unpackspec) fst) . f

356+ ( Opaleye.distinctOn (key unpackspec) fst

357+ . Opaleye.runSimpleQueryArr q

358+ )

359+ )

360+ (f p)

354

361

355

362

356-- | 'order' orders the /values/ of a 'Tabulation' within their

363-- | 'order' orders the /values/ of a 'Tabulation' within their

@@ -509,8 +516,8 @@ alignWith :: EqTable k

509 -> Tabulation k a -> Tabulation k b -> Tabulation k c

516 -> Tabulation k a -> Tabulation k b -> Tabulation k c

510alignWith f (Tabulation as) (Tabulation bs) = Tabulation $ \p -> do

517alignWith f (Tabulation as) (Tabulation bs) = Tabulation $ \p -> do

511 tkab <- liftF2 (alignBy condition) as bs p

518 tkab <- liftF2 (alignBy condition) as bs p

512− k <- traverse (rebind "key") $ recover $ bimap fst fst tkab

513 let

519 let

520+ k = recover $ bimap fst fst tkab

514 tab = bimap snd snd tkab

521 tab = bimap snd snd tkab

515 pure (k, f tab)

522 pure (k, f tab)

516 where

523 where

@@ -628,13 +635,3 @@ similarity a b = a <* present b

628-- @do@-notation.

635-- @do@-notation.

629difference :: EqTable k => Tabulation k a -> Tabulation k b -> Tabulation k a

636difference :: EqTable k => Tabulation k a -> Tabulation k b -> Tabulation k a

630difference a b = a <* absent b

637difference a b = a <* absent b

631−

632−

633−-- | 'Tabulation's can be produced with either 'fromQuery' or 'liftQuery', and

634−-- in some cases we might want to treat these differently. 'peek' uses

635−-- 'unsafePeekQuery' to determine which type of 'Tabulation' we have.

636−peek :: Tabulation k a -> Tabulation k (Either (Query a) (Query (k, a)))

637−peek (Tabulation f) = Tabulation $ \p ->

638− pure $ (empty,) $ case unsafePeekQuery (f p) of

639− (Nothing, _) -> Left $ fmap snd (f p)

640− (Just _, _) -> Right $ fmap (first fromJust) (f p)

src/Rel8/Type.hs+8−9

@@ -1,4 +1,3 @@

1−{-# language FlexibleContexts #-}

2{-# language FlexibleInstances #-}

1{-# language FlexibleInstances #-}

3{-# language MonoLocalBinds #-}

2{-# language MonoLocalBinds #-}

4{-# language MultiWayIf #-}

3{-# language MultiWayIf #-}

@@ -128,10 +127,10 @@ instance DBType Int64 where

128instance DBType Float where

127instance DBType Float where

129 typeInformation = TypeInformation

128 typeInformation = TypeInformation

130 { encode = \x -> Opaleye.ConstExpr

129 { encode = \x -> Opaleye.ConstExpr

131− if | x == (1 / 0) -> Opaleye.OtherLit "'Infinity'"

130+ if | x == (1 /0) -> Opaleye.OtherLit "'Infinity'"

132− | isNaN x -> Opaleye.OtherLit "'NaN'"

131+ | isNaN x -> Opaleye.OtherLit "'NaN'"

133− | x == (-1 / 0) -> Opaleye.OtherLit "'-Infinity'"

132+ | x == (-1/0) -> Opaleye.OtherLit "'-Infinity'"

134− | otherwise -> Opaleye.NumericLit $ realToFrac x

133+ | otherwise -> Opaleye.NumericLit $ realToFrac x

135 , decode = Hasql.float4

134 , decode = Hasql.float4

136 , typeName = "float4"

135 , typeName = "float4"

137 }

136 }

@@ -141,10 +140,10 @@ instance DBType Float where

141instance DBType Double where

140instance DBType Double where

142 typeInformation = TypeInformation

141 typeInformation = TypeInformation

143 { encode = \x -> Opaleye.ConstExpr

142 { encode = \x -> Opaleye.ConstExpr

144− if | x == (1 / 0) -> Opaleye.OtherLit "'Infinity'"

143+ if | x == (1 /0) -> Opaleye.OtherLit "'Infinity'"

145− | isNaN x -> Opaleye.OtherLit "'NaN'"

144+ | isNaN x -> Opaleye.OtherLit "'NaN'"

146− | x == (-1 / 0) -> Opaleye.OtherLit "'-Infinity'"

145+ | x == (-1/0) -> Opaleye.OtherLit "'-Infinity'"

147− | otherwise -> Opaleye.NumericLit $ realToFrac x

146+ | otherwise -> Opaleye.NumericLit $ realToFrac x

148 , decode = Hasql.float8

147 , decode = Hasql.float8

149 , typeName = "float8"

148 , typeName = "float8"

150 }

149 }

src/Rel8/Type/Enum.hs−1

@@ -106,7 +106,6 @@ class (DBType a, Enumable a) => DBEnum a where

106

107-- | Types that are sum types, where each constructor is unary (that is, has no

108-- fields).

109−type Enumable :: Type -> Constraint

110class (Generic a, GEnumable (Rep a)) => Enumable a

109class (Generic a, GEnumable (Rep a)) => Enumable a

111instance (Generic a, GEnumable (Rep a)) => Enumable a

110instance (Generic a, GEnumable (Rep a)) => Enumable a

112

111

src/Rel8/Type/JSONBEncoded.hs−4

@@ -1,5 +1,3 @@

1−{-# language StandaloneKindSignatures #-}

2−

3module Rel8.Type.JSONBEncoded ( JSONBEncoded(..) ) where

1module Rel8.Type.JSONBEncoded ( JSONBEncoded(..) ) where

4

2

5-- aeson

3-- aeson

@@ -8,7 +6,6 @@ import Data.Aeson.Types ( parseEither )

8

6

9-- base

7-- base

10import Data.Bifunctor ( first )

8import Data.Bifunctor ( first )

11−import Data.Kind ( Type )

12import Prelude

9import Prelude

13

10

14-- hasql

11-- hasql

@@ -23,7 +20,6 @@ import Data.Text ( pack )

23

20

24

21

25-- | Like 'Rel8.JSONEncoded', but works for @jsonb@ columns.

22-- | Like 'Rel8.JSONEncoded', but works for @jsonb@ columns.

26−type JSONBEncoded :: Type -> Type

27newtype JSONBEncoded a = JSONBEncoded { fromJSONBEncoded :: a }

23newtype JSONBEncoded a = JSONBEncoded { fromJSONBEncoded :: a }

28

24

29

25

src/Rel8/Type/JSONEncoded.hs−4

@@ -1,5 +1,3 @@

1−{-# language StandaloneKindSignatures #-}

2−

3module Rel8.Type.JSONEncoded ( JSONEncoded(..) ) where

1module Rel8.Type.JSONEncoded ( JSONEncoded(..) ) where

4

2

5-- aeson

3-- aeson

@@ -7,7 +5,6 @@ import Data.Aeson ( FromJSON, ToJSON, parseJSON, toJSON )

7import Data.Aeson.Types ( parseEither )

5import Data.Aeson.Types ( parseEither )

8

6

9-- base

7-- base

10−import Data.Kind ( Type )

11import Prelude

8import Prelude

12

9

13-- rel8

10-- rel8

@@ -18,7 +15,6 @@ import Rel8.Type.Information ( parseTypeInformation )

18-- | A deriving-via helper type for column types that store a Haskell value

15-- | A deriving-via helper type for column types that store a Haskell value

19-- using a JSON encoding described by @aeson@'s 'ToJSON' and 'FromJSON' type

16-- using a JSON encoding described by @aeson@'s 'ToJSON' and 'FromJSON' type

20-- classes.

17-- classes.

21−type JSONEncoded :: Type -> Type

22newtype JSONEncoded a = JSONEncoded { fromJSONEncoded :: a }

18newtype JSONEncoded a = JSONEncoded { fromJSONEncoded :: a }

23

19

24

20

src/Rel8/Type/Num.hs+1−4

@@ -18,7 +18,6 @@ import Prelude

18

19-- rel8

20import Rel8.Type ( DBType )

21−import Rel8.Type.Ord ( DBOrd )

22

21

23-- scientific

22-- scientific

24import Data.Scientific ( Scientific )

23import Data.Scientific ( Scientific )

@@ -40,14 +39,13 @@ instance DBNum Scientific

40-- expressions. This is a Rel8 concept, and allows us to provide

39-- expressions. This is a Rel8 concept, and allows us to provide

41-- 'fromIntegral'.

40-- 'fromIntegral'.

42type DBIntegral :: Type -> Constraint

41type DBIntegral :: Type -> Constraint

43−class (DBNum a, DBOrd a) => DBIntegral a

42+class DBNum a => DBIntegral a

44instance DBIntegral Int16

43instance DBIntegral Int16

45instance DBIntegral Int32

44instance DBIntegral Int32

46instance DBIntegral Int64

45instance DBIntegral Int64

47

46

48

47

49-- | The class of database types that support the @/@ operator.

48-- | The class of database types that support the @/@ operator.

50−type DBFractional :: Type -> Constraint

51class DBNum a => DBFractional a

49class DBNum a => DBFractional a

52instance DBFractional Float

50instance DBFractional Float

53instance DBFractional Double

51instance DBFractional Double

@@ -55,7 +53,6 @@ instance DBFractional Scientific

55

53

56

54

57-- | The class of database types that support the @/@ operator.

55-- | The class of database types that support the @/@ operator.

58−type DBFloating :: Type -> Constraint

59class DBFractional a => DBFloating a

56class DBFractional a => DBFloating a

60instance DBFloating Float

57instance DBFloating Float

61instance DBFloating Double

58instance DBFloating Double

src/Rel8/Type/Ord.hs+2

@@ -75,6 +75,7 @@ instance Sql DBOrd a => DBOrd (NonEmpty a)

75-- | The class of database types that support the @max@ aggregation function.

76type DBMax :: Type -> Constraint

77class DBOrd a => DBMax a

78+instance DBMax Bool

78instance DBMax Char

79instance DBMax Char

79instance DBMax Int16

80instance DBMax Int16

80instance DBMax Int32

81instance DBMax Int32

@@ -100,6 +101,7 @@ instance Sql DBMax a => DBMax (NonEmpty a)

100-- | The class of database types that support the @min@ aggregation function.

101-- | The class of database types that support the @min@ aggregation function.

101type DBMin :: Type -> Constraint

102type DBMin :: Type -> Constraint

102class DBOrd a => DBMin a

103class DBOrd a => DBMin a

104+instance DBMin Bool

103instance DBMin Char

105instance DBMin Char

104instance DBMin Int16

106instance DBMin Int16

105instance DBMin Int32

107instance DBMin Int32

src/Rel8/Type/ReadShow.hs−3

@@ -1,12 +1,10 @@

1{-# language ScopedTypeVariables #-}

2−{-# language StandaloneKindSignatures #-}

3{-# language TypeApplications #-}

2{-# language TypeApplications #-}

4{-# language ViewPatterns #-}

3{-# language ViewPatterns #-}

5

4

6module Rel8.Type.ReadShow ( ReadShow(..) ) where

5module Rel8.Type.ReadShow ( ReadShow(..) ) where

7

6

8-- base

7-- base

9−import Data.Kind ( Type )

10import Data.Proxy ( Proxy( Proxy ) )

8import Data.Proxy ( Proxy( Proxy ) )

11import Data.Typeable ( Typeable, typeRep )

9import Data.Typeable ( Typeable, typeRep )

12import Prelude

10import Prelude

@@ -22,7 +20,6 @@ import qualified Data.Text as Text

22

20

23-- | A deriving-via helper type for column types that store a Haskell value

21-- | A deriving-via helper type for column types that store a Haskell value

24-- using a Haskell's 'Read' and 'Show' type classes.

22-- using a Haskell's 'Read' and 'Show' type classes.

25−type ReadShow :: Type -> Type

26newtype ReadShow a = ReadShow { fromReadShow :: a }

23newtype ReadShow a = ReadShow { fromReadShow :: a }

27

24

28

25

src/Rel8/Type/Tag.hs−1

@@ -90,7 +90,6 @@ instance DBMonoid MaybeTag where

90 memptyExpr = litExpr mempty

91

92

93−type Tag :: Type

94newtype Tag = Tag Text

93newtype Tag = Tag Text

95 deriving newtype

94 deriving newtype

96 ( Eq, Ord, Read, Show

95 ( Eq, Ord, Read, Show

src/Rel8/Window.hsdeleted−97

@@ -1,97 +0,0 @@

1−{-# language DerivingVia #-}

2−{-# language FlexibleContexts #-}

3−{-# language GeneralizedNewtypeDeriving #-}

4−{-# language ScopedTypeVariables #-}

5−{-# language StandaloneKindSignatures #-}

6−{-# language TypeApplications #-}

7−

8−module Rel8.Window

9− ( Window(..)

10− , Partition

11− , over

12− , partitionBy

13− , orderPartitionBy

14− )

15−where

16−

17−-- base

18−import Data.Functor.Const ( Const( Const ), getConst )

19−import Data.Functor.Contravariant ( Contravariant, contramap )

20−import Data.Kind ( Type )

21−import Prelude

22−

23−-- opaleye

24−import qualified Opaleye.Internal.Window as Opaleye

25−import qualified Opaleye.Internal.PackMap as Opaleye

26−

27−-- profunctors

28−import Data.Profunctor ( Profunctor )

29−

30−-- product-profunctors

31−import Data.Profunctor.Product ( ProductProfunctor, (****), purePP )

32−

33−-- rel8

34−import Rel8.Expr.Opaleye ( toColumn, toPrimExpr )

35−import Rel8.Order( Order( Order ) )

36−import Rel8.Schema.HTable ( hfield, htabulateA )

37−import Rel8.Table ( Columns, toColumns )

38−import Rel8.Table.Eq ( EqTable )

39−

40−-- semigroupoids

41−import Data.Functor.Apply ( Apply, WrappedApplicative(..) )

42−

43−

44−-- | 'Window' is an applicative functor that represents expressions that

45−-- contain

46−-- [window functions](https://www.postgresql.org/docs/current/tutorial-window.html).

47−-- 'Rel8.Query.Window.window' can be used to

48−-- evaluate these expressions over a particular query.

49−type Window :: Type -> Type -> Type

50−newtype Window a b = Window (Opaleye.Windows a b)

51− deriving newtype (Profunctor)

52− deriving newtype (Functor, Applicative)

53− deriving (Apply) via (WrappedApplicative (Window a))

54−

55−

56−instance ProductProfunctor Window where

57− purePP = pure

58− (****) = (<*>)

59−

60−

61−-- | In PostgreSQL, window functions must specify the \"window\" or

62−-- \"partition\" over which they operate. The syntax for this looks like:

63−-- @SUM(salary) OVER (PARTITION BY department)@. The Rel8 type 'Partition'

64−-- represents everything that comes after @OVER@.

65−--

66−-- 'Partition' is a 'Monoid', so 'Window's created with 'partitionBy' and

67−-- 'orderWindowBy' can be combined using '<>'.

68−type Partition :: Type -> Type

69−newtype Partition a = Partition (Opaleye.Window a)

70− deriving newtype (Contravariant, Semigroup, Monoid)

71−

72−

73−-- | 'over' adds a 'Partition' to a 'Window' expression.

74−--

75−-- @@@

76−-- 'Rel8.Table.Window.cumulative' ('Rel8.Expr.Aggregate.sum' . salary) `over` 'partitionBy' department <> 'orderPartitionBy' (salary >$< 'Rel8.desc')

77−-- @@@

78−over :: Window a b -> Partition a -> Window a b

79−over (Window (Opaleye.Windows (Opaleye.PackMap w))) (Partition p) =

80− Window $ Opaleye.Windows $ Opaleye.PackMap $ \f ->

81− w (\(o, p') -> f (o, p' <> p))

82−infixl 1 `over`

83−

84−

85−-- | Restricts a window function to operate only the group of rows that share

86−-- the same value(s) for the given expression(s).

87−partitionBy :: forall b a. EqTable b => (a -> b) -> Partition a

88−partitionBy f =

89− Partition $ contramap (toColumns . f) $ getConst $

90− htabulateA @(Columns b) $ \field ->

91− Const $ Opaleye.partitionBy (toColumn . toPrimExpr . (`hfield` field))

92−

93−

94−-- | Controls the order in which rows are processed by window functions. This

95−-- does not need to match the ordering of the overall query.

96−orderPartitionBy :: Order a -> Partition a

97−orderPartitionBy (Order ordering) = Partition $ Opaleye.orderPartitionBy ordering

tests/Main.hs−94

@@ -1,4 +1,3 @@

1−{-# language BangPatterns #-}

2{-# language BlockArguments #-}

1{-# language BlockArguments #-}

3{-# language DeriveAnyClass #-}

2{-# language DeriveAnyClass #-}

4{-# language DeriveGeneric #-}

3{-# language DeriveGeneric #-}

@@ -6,7 +5,6 @@

6{-# language FlexibleContexts #-}

5{-# language FlexibleContexts #-}

7{-# language FlexibleInstances #-}

6{-# language FlexibleInstances #-}

8{-# language MonoLocalBinds #-}

7{-# language MonoLocalBinds #-}

9−{-# language NamedFieldPuns #-}

10{-# language OverloadedStrings #-}

8{-# language OverloadedStrings #-}

11{-# language RecordWildCards #-}

9{-# language RecordWildCards #-}

12{-# language ScopedTypeVariables #-}

10{-# language ScopedTypeVariables #-}

@@ -38,7 +36,6 @@ import qualified Data.ByteString.Lazy

38import Data.CaseInsensitive ( mk )

36import Data.CaseInsensitive ( mk )

39

37

40-- containers

38-- containers

41−import Data.Containers.ListUtils ( nubOrdOn )

42import qualified Data.Map.Strict as Map

39import qualified Data.Map.Strict as Map

43

40

44-- hasql

41-- hasql

@@ -116,13 +113,11 @@ tests =

116 , testCatMaybeTable getTestDatabase

113 , testCatMaybeTable getTestDatabase

117 , testCatMaybe getTestDatabase

114 , testCatMaybe getTestDatabase

118 , testMaybeTable getTestDatabase

115 , testMaybeTable getTestDatabase

119− , testAggregateMaybeTable getTestDatabase

120 , testNestedTables getTestDatabase

116 , testNestedTables getTestDatabase

121 , testMaybeTableApplicative getTestDatabase

117 , testMaybeTableApplicative getTestDatabase

122 , testLogicalFixities getTestDatabase

118 , testLogicalFixities getTestDatabase

123 , testUpdate getTestDatabase

119 , testUpdate getTestDatabase

124 , testDelete getTestDatabase

120 , testDelete getTestDatabase

125− , testUpsert getTestDatabase

126 , testSelectNestedPairs getTestDatabase

121 , testSelectNestedPairs getTestDatabase

127 , testSelectArray getTestDatabase

122 , testSelectArray getTestDatabase

128 , testNestedMaybeTable getTestDatabase

123 , testNestedMaybeTable getTestDatabase

@@ -138,7 +133,6 @@ tests =

138 flip run conn do

133 flip run conn do

139 sql "CREATE EXTENSION citext"

134 sql "CREATE EXTENSION citext"

140 sql "CREATE TABLE test_table ( column1 text not null, column2 bool not null )"

135 sql "CREATE TABLE test_table ( column1 text not null, column2 bool not null )"

141− sql "CREATE TABLE unique_table ( \"key\" text not null unique, \"value\" text not null )"

142 sql "CREATE SEQUENCE test_seq"

136 sql "CREATE SEQUENCE test_seq"

143

137

144 return db

138 return db

@@ -561,28 +555,6 @@ testMaybeTable = databasePropertyTest "maybeTable" \transaction -> evalM do

561 _ -> sort selected === sort rows

555 _ -> sort selected === sort rows

562

556

563

557

564−testAggregateMaybeTable :: IO TmpPostgres.DB -> TestTree

565−testAggregateMaybeTable = databasePropertyTest "aggregateMaybeTable" \transaction -> evalM do

566− rows <- forAll $ Gen.list (Range.linear 0 10) (Gen.maybe (Gen.int64 (Range.linear 0 10)))

567−

568− let

569− aggregate = go 0 False False

570− where

571− go !n nothing _ (Just a : as) = go (n + a) nothing True as

572− go n _ just (Nothing : as) = go n True just as

573− go _ False False [] = []

574− go _ True False [] = [Nothing]

575− go n False True [] = [Just n]

576− go n True True [] = [Nothing, Just n]

577−

578− transaction do

579− selected <- lift do

580− statement () $ Rel8.select do

581− Rel8.aggregate $ Rel8.aggregateMaybeTable Rel8.sum <$> Rel8.values (Rel8.lit <$> rows)

582−

583− sort selected === aggregate rows

584−

585−

586data TwoTestTables f =

558data TwoTestTables f =

587 TwoTestTables

559 TwoTestTables

588 { testTable1 :: TestTable f

560 { testTable1 :: TestTable f

@@ -713,72 +685,6 @@ testDelete = databasePropertyTest "Can DELETE TestTable" \transaction -> do

713 sort (deleted <> selected) === sort rows

685 sort (deleted <> selected) === sort rows

714

686

715

687

716−data UniqueTable f = UniqueTable

717− { uniqueTableKey :: Rel8.Column f Text

718− , uniqueTableValue :: Rel8.Column f Text

719− }

720− deriving stock Generic

721− deriving anyclass Rel8.Rel8able

722−

723−

724−deriving stock instance Eq (UniqueTable Result)

725−deriving stock instance Ord (UniqueTable Result)

726−deriving stock instance Show (UniqueTable Result)

727−

728−

729−uniqueTableSchema :: Rel8.TableSchema (UniqueTable Rel8.Name)

730−uniqueTableSchema =

731− Rel8.TableSchema

732− { name = "unique_table"

733− , schema = Nothing

734− , columns = UniqueTable

735− { uniqueTableKey = "key"

736− , uniqueTableValue = "value"

737− }

738− }

739−

740−

741−genUniqueTable :: Gen (UniqueTable Result)

742−genUniqueTable = do

743− uniqueTableKey <- Gen.text (Range.linear 0 5) Gen.alphaNum

744− uniqueTableValue <- Gen.text (Range.linear 0 5) Gen.alphaNum

745− pure UniqueTable {..}

746−

747−

748−testUpsert :: IO TmpPostgres.DB -> TestTree

749−testUpsert = databasePropertyTest "Can UPSERT UniqueTable" \transaction -> do

750− as <- unique $ forAll $ Gen.list (Range.linear 0 20) genUniqueTable

751− bs <- unique $ forAll $ Gen.list (Range.linear 0 20) genUniqueTable

752−

753− transaction do

754− selected <- lift do

755− statement () $ Rel8.insert Rel8.Insert

756− { into = uniqueTableSchema

757− , rows = Rel8.values $ Rel8.lit <$> as

758− , onConflict = Rel8.DoNothing

759− , returning = pure ()

760− }

761−

762− statement () $ Rel8.insert Rel8.Insert

763− { into = uniqueTableSchema

764− , rows = Rel8.values $ Rel8.lit <$> bs

765− , onConflict = Rel8.DoUpdate Rel8.Upsert

766− { index = uniqueTableKey

767− , set = \UniqueTable {uniqueTableValue} old -> old {uniqueTableValue}

768− , updateWhere = \_ _ -> Rel8.true

769− }

770− , returning = pure ()

771− }

772−

773− statement () $ Rel8.select do

774− Rel8.each uniqueTableSchema

775−

776− fromUniqueTables selected === fromUniqueTables bs <> fromUniqueTables as

777− where

778− unique = fmap (nubOrdOn uniqueTableKey)

779− fromUniqueTables = Map.fromList . map \(UniqueTable key value) -> (key, value)

780−

781−

782newtype HKNestedPair f = HKNestedPair { pairOne :: (TestTable f, TestTable f) }

688newtype HKNestedPair f = HKNestedPair { pairOne :: (TestTable f, TestTable f) }

783 deriving stock Generic

689 deriving stock Generic

784 deriving anyclass Rel8.Rel8able

690 deriving anyclass Rel8.Rel8able

tests/Rel8/Generic/Rel8able/Test.hs+1−10

@@ -5,7 +5,6 @@

5{-# language DuplicateRecordFields #-}

6{-# language FlexibleInstances #-}

7{-# language MultiParamTypeClasses #-}

8−{-# language StandaloneKindSignatures #-}

9{-# language TypeFamilies #-}

8{-# language TypeFamilies #-}

10{-# language UndecidableInstances #-}

9{-# language UndecidableInstances #-}

11

10

@@ -172,17 +171,9 @@ data NestedTableTestB f = NestedTableTestB

172 deriving anyclass Rel8able

171 deriving anyclass Rel8able

173

172

174

173

174+

175newtype IdRecord a f = IdRecord { recordId :: Column f a }

176 deriving stock Generic

177

178

179instance DBType a => Rel8able (IdRecord a)

180−

181−

182−type Nest :: KRel8able -> KRel8able -> KRel8able

183−data Nest t u f = Nest

184− { foo :: t f

185− , bar :: u f

186− }

187− deriving stock Generic

188− deriving anyclass Rel8able