b0e47ec...master · rel8

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

since splitsnapshots

unifiedsplit

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

9 persist-credentials: false

10 submodules: true

11

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

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

13 with:

14 nix_path: nixpkgs=channel:nixos-unstable

15 extra_nix_config: |

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

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

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

18

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

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

20 with:

21 name: rel8

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

Changelog.md+90−2

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

1−# 1.1.0.0 (??)

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)

2

88

3## New features

89## New features

4

90

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

10 , myTableY :: f Text

96 , myTableY :: f Text

11 } deriving (Generic, Rel8able)

97 } deriving (Generic, Rel8able)

12 ```

98 ```

13−

99+

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

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

15

101

16 ```haskell

102 ```haskell

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

27

113

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

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

29

115

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

117+

30## Breaking changes

118## Breaking changes

31

119

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

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

cabal.project−5

@@ -1,6 +1 @@

1packages: .

2−

3−allow-newer: generic-monoid:base

4−allow-newer: cryptohash-sha1:base

5−allow-newer: cryptohash-md5:base

6−allow-newer: entropy:Cabal

cabal.project.haskell-nix−6

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

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

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

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

5−

6−source-repository-package

7− type: git

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

9− tag: f99b05454874192e3511bd133555dfb6cc6a6ecb

10− --sha256: 0yy2i2jbllwavv5d2176rf8lmm4l1ws90lxkmdlfgvfzqxidx0gi

default.nix+2−2

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

1let

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

3

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

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

5

6 nixpkgsArgs = haskellNix.nixpkgsArgs;

7

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

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

9

10 pkgs = import nixpkgsSrc nixpkgsArgs;

11

docs/cookbook.rst+9−7

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

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

143posts. We want our query to return:

144

145−1. The latest 5 blog posts.

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

1462. For each blog post, all tags.

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

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

148

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

150

151 latestBlogPosts = do

152 post <- each postSchema

153

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

154− tags <- aggregate do

155+ tags <- some $ do

155 tag <- each tagSchema

156 tag <- each tagSchema

156 where_ (tagPostId tag ==. postId post)

157 where_ (tagPostId tag ==. postId post)

157− return (listAgg (tagName tag))

158+ return (tagName tag)

158

159

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

159− latestComments <-

161+ latestComments <-

160− many $

162+ many $

161− limit 3 $

163+ limit 3 $

162 orderBy (commentCreatedAt >$< desc) do

164 orderBy (commentCreatedAt >$< desc) do

163 comment <- each commentSchema

165 comment <- each commentSchema

164 where_ (commentPostId comment ==. postId post)

166 where_ (commentPostId comment ==. postId post)

nix/sources.json+9−9

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

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

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

7 "repo": "haskell.nix",

8− "rev": "3856d2d24dca0ecc71fcfc314253a2a2d07a3c4f",

8+ "rev": "0837156c56cb5350dd9bd84eb424187e00aa1e8a",

9− "sha256": "0s69nasqhkv8n0qmdv075k83p3z584ja9vkzdnp2291mymghvx87",

9+ "sha256": "1djmv5a0vfj78csw2cad6nicrs8iqrp928b9b3v4h7lwwhhzliwl",

10 "type": "tarball",

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

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

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

13 },

14 "niv": {

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

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

18 "owner": "nmattia",

19 "repo": "niv",

20− "rev": "e0ca65c81a2d7a4d82a189f1e23a48d59ad42070",

20+ "rev": "acdb1726783637852c01e0ad639ac9cbec28d8c8",

21− "sha256": "1pq9nh1d8nn3xvbdny8fafzw87mj7gsmp6pxkdl65w2g18rmcmzx",

21+ "sha256": "1wszl8q70z6wfgkh2dvgmhhry6qp9nar421qq2ifd17hq2jj9ck3",

22 "type": "tarball",

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

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

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

25 },

26 "nixpkgs": {

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

29 "homepage": null,

30 "owner": "nixos",

31 "repo": "nixpkgs",

32− "rev": "59b8d9cf24e9fcf10341a0923c9bdca088dca8c8",

32+ "rev": "1c1f5649bb9c1b0d98637c8c365228f57126f361",

33− "sha256": "08f38v4b2kcxnbapdwrb54bglka92cxj9qlnqlk5px206jyq9v4c",

33+ "sha256": "0f2nvdijyxfgl5kwyb4465pppd5vkhqxddx6v40k2s0z9jfhj0xl",

34 "type": "tarball",

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

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

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

37 }

38}

nix/sources.nix+21−1

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

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

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

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

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

35+ submoduleArg =

36+ let

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

38+ emptyArgWithWarning =

39+ if submodules == true

40+ then

41+ builtins.trace

42+ (

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

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

45+ + "does not support them"

46+ )

47+ {}

48+ else {};

49+ in

50+ if nixSupportsSubmodules

51+ then { inherit submodules; }

52+ else emptyArgWithWarning;

34 in

53 in

54+ builtins.fetchGit

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

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

36

56

37 fetch_local = spec: spec.path;

57 fetch_local = spec: spec.path;

38

58

rel8.cabal+16−5

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

1cabal-version: 2.0

2name: rel8

3−version: 1.0.0.1

3+version: 1.4.0.0

4synopsis: Hey! Hey! Can u rel8?

5license: BSD3

6license-file: LICENSE

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

20library

21 build-depends:

22 aeson

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

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

24 , bifunctors

25 , bytestring

26 , case-insensitive

27 , comonad

28 , contravariant

29− , hasql ^>= 1.4.5.1

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

30− , opaleye ^>= 0.7.3.0

30+ , opaleye ^>= 0.9.6.1

31 , pretty

32 , profunctors

33 , product-profunctors

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

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

47 -Wno-monomorphism-restriction

48 -Wno-missing-local-signatures

49+ -Wno-missing-kind-signatures

49 hs-source-dirs:

50 hs-source-dirs:

50 src

51 src

51 exposed-modules:

52 exposed-modules:

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

65 Rel8.Column.List

66 Rel8.Column.List

66 Rel8.Column.Maybe

67 Rel8.Column.Maybe

67 Rel8.Column.NonEmpty

68 Rel8.Column.NonEmpty

69+ Rel8.Column.Null

68 Rel8.Column.These

70 Rel8.Column.These

69

71

70 Rel8.Expr

72 Rel8.Expr

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

80 Rel8.Expr.Order

82 Rel8.Expr.Order

81 Rel8.Expr.Sequence

83 Rel8.Expr.Sequence

82 Rel8.Expr.Serialize

84 Rel8.Expr.Serialize

85+ Rel8.Expr.Window

83

86

84 Rel8.FCF

87 Rel8.FCF

85

88

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

106 Rel8.Query.Evaluate

109 Rel8.Query.Evaluate

107 Rel8.Query.Exists

110 Rel8.Query.Exists

108 Rel8.Query.Filter

111 Rel8.Query.Filter

112+ Rel8.Query.Indexed

109 Rel8.Query.Limit

113 Rel8.Query.Limit

110 Rel8.Query.List

114 Rel8.Query.List

111 Rel8.Query.Maybe

115 Rel8.Query.Maybe

112 Rel8.Query.Null

116 Rel8.Query.Null

113 Rel8.Query.Opaleye

117 Rel8.Query.Opaleye

114 Rel8.Query.Order

118 Rel8.Query.Order

119+ Rel8.Query.Rebind

115 Rel8.Query.Set

120 Rel8.Query.Set

116 Rel8.Query.SQL

121 Rel8.Query.SQL

117 Rel8.Query.These

122 Rel8.Query.These

118 Rel8.Query.Values

123 Rel8.Query.Values

124+ Rel8.Query.Window

119

125

120 Rel8.Schema.Context.Nullify

126 Rel8.Schema.Context.Nullify

121 Rel8.Schema.Dict

127 Rel8.Schema.Dict

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

164 Rel8.Table.Maybe

170 Rel8.Table.Maybe

165 Rel8.Table.Name

171 Rel8.Table.Name

166 Rel8.Table.NonEmpty

172 Rel8.Table.NonEmpty

173+ Rel8.Table.Null

167 Rel8.Table.Nullify

174 Rel8.Table.Nullify

168 Rel8.Table.Opaleye

175 Rel8.Table.Opaleye

169 Rel8.Table.Ord

176 Rel8.Table.Ord

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

174 Rel8.Table.These

181 Rel8.Table.These

175 Rel8.Table.Transpose

182 Rel8.Table.Transpose

176 Rel8.Table.Undefined

183 Rel8.Table.Undefined

184+ Rel8.Table.Window

177

185

178 Rel8.Type

186 Rel8.Type

179 Rel8.Type.Array

187 Rel8.Type.Array

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

192 Rel8.Type.Sum

200 Rel8.Type.Sum

193 Rel8.Type.Tag

201 Rel8.Type.Tag

194

202

203+ Rel8.Window

204+

205+

195test-suite tests

206test-suite tests

196 type: exitcode-stdio-1.0

207 type: exitcode-stdio-1.0

197 build-depends:

208 build-depends:

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

201 , containers

212 , containers

202 , hasql

213 , hasql

203 , hasql-transaction

214 , hasql-transaction

204− , hedgehog ^>=1.0.2

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

205 , mmorph

216 , mmorph

206 , rel8

217 , rel8

207 , scientific

218 , scientific

shell.nix+1−1

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

1let

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

3− pkgs = import sources.nixpkgs {};

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

4 hsPkgs = import ./default.nix;

5in

6 hsPkgs.shellFor {

src/Rel8.hs+277−8

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

38 , HMaybe

39 , HList

40 , HNonEmpty

41+ , HNull

41 , HThese

42 , HThese

42 , Lift

43 , Lift

43

44

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

46 , Transposes

47 , Transposes

47 , AltTable((<|>:))

48 , AltTable((<|>:))

48 , AlternativeTable( emptyTable )

49 , AlternativeTable( emptyTable )

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

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

50− , OrdTable, ascTable, descTable

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

51 , lit

52 , lit

52 , bool

53 , bool

53 , case_

54 , case_

55+ , castTable

54

56

55 -- ** @MaybeTable@

57 -- ** @MaybeTable@

56 , MaybeTable

58 , MaybeTable

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

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

58 , isNothingTable, isJustTable

60 , isNothingTable, isJustTable

61+ , fromMaybeTable

59 , optional

62 , optional

60 , catMaybeTable

63 , catMaybeTable

61 , traverseMaybeTable

64 , traverseMaybeTable

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

78 , isThisTable, isThatTable, isThoseTable

81 , isThisTable, isThatTable, isThoseTable

79 , hasHereTable, hasThereTable

82 , hasHereTable, hasThereTable

80 , justHereTable, justThereTable

83 , justHereTable, justThereTable

84+ , alignMaybeTable

81 , alignBy

85 , alignBy

82 , keepHereTable, loseHereTable

86 , keepHereTable, loseHereTable

83 , keepThereTable, loseThereTable

87 , keepThereTable, loseThereTable

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

90

94

91 -- ** @ListTable@

95 -- ** @ListTable@

92 , ListTable

96 , ListTable

93− , listTable

97+ , listTable, ($*)

94 , nameListTable

98 , nameListTable

95 , many

99 , many

96 , manyExpr

100 , manyExpr

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

99

103

100 -- ** @NonEmptyTable@

104 -- ** @NonEmptyTable@

101 , NonEmptyTable

105 , NonEmptyTable

102− , nonEmptyTable

106+ , nonEmptyTable, ($+)

103 , nameNonEmptyTable

107 , nameNonEmptyTable

104 , some

108 , some

105 , someExpr

109 , someExpr

106 , catNonEmptyTable

110 , catNonEmptyTable

107 , catNonEmpty

111 , catNonEmpty

108

112

109− -- ** @ADT@

113+ -- ** @NullTable@

114+ , NullTable

115+ , nullableTable, nullTable, nullifyTable

116+ , isNullTable, isNonNullTable

117+ , catNullTable

118+ , nameNullTable

119+ , toNullTable, toMaybeTable

120+

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

122+ -- $adts

123+

124+ -- *** Naming of ADTs

125+ -- $naming

126+ , NameADT, nameADT

110 , ADT, ADTable

127 , ADT, ADTable

128+

129+ -- *** Deconstruction of ADTs

130+ -- $deconstruction

131+ , DeconstructADT, deconstructADT

132+

133+ -- *** Construction of ADTs

134+ -- $construction

111 , BuildADT, buildADT

135 , BuildADT, buildADT

112 , ConstructADT, constructADT

136 , ConstructADT, constructADT

113− , DeconstructADT, deconstructADT

137+

114− , NameADT, nameADT

138+ -- *** Other ADT operations

115 , AggregateADT, aggregateADT

139 , AggregateADT, aggregateADT

116

140

141+ -- *** Miscellaneous notes

142+ -- $misc-notes

143+

117 -- ** @HKD@

144 -- ** @HKD@

118 , HKD, HKDable

145 , HKD, HKDable

119 , BuildHKD, buildHKD

146 , BuildHKD, buildHKD

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

138 -- ** @null@

165 -- ** @null@

139 , NotNull

166 , NotNull

140 , Nullable

167 , Nullable

168+ , Homonullable

141 , null

169 , null

142 , nullify

170 , nullify

143 , nullable

171 , nullable

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

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

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

157 , in_

185 , in_

158 , boolExpr, caseExpr

186 , boolExpr, caseExpr

187+ , like, ilike

159

188

160 -- ** Ordering

189 -- ** Ordering

161 , DBOrd

190 , DBOrd

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

224 , countRows

253 , countRows

225 , groupBy

254 , groupBy

226 , listAgg, listAggExpr

255 , listAgg, listAggExpr

256+ , mode

227 , nonEmptyAgg, nonEmptyAggExpr

257 , nonEmptyAgg, nonEmptyAggExpr

228 , DBMax, max

258 , DBMax, max

229 , DBMin, min

259 , DBMin, min

230− , DBSum, sum, sumWhere

260+ , DBSum, sum, sumWhere, avg

231 , DBString, stringAgg

261 , DBString, stringAgg

232 , count

262 , count

233 , countStar

263 , countStar

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

244 , nullsFirst

274 , nullsFirst

245 , nullsLast

275 , nullsLast

246

276

277+ -- ** Window functions

278+ , Window

279+ , window

280+ , Partition

281+ , over

282+ , partitionBy

283+ , orderPartitionBy

284+ , cumulative

285+ , cumulative_

286+ , currentRow

287+ , rowNumber

288+ , rank

289+ , denseRank

290+ , percentRank

291+ , cumeDist

292+ , ntile

293+ , lag

294+ , lead

295+ , firstValue

296+ , lastValue

297+ , nthValue

298+ , indexed

299+

247 -- ** Bindings

300 -- ** Bindings

248 , rebind

301 , rebind

249

302

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

281

334

282 -- ** @CREATE VIEW@

335 -- ** @CREATE VIEW@

283 , createView

336 , createView

337+ , createOrReplaceView

284

338

285 -- ** Sequences

339 -- ** Sequences

286 , nextval

340 , nextval

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

299import Rel8.Column.List

353import Rel8.Column.List

300import Rel8.Column.Maybe

354import Rel8.Column.Maybe

301import Rel8.Column.NonEmpty

355import Rel8.Column.NonEmpty

356+import Rel8.Column.Null

302import Rel8.Column.These

357import Rel8.Column.These

303import Rel8.Expr

358import Rel8.Expr

304import Rel8.Expr.Aggregate

359import Rel8.Expr.Aggregate

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

312import Rel8.Expr.Order

367import Rel8.Expr.Order

313import Rel8.Expr.Serialize

368import Rel8.Expr.Serialize

314import Rel8.Expr.Sequence

369import Rel8.Expr.Sequence

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

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

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

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

316import Rel8.Order

373import Rel8.Order

317import Rel8.Query

374import Rel8.Query

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

322import Rel8.Query.Evaluate

379import Rel8.Query.Evaluate

323import Rel8.Query.Exists

380import Rel8.Query.Exists

324import Rel8.Query.Filter

381import Rel8.Query.Filter

382+import Rel8.Query.Indexed

325import Rel8.Query.Limit

383import Rel8.Query.Limit

326import Rel8.Query.List

384import Rel8.Query.List

327import Rel8.Query.Maybe

385import Rel8.Query.Maybe

328import Rel8.Query.Null

386import Rel8.Query.Null

329import Rel8.Query.Order

387import Rel8.Query.Order

388+import Rel8.Query.Rebind

330import Rel8.Query.SQL (showQuery)

389import Rel8.Query.SQL (showQuery)

331import Rel8.Query.Set

390import Rel8.Query.Set

332import Rel8.Query.These

391import Rel8.Query.These

333import Rel8.Query.Values

392import Rel8.Query.Values

393+import Rel8.Query.Window

334import Rel8.Schema.Field

394import Rel8.Schema.Field

335import Rel8.Schema.HTable

395import Rel8.Schema.HTable

336import Rel8.Schema.Name

396import Rel8.Schema.Name

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

357import Rel8.Table.Maybe

417import Rel8.Table.Maybe

358import Rel8.Table.Name

418import Rel8.Table.Name

359import Rel8.Table.NonEmpty

419import Rel8.Table.NonEmpty

420+import Rel8.Table.Null

421+import Rel8.Table.Opaleye ( castTable )

360import Rel8.Table.Ord

422import Rel8.Table.Ord

361import Rel8.Table.Order

423import Rel8.Table.Order

362import Rel8.Table.Projection

424import Rel8.Table.Projection

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

364import Rel8.Table.Serialize

426import Rel8.Table.Serialize

365import Rel8.Table.These

427import Rel8.Table.These

366import Rel8.Table.Transpose

428import Rel8.Table.Transpose

429+import Rel8.Table.Window

367import Rel8.Type

430import Rel8.Type

368import Rel8.Type.Composite

431import Rel8.Type.Composite

369import Rel8.Type.Eq

432import Rel8.Type.Eq

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

378import Rel8.Type.Semigroup

441import Rel8.Type.Semigroup

379import Rel8.Type.String

442import Rel8.Type.String

380import Rel8.Type.Sum

443import Rel8.Type.Sum

444+import Rel8.Window

381

445

382

446

383-- $running

447-- $running

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

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

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

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

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

387-- `DuplicateRecordFields` language extension enabled.

451-- `DuplicateRecordFields` language extension enabled.

452+

453+-- $adts

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

455+--

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

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

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

459+--

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

461+--

462+-- @

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

464+-- deriving stock Generic

465+--

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

467+-- deriving stock Generic

468+-- deriving anyclass Rel8able

469+--

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

471+-- deriving stock Generic

472+-- deriving anyclass Rel8able

473+-- @

474+

475+-- $naming

476+--

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

478+--

479+-- @

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

481+-- thingSchema =

482+-- TableSchema

483+-- { schema = Nothing,

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

485+-- columns =

486+-- nameADT @Thing

487+-- \"tag\"

488+-- Employer

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

490+-- employerId = \"id\"

491+-- }

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

493+-- }

494+-- @

495+--

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

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

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

499+

500+-- $deconstruction

501+--

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

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

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

505+--

506+-- @

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

508+-- query = do

509+-- thingExpr <- each thingSchema

510+-- where_ $

511+-- deconstructADT @Thing

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

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

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

515+-- thingExpr

516+-- pure thingExpr

517+-- @

518+--

519+-- SQL output:

520+--

521+-- @

522+-- SELECT

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

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

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

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

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

528+-- FROM (SELECT

529+-- *

530+-- FROM (SELECT

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

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

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

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

535+-- "Mary" as "Mary4_1"

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

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

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

539+-- @

540+

541+-- $construction

542+--

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

544+--

545+-- @

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

547+-- @

548+--

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

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

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

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

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

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

555+--

556+-- @

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

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

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

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

561+-- @

562+--

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

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

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

566+--

567+-- @

568+-- > :t lit . Complete

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

570+-- @

571+--

572+--

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

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

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

576+-- query.

577+--

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

579+--

580+-- @

581+-- > :{

582+-- showQuery $ values

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

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

585+-- ]

586+-- :}

587+-- @

588+--

589+-- This produces the following SQL:

590+--

591+-- @

592+-- SELECT

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

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

595+-- FROM (SELECT

596+-- *

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

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

599+-- FROM

600+-- (VALUES

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

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

603+-- @

604+--

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

606+--

607+--

608+-- @

609+-- tag | Complete/_1/date

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

611+-- Pending |

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

613+-- (2 rows)

614+-- @

615+--

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

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

618+-- to make sense:

619+--

620+-- @

621+-- > :t constructADT @Task

622+-- constructADT @Task

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

624+-- @

625+--

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

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

628+-- might use it as follows:

629+--

630+-- @

631+-- let

632+-- pending :: ADT Task Expr

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

634+--

635+-- complete :: ADT Task Expr

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

637+-- @

638+--

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

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

641+--

642+

643+-- $misc-notes

644+--

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

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

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

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

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

650+--

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

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

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

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

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

656+-- matching in PostgreSQL.

src/Rel8/Aggregate.hs+19−43

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

2{-# language FlexibleContexts #-}

3{-# language FlexibleInstances #-}

4{-# language MultiParamTypeClasses #-}

5−{-# language NamedFieldPuns #-}

6{-# language RankNTypes #-}

5{-# language RankNTypes #-}

7{-# language StandaloneKindSignatures #-}

6{-# language StandaloneKindSignatures #-}

8{-# language TypeFamilies #-}

7{-# language TypeFamilies #-}

9{-# language UndecidableInstances #-}

8{-# language UndecidableInstances #-}

10

9

11module Rel8.Aggregate

10module Rel8.Aggregate

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

11+ ( Aggregate(..), zipOutputs

13− , Aggregator(..), unsafeMakeAggregate

12+ , unsafeMakeAggregate

14 , Aggregates

13 , Aggregates

15 )

14 )

16where

15where

17

16

18-- base

17-- base

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

18+import Control.Applicative ( liftA2 )

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

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

21import Data.Kind ( Constraint, Type )

20import Data.Kind ( Constraint, Type )

22import Prelude

21import Prelude

23

22

23+-- profunctors

24+import Data.Profunctor ( dimap )

25+

24-- opaleye

26-- opaleye

25−import qualified Opaleye.Internal.Aggregate as Opaleye

27+import qualified Opaleye.Aggregate as Opaleye

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

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

27−import qualified Opaleye.Internal.PackMap as Opaleye

29+import qualified Opaleye.Internal.Column as Opaleye

28

30

29-- rel8

31-- rel8

30import Rel8.Expr ( Expr )

32import Rel8.Expr ( Expr )

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

40import Rel8.Type ( DBType )

42import Rel8.Type ( DBType )

41

43

42

44

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

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

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

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

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

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

48type Aggregate :: K.Context

46type Aggregate :: K.Context

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

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

50

48

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

61 fromResult (HIdentity (Identity a)) = a

59 fromResult (HIdentity (Identity a)) = a

62

60

63

61

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

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

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

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

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

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

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

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

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

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

69

67

70

68

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

69+zipOutputs :: ()

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

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

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

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

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

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

76− where

77− detuplize (operation, ordering, distinction) =

78− Aggregator {operation, ordering, distinction}

79−

80−

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

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

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

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

85− f (fmap transform input)

86−

87−

88−type Aggregator :: Type

89−data Aggregator = Aggregator

90− { operation :: Opaleye.AggrOp

91− , ordering :: [Opaleye.OrderExpr]

92− , distinction :: Opaleye.AggrDistinct

93− }

94

72

95

73

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

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

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

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

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

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

99− -> Maybe Aggregator

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

100 -> Expr input

78 -> Expr input

101 -> Aggregate output

79 -> Aggregate output

102unsafeMakeAggregate input output aggregator expr =

80unsafeMakeAggregate input output aggregator expr =

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

81+ Aggregate $ dimap in_ out aggregator

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

82+ where out = output . Opaleye.unColumn

105− where

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

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

107− (operation, ordering, distinction)

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

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

1+{-# language DataKinds #-}

2+{-# language StandaloneKindSignatures #-}

3+{-# language TypeFamilyDependencies #-}

4+

5+module Rel8.Column.Null

6+ ( HNull

7+ )

8+where

9+

10+-- base

11+import Data.Kind ( Type )

12+import Prelude

13+

14+-- rel8

15+import qualified Rel8.Schema.Kind as K

16+import Rel8.Schema.Result ( Result )

17+import Rel8.Table.Null ( NullTable )

18+

19+

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

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

22+-- context.

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

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

25+ HNull Result = Maybe

26+ HNull context = NullTable context

src/Rel8/Expr.hs+1

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

1{-# language DataKinds #-}

2{-# language DerivingStrategies #-}

3+{-# language FlexibleContexts #-}

3{-# language FlexibleInstances #-}

4{-# language FlexibleInstances #-}

4{-# language MultiParamTypeClasses #-}

5{-# language MultiParamTypeClasses #-}

5{-# language ScopedTypeVariables #-}

6{-# language ScopedTypeVariables #-}

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

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

10 , and, or

11 , min, max

12 , sum, sumWhere

13+ , avg

13 , stringAgg

14 , stringAgg

14 , groupByExpr

15 , groupByExpr

15 , listAggExpr, nonEmptyAggExpr

16 , listAggExpr, nonEmptyAggExpr

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

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

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

24

25

25-- opaleye

26-- opaleye

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

27+import qualified Opaleye.Internal.Aggregate as Opaleye

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

29+import qualified Opaleye.Aggregate as Opaleye

27

30

28-- rel8

31-- rel8

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

32+import Rel8.Aggregate ( Aggregate, unsafeMakeAggregate )

30import Rel8.Expr ( Expr )

33import Rel8.Expr ( Expr )

31import Rel8.Expr.Bool ( caseExpr )

34import Rel8.Expr.Bool ( caseExpr )

32import Rel8.Expr.Opaleye

35import Rel8.Expr.Opaleye

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

50

53

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

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

52count :: Expr a -> Aggregate Int64

55count :: Expr a -> Aggregate Int64

53−count = unsafeMakeAggregate toPrimExpr fromPrimExpr $

56+count = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.count

54− Just Aggregator

55− { operation = Opaleye.AggrCount

56− , ordering = []

57− , distinction = Opaleye.AggrAll

58− }

59−

60

57

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

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

62-- @COUNT(DISTINCT a)@

59-- @COUNT(DISTINCT a)@

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

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

64countDistinct = unsafeMakeAggregate toPrimExpr fromPrimExpr $

61countDistinct = unsafeMakeAggregate toPrimExpr fromPrimExpr $

65− Just Aggregator

62+ Opaleye.distinctAggregator Opaleye.count

66− { operation = Opaleye.AggrCount

67− , ordering = []

68− , distinction = Opaleye.AggrDistinct

69− }

70

63

71

64

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

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

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

81

74

82-- | Corresponds to @bool_and@.

75-- | Corresponds to @bool_and@.

83and :: Expr Bool -> Aggregate Bool

76and :: Expr Bool -> Aggregate Bool

84−and = unsafeMakeAggregate toPrimExpr fromPrimExpr $

77+and = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.boolAnd

85− Just Aggregator

86− { operation = Opaleye.AggrBoolAnd

87− , ordering = []

88− , distinction = Opaleye.AggrAll

89− }

90

78

91

79

92-- | Corresponds to @bool_or@.

80-- | Corresponds to @bool_or@.

93or :: Expr Bool -> Aggregate Bool

81or :: Expr Bool -> Aggregate Bool

94−or = unsafeMakeAggregate toPrimExpr fromPrimExpr $

82+or = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.boolOr

95− Just Aggregator

96− { operation = Opaleye.AggrBoolOr

97− , ordering = []

98− , distinction = Opaleye.AggrAll

99− }

100

83

101

84

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

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

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

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

104−max = unsafeMakeAggregate toPrimExpr fromPrimExpr $

87+max = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.unsafeMax

105− Just Aggregator

106− { operation = Opaleye.AggrMax

107− , ordering = []

108− , distinction = Opaleye.AggrAll

109− }

110

88

111

89

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

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

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

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

114−min = unsafeMakeAggregate toPrimExpr fromPrimExpr $

92+min = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.unsafeMin

115− Just Aggregator

116− { operation = Opaleye.AggrMin

117− , ordering = []

118− , distinction = Opaleye.AggrAll

119− }

120

93

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

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

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

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

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

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

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

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

125-- your input.

98-- your input.

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

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

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

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

128− Just Aggregator

101+

129− { operation = Opaleye.AggrSum

130− , ordering = []

131− , distinction = Opaleye.AggrAll

132− }

133

102

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

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

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

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

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

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

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

134

110

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

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

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

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

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

142stringAgg :: Sql DBString a

118stringAgg :: Sql DBString a

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

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

144stringAgg delimiter =

120stringAgg delimiter =

145− unsafeMakeAggregate toPrimExpr (castExpr . fromPrimExpr) $

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

146− Just Aggregator

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

148− , ordering = []

149− , distinction = Opaleye.AggrAll

150− }

151

122

152

123

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

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

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

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

155−groupByExpr = unsafeMakeAggregate toPrimExpr fromPrimExpr Nothing

126+groupByExpr = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.groupBy

156

127

157

128

158-- | Collect expressions values as a list.

129-- | Collect expressions values as a list.

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

167

138

168slistAggExpr :: ()

139slistAggExpr :: ()

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

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

170−slistAggExpr info = unsafeMakeAggregate to fromPrimExpr $ Just

141+slistAggExpr info = unsafeMakeAggregate to fromPrimExpr Opaleye.arrayAgg

171− Aggregator

172− { operation = Opaleye.AggrArr

173− , ordering = []

174− , distinction = Opaleye.AggrAll

175− }

176 where

142 where

177 to = encodeArrayElement info . toPrimExpr

143 to = encodeArrayElement info . toPrimExpr

178

144

179

145

180snonEmptyAggExpr :: ()

146snonEmptyAggExpr :: ()

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

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

182−snonEmptyAggExpr info = unsafeMakeAggregate to fromPrimExpr $ Just

148+snonEmptyAggExpr info = unsafeMakeAggregate to fromPrimExpr Opaleye.arrayAgg

183− Aggregator

184− { operation = Opaleye.AggrArr

185− , ordering = []

186− , distinction = Opaleye.AggrAll

187− }

188 where

149 where

189 to = encodeArrayElement info . toPrimExpr

150 to = encodeArrayElement info . toPrimExpr

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

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

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

5

6module Rel8.Expr.Num

7+ ( fromIntegral

8+ , realToFrac

9+ , div, mod, divMod

10+ , quot, rem, quotRem

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

11+ , ceiling, floor, round, truncate

8 )

12 )

9where

13where

10

14

11-- base

15-- base

12−import Prelude ()

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

13

17

14-- rel

18-- rel

15import Rel8.Expr ( Expr( Expr ) )

19import Rel8.Expr ( Expr( Expr ) )

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

16import Rel8.Expr.Function ( function )

21import Rel8.Expr.Function ( function )

17import Rel8.Expr.Opaleye ( castExpr )

22import Rel8.Expr.Opaleye ( castExpr )

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

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

24+import Rel8.Table.Bool ( bool )

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

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

20

26

21

27

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

42ceiling = function "ceiling"

48ceiling = function "ceiling"

43

49

44

50

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

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

52+-- PostgreSQL.

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

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

47−div = function "div"

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

48

55

49

56

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

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

58+-- PostgreSQL.

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

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

52−mod = function "mod"

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

61+

62+

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

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

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

66+ where

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

68+

69+

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

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

72+-- 'Prelude.div'.

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

74+quot = function "div"

75+

76+

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

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

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

80+rem = function "mod"

81+

82+

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

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

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

53

86

54

87

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

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

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

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

10 , scastExpr, sunsafeCastExpr

11 , unsafeLiteral

12 , fromPrimExpr, toPrimExpr, mapPrimExpr, zipPrimExprsWith, traversePrimExpr

13− , toColumn, fromColumn

13+ , toColumn, fromColumn, traverseFieldP

14 )

15where

16

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

27import Rel8.Type ( DBType, typeInformation )

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

29

30+-- profunctors

31+import Data.Profunctor ( Profunctor, dimap )

32+

30

33

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

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

32castExpr = scastExpr typeInformation

35castExpr = scastExpr typeInformation

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

80traversePrimExpr f = fmap fromPrimExpr . f . toPrimExpr

83traversePrimExpr f = fmap fromPrimExpr . f . toPrimExpr

81

84

82

85

86+traverseFieldP :: Profunctor p

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

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

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

90+

91+

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

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

84toColumn = Opaleye.Column

93toColumn = Opaleye.Column

85

94

86

95

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

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

88fromColumn (Opaleye.Column a) = a

97fromColumn (Opaleye.Column a) = a

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

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

11import Rel8.Expr ( Expr )

12import Rel8.Expr.Function ( function )

13import Rel8.Expr.Serialize ( litExpr )

14+import Rel8.Expr.Text ( quoteIdent )

14

15

15-- text

16-- text

16import Data.Text ( pack )

17import Data.Text ( pack )

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

18

19

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

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

20nextval :: String -> Expr Int64

21nextval :: String -> Expr Int64

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

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

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

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

17 , pgClientEncoding, quoteIdent, quoteLiteral, quoteNullable, regexpReplace

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

19 , splitPart, strpos, substr, translate

20+

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

22+ , like, ilike

20 )

23 )

21where

24where

22

25

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

24import Data.Bool ( Bool )

27import Data.Bool ( Bool )

25import Data.Int ( Int32 )

28import Data.Int ( Int32 )

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

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

27−import Prelude ()

30+import Prelude ( flip )

28

31

29-- bytestring

32-- bytestring

30import Data.ByteString ( ByteString )

33import Data.ByteString ( ByteString )

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

49

52

50

53

51-- | Matches regular expression, case sensitive

54-- | Matches regular expression, case sensitive

52−--

55+--

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

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

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

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

55(~.) = binaryOperator "~."

58(~.) = binaryOperator "~."

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

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

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

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

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

275translate = function "translate"

278translate = function "translate"

279+

280+

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

282+--

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

284+-- you can write expressions like

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

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

287+like = flip (binaryOperator "LIKE")

288+

289+

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

291+--

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

293+-- you can write expressions like

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

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

296+ilike = flip (binaryOperator "ILIKE")

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

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

1+module Rel8.Expr.Window

2+ ( cumulative

3+ , rowNumber

4+ , rank

5+ , denseRank

6+ , percentRank

7+ , cumeDist

8+ , ntile

9+ , lag

10+ , lead

11+ , firstValue

12+ , lastValue

13+ , nthValue

14+ )

15+where

16+

17+-- base

18+import Data.Int ( Int32, Int64 )

19+import Prelude

20+

21+-- opaleye

22+import qualified Opaleye.Internal.Aggregate as Opaleye

23+import qualified Opaleye.Internal.PackMap as Opaleye

24+import qualified Opaleye.Internal.Window as Opaleye

25+import qualified Opaleye.Window as Opaleye

26+

27+-- profunctors

28+import Data.Profunctor (dimap)

29+

30+-- rel8

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

32+import Rel8.Expr ( Expr )

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

34+import Rel8.Schema.Null ( Nullify )

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

36+

37+

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

39+cumulative f =

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

41+

42+

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

44+rowNumber :: Window a (Expr Int64)

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

46+

47+

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

49+rank :: Window a (Expr Int64)

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

51+

52+

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

54+denseRank :: Window a (Expr Int64)

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

56+

57+

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

59+percentRank :: Window a (Expr Double)

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

61+

62+

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

64+cumeDist :: Window a (Expr Double)

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

66+

67+

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

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

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

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

72+

73+

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

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

76+lag offset def =

77+ fromWindowFunction $

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

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

80+

81+

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

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

84+lead offset def =

85+ fromWindowFunction $

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

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

88+

89+

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

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

92+firstValue =

93+ fromWindowFunction $

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

95+ Opaleye.firstValue

96+

97+

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

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

100+lastValue =

101+ fromWindowFunction $

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

103+ Opaleye.lastValue

104+

105+

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

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

108+nthValue n =

109+ fromWindowFunction $

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

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

112+

113+

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

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

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

117+

118+

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

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

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

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

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

1{-# language AllowAmbiguousTypes #-}

2{-# language BlockArguments #-}

3{-# language DataKinds #-}

4+{-# language FlexibleContexts #-}

4{-# language FlexibleInstances #-}

5{-# language FlexibleInstances #-}

5{-# language MultiParamTypeClasses #-}

6{-# language MultiParamTypeClasses #-}

6{-# language RankNTypes #-}

7{-# language RankNTypes #-}

src/Rel8/Generic/Record.hs+2

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

1{-# language AllowAmbiguousTypes #-}

2{-# language DataKinds #-}

3+{-# language FlexibleContexts #-}

3{-# language FlexibleInstances #-}

4{-# language FlexibleInstances #-}

4{-# language MultiParamTypeClasses #-}

5{-# language MultiParamTypeClasses #-}

5{-# language PolyKinds #-}

6{-# language PolyKinds #-}

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

141 uncount = id

142 uncount = id

142

143

144

145+type Record :: Type -> Type

144newtype Record a = Record

146newtype Record a = Record

145 { unrecord :: a

147 { unrecord :: a

146 }

148 }

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

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

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

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

65type family a == b where

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

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

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

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

70+

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

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

67 -- which occurs when we have polymorphic Rel8ables

72 -- which occurs when we have polymorphic Rel8ables

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

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

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

141-- [Supplying @Rel8able@ instances]

146-- [Supplying @Rel8able@ instances]

142--

147--

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

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

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

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

145-- extensions:

150-- extensions:

146--

151--

147-- @

152-- @

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

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

1{-# language AllowAmbiguousTypes #-}

2{-# language DataKinds #-}

3+{-# language FlexibleContexts #-}

3{-# language FlexibleInstances #-}

4{-# language FlexibleInstances #-}

4{-# language LambdaCase #-}

5{-# language LambdaCase #-}

5{-# language MultiParamTypeClasses #-}

6{-# language MultiParamTypeClasses #-}

src/Rel8/Order.hs+1−8

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

4

5module Rel8.Order

6 ( Order(..)

7− , toOrderExprs

8 )

7 )

9where

8where

10

9

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

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

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

18

17

19-- opaleye

18-- opaleye

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

19+import qualified Opaleye.Order as Opaleye

21−import qualified Opaleye.Internal.Order as Opaleye

22

20

23

21

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

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

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

30type Order :: Type -> Type

28type Order :: Type -> Type

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

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

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

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

33−

34−

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

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

37− uncurry Opaleye.OrderExpr <$> order a

src/Rel8/Query.hs+23−10

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

1+{-# language FlexibleContexts #-}

1{-# language StandaloneKindSignatures #-}

2{-# language StandaloneKindSignatures #-}

3+{-# language UndecidableInstances #-}

2

4

3module Rel8.Query

5module Rel8.Query

4 ( Query( Query )

6 ( Query( Query )

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

15-- opaleye

17-- opaleye

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

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

17import qualified Opaleye.Internal.PackMap as Opaleye

19import qualified Opaleye.Internal.PackMap as Opaleye

18−import qualified Opaleye.Internal.PrimQuery as Opaleye

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

19import qualified Opaleye.Internal.QueryArr as Opaleye

21import qualified Opaleye.Internal.QueryArr as Opaleye

20import qualified Opaleye.Internal.Tag as Opaleye

22import qualified Opaleye.Internal.Tag as Opaleye

21

23

22-- rel8

24-- rel8

25+import Rel8.Expr ( Expr )

23import Rel8.Query.Set ( unionAll )

26import Rel8.Query.Set ( unionAll )

24import Rel8.Query.Opaleye ( fromOpaleye )

27import Rel8.Query.Opaleye ( fromOpaleye )

25import Rel8.Query.Values ( values )

28import Rel8.Query.Values ( values )

26−import Rel8.Table ( fromColumns, toColumns )

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

27import Rel8.Table.Alternative

30import Rel8.Table.Alternative

28 ( AltTable, (<|>:)

31 ( AltTable, (<|>:)

29 , AlternativeTable, emptyTable

32 , AlternativeTable, emptyTable

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

175

178

176

179

177instance Monad Query where

180instance Monad Query where

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

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

179 let

182 let

180− Opaleye.QueryArr qa = q dummies

183+ qa = q dummies

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

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

182 Query q' = f a

185 Query q' = f a

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

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

184 ( dummy : dummies

187 ( dummy : dummies

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

188+ , query <> Opaleye.aRebind bindings

186 , Opaleye.next tag'

189 , Opaleye.next tag'

187 )

190 )

188 where

191 where

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

190 where

193 where

191 random = Opaleye.FunExpr "random" []

194 random = Opaleye.FunExpr "random" []

192 name = Opaleye.extractAttr "dummy" tag'

195 name = Opaleye.extractAttr "dummy" tag'

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

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

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

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

195 query'''

198 query'''

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

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

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

200+ | otherwise = query <> query''

198 m'' = m <> m'

201 m'' = m <> m'

199 in

202 in

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

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

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

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

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

209instance AlternativeTable Query where

212instance AlternativeTable Query where

210 emptyTable = values []

213 emptyTable = values []

214+

215+

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

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

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

219+

220+

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

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

223+ mempty = emptyTable

src/Rel8/Query/Aggregate.hs+19

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

1{-# language FlexibleContexts #-}

2{-# language MonoLocalBinds #-}

3+{-# language ScopedTypeVariables #-}

4+{-# language TypeApplications #-}

3

5

4module Rel8.Query.Aggregate

6module Rel8.Query.Aggregate

5 ( aggregate

7 ( aggregate

6 , countRows

8 , countRows

9+ , mode

7 )

10 )

8where

11where

9

12

10-- base

13-- base

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

11import Data.Int ( Int64 )

15import Data.Int ( Int64 )

12import Prelude

16import Prelude

13

17

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

18import Rel8.Aggregate ( Aggregates )

22import Rel8.Aggregate ( Aggregates )

19import Rel8.Expr ( Expr )

23import Rel8.Expr ( Expr )

20import Rel8.Expr.Aggregate ( countStar )

24import Rel8.Expr.Aggregate ( countStar )

25+import Rel8.Expr.Order ( desc )

21import Rel8.Query ( Query )

26import Rel8.Query ( Query )

27+import Rel8.Query.Limit ( limit )

22import Rel8.Query.Maybe ( optional )

28import Rel8.Query.Maybe ( optional )

23import Rel8.Query.Opaleye ( mapOpaleye )

29import Rel8.Query.Opaleye ( mapOpaleye )

30+import Rel8.Query.Order ( orderBy )

31+import Rel8.Table ( toColumns )

32+import Rel8.Table.Aggregate ( hgroupBy )

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

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

24import Rel8.Table.Opaleye ( aggregator )

35import Rel8.Table.Opaleye ( aggregator )

25import Rel8.Table.Maybe ( maybeTable )

36import Rel8.Table.Maybe ( maybeTable )

26

37

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

35-- will return @0@.

46-- will return @0@.

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

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

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

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

49+

50+

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

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

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

54+ aggregate $ do

55+ row <- toColumns <$> rows

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

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

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

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

2−

3module Rel8.Query.Distinct

1module Rel8.Query.Distinct

4 ( distinct

2 ( distinct

5 , distinctOn

3 , distinctOn

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

8where

6where

9

7

10-- base

8-- base

11−import Prelude

9+import Prelude ()

12

10

13-- opaleye

11-- opaleye

14import qualified Opaleye.Distinct as Opaleye

12import qualified Opaleye.Distinct as Opaleye

15−import qualified Opaleye.Internal.Order as Opaleye

13+import qualified Opaleye.Order as Opaleye

16−import qualified Opaleye.Internal.QueryArr as Opaleye

17

14

18-- rel8

15-- rel8

19import Rel8.Order ( Order( Order ) )

16import Rel8.Order ( Order( Order ) )

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

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

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

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

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

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

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

36−distinctOn proj =

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

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

38

34

39

35

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

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

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

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

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

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

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

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

44−distinctOnBy proj (Order order) =

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

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

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

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

3

4module Rel8.Query.Evaluate

5 ( evaluate

6− , rebind

7 )

6 )

8where

7where

9

8

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

16

15

17-- opaleye

16-- opaleye

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

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

19−import qualified Opaleye.Internal.PackMap as Opaleye

20−import qualified Opaleye.Internal.PrimQuery as Opaleye

21−import qualified Opaleye.Internal.QueryArr as Opaleye

22−import qualified Opaleye.Internal.Tag as Opaleye

23−import qualified Opaleye.Internal.Unpackspec as Opaleye

24

18

25-- rel8

19-- rel8

26import Rel8.Expr ( Expr )

20import Rel8.Expr ( Expr )

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

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

28import Rel8.Expr.Opaleye ( fromPrimExpr )

22import Rel8.Expr.Opaleye ( fromPrimExpr )

29import Rel8.Query ( Query( Query ) )

23import Rel8.Query ( Query( Query ) )

24+import Rel8.Query.Rebind ( rebind )

30import Rel8.Table ( Table )

25import Rel8.Table ( Table )

31import Rel8.Table.Bool ( case_ )

26import Rel8.Table.Bool ( case_ )

32−import Rel8.Table.Opaleye ( unpackspec )

27+import Rel8.Table.Undefined ( undefined )

33−import Rel8.Table.Undefined

34

28

35

29

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

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

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

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

38-- effects and can safely be reused.

32-- effects and can safely be reused.

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

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

40−evaluate = laterally >=> rebind

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

41

35

42

36

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

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

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

51 go = fromPrimExpr . Opaleye.UnExpr Opaleye.OpIsNotNull

45 go = fromPrimExpr . Opaleye.UnExpr Opaleye.OpIsNotNull

52

46

53

47

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

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

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

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

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

59− let

60− tag' = Opaleye.next tag

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

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

63− in

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

65−

66−

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

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

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

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

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

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

12

13-- opaleye

14import qualified Opaleye.Exists as Opaleye

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

15+import qualified Opaleye.Operators as Opaleye

16

17-- rel8

18import Rel8.Expr ( Expr )

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

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

1+module Rel8.Query.Indexed

2+ ( indexed

3+ )

4+where

5+

6+-- base

7+import Control.Applicative ( liftA2 )

8+import Data.Int ( Int64 )

9+import Prelude

10+

11+-- rel8

12+import Rel8.Expr ( Expr )

13+import Rel8.Expr.Window ( rowNumber )

14+import Rel8.Query ( Query )

15+import Rel8.Query.Window ( window )

16+import Rel8.Table.Window ( currentRow )

17+

18+

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

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

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

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

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

24import Rel8.Expr.Opaleye ( mapPrimExpr )

25import Rel8.Query ( Query )

26import Rel8.Query.Aggregate ( aggregate )

27−import Rel8.Query.Evaluate ( rebind )

28import Rel8.Query.Maybe ( optional )

27import Rel8.Query.Maybe ( optional )

28+import Rel8.Query.Rebind ( rebind )

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

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

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

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

85--

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

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

88+catListTable (ListTable as) =

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

89+ rebind "unnest" $ fromColumns $ runIdentity $

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

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

90

91

92

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

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

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

94--

95--

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

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

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

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

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

98+catNonEmptyTable (NonEmptyTable as) =

99+ rebind "unnest" $ fromColumns $ runIdentity $

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

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

99

101

100

102

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

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

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

103--

105--

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

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

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

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

106−catList = rebind . sunnest typeInformation

108+catList = rebind "unnest" . sunnest typeInformation

107

109

108

110

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

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

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

111--

113--

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

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

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

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

114−catNonEmpty = rebind . sunnest typeInformation

116+catNonEmpty = rebind "unnest" . sunnest typeInformation

115

117

116

118

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

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

src/Rel8/Query/Null.hs+15

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

1+{-# language FlexibleContexts #-}

2+

1module Rel8.Query.Null

3module Rel8.Query.Null

2 ( catNull

4 ( catNull

5+ , catNullTable

3 )

6 )

4where

7where

5

8

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

9-- rel8

12-- rel8

10import Rel8.Expr ( Expr )

13import Rel8.Expr ( Expr )

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

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

15+import Rel8.Table ( Table )

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

12import Rel8.Query ( Query )

17import Rel8.Query ( Query )

13import Rel8.Query.Filter ( where_ )

18import Rel8.Query.Filter ( where_ )

14

19

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

21catNull a = do

26catNull a = do

22 where_ $ isNonNull a

27 where_ $ isNonNull a

23 pure $ unsafeUnnullify a

28 pure $ unsafeUnnullify a

29+

30+

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

32+-- @nullTable@s.

33+--

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

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

36+catNullTable a = do

37+ where_ $ isNonNullTable a

38+ pure $ unsafeUnnullifyTable a

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

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

41

42unsafePeekQuery :: Query a -> a

43unsafePeekQuery (Query q) = case q mempty of

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

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

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

46

47

48mapping :: ()

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

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

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

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

52 let

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

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

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

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

55 in

56− qa' ((), tag)

56+ Opaleye.runStateQueryArr q' () tag

57

58

59zipping :: Semigroup m

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

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

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

62+zipping f q q' =

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

63+ Opaleye.stateQueryArr $ \_ tag ->

64 let

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

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

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

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

67 m'' = m <> m'

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

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

69 in

70− qa'' ((), tag)

70+ Opaleye.runStateQueryArr q'' () tag

src/Rel8/Query/Rebind.hsnew file+27

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

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

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

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

28union = zipOpaleyeWith (Opaleye.unionExplicit binaryspec)

29

30

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

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

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

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

34unionAll = zipOpaleyeWith (Opaleye.unionAllExplicit binaryspec)

35

36

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

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

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

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

40intersect = zipOpaleyeWith (Opaleye.intersectExplicit binaryspec)

41

42

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

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

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

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

46intersectAll = zipOpaleyeWith (Opaleye.intersectAllExplicit binaryspec)

47

48

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

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

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

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

52except = zipOpaleyeWith (Opaleye.exceptExplicit binaryspec)

53

54

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

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

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

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

58exceptAll = zipOpaleyeWith (Opaleye.exceptAllExplicit binaryspec)

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

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

48alignBy :: ()

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

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

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

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

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

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

53 where

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

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

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

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

56 MaybeTable hasHere a = ma

57 MaybeTable hasThere b = mb

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

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

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

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

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

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

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

64 where

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

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

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

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

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

68 ma' = MaybeTable hasHere' a

69 mb' = MaybeTable hasThere' b

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

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

71+ join' = Opaleye.aProduct join

72

73

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

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

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

1+module Rel8.Query.Window

2+ ( window

3+ )

4+where

5+

6+-- base

7+import Prelude ()

8+

9+-- opaleye

10+import qualified Opaleye.Window as Opaleye

11+

12+-- rel8

13+import Rel8.Query ( Query )

14+import Rel8.Query.Opaleye ( mapOpaleye )

15+import Rel8.Window ( Window( Window ) )

16+

17+

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

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

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

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

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

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

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

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

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

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

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

18import Data.Bool ( bool )

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

20import Data.Kind ( Constraint, Type )

21−import Data.Monoid ( getFirst )

22import Prelude hiding ( null )

21import Prelude hiding ( null )

23

22

24-- opaleye

23-- opaleye

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

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

26

25

27-- rel8

26-- rel8

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

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

29import Rel8.Expr ( Expr )

28import Rel8.Expr ( Expr )

30import Rel8.Expr.Bool ( boolExpr )

29import Rel8.Expr.Bool ( boolExpr )

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

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

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

31+import Rel8.Expr.Opaleye ( fromPrimExpr )

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

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

34import Rel8.Schema.Field ( Field )

33import Rel8.Schema.Field ( Field )

35import qualified Rel8.Schema.Kind as K

34import qualified Rel8.Schema.Kind as K

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

95 -> context (Maybe a)

94 -> context (Maybe a)

96 -> context (Maybe a)

95 -> context (Maybe a)

97guarder = \case

96guarder = \case

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

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

99− let

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

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

102− in

103− mapInputs (toPrimExpr . run . fromPrimExpr) $

104− Aggregate $

105− run <$> a

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

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

107− SField -> \_ _ _ field -> field

99+ SField -> \_ _ _ -> id

108− SName -> \_ _ _ name -> name

100+ SName -> \_ _ _ -> id

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

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

110 Identity (bool Nothing a (isNonNull tag))

102 Identity (bool Nothing a (isNonNull tag))

111

103

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

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

16module Rel8.Schema.HTable

17 ( HTable (HField, HConstrainTable)

18 , hfield, htabulate, htraverse, hdicts, hspecs

19− , hmap, htabulateA

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

20 )

21where

22

23-- base

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

24import Data.Kind ( Constraint, Type )

25import Data.Kind ( Constraint, Type )

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

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

26import Data.Proxy ( Proxy )

27import Data.Proxy ( Proxy )

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

32 )

33 )

33import Prelude

34import Prelude

34

35

36+-- profunctors

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

38+

39+-- product-profunctors

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

41+

35-- rel8

42-- rel8

36import Rel8.Schema.Dict ( Dict )

43import Rel8.Schema.Dict ( Dict )

37import Rel8.Schema.Spec ( Spec )

44import Rel8.Schema.Spec ( Spec )

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

41-- semigroupoids

48-- semigroupoids

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

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

43

50

44−

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

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

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

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

47-- specified ('hspecs').

53-- specified ('hspecs').

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

114 {-# INLINABLE hspecs #-}

120 {-# INLINABLE hspecs #-}

115

121

116

122

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

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

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

126+

127+

117hmap :: HTable t

128hmap :: HTable t

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

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

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

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

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

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

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

125{-# INLINABLE htabulateA #-}

136{-# INLINABLE htabulateA #-}

126

137

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

139+

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

141+ fmap f = ApplyP . rmap f . unApplyP

142+

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

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

145+

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

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

148+htraverseP f = htraversePWithField (const f)

149+

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

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

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

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

127

154

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

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

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

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

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

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

22 , hvectorize, hunvectorize

23 , happend, hempty

24 , hproject

25+ , hcolumn

25 )

26 )

26where

27where

27

28

28-- base

29-- base

29−import Data.Kind ( Type )

30+import Data.Kind ( Constraint, Type )

30import Data.List.NonEmpty ( NonEmpty )

31import Data.List.NonEmpty ( NonEmpty )

31import GHC.Generics (Generic)

32import GHC.Generics (Generic)

32import Prelude

33import Prelude

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

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

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

37import qualified Rel8.Schema.Kind as K

38import qualified Rel8.Schema.Kind as K

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

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

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

39import Rel8.Schema.HTable.MapTable

41import Rel8.Schema.HTable.MapTable

40− ( HMapTable, HMapTableField( HMapTableField )

42+ ( HMapTable( HMapTable ), HMapTableField( HMapTableField )

41 , MapSpec, mapInfo

43 , MapSpec, mapInfo

44+ , Precompose( Precompose )

42 )

45 )

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

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

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

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

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

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

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

51

54

52

55

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

53class Vector list where

57class Vector list where

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

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

55 vectorTypeInformation :: ()

59 vectorTypeInformation :: ()

@@ -133,3 +137,7 @@ hproject :: ()

133 => (forall ctx. t ctx -> t' ctx)

137 => (forall ctx. t ctx -> t' ctx)

134 -> HVectorize list t context -> HVectorize list t' context

138 -> HVectorize list t context -> HVectorize list t' context

135hproject f (HVectorize a) = HVectorize (HMapTable.hproject f a)

139hproject 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,6 +2,7 @@

2{-# language DerivingStrategies #-}

3{-# language DisambiguateRecordFields #-}

4{-# language NamedFieldPuns #-}

5+{-# language StandaloneKindSignatures #-}

5

6

6module Rel8.Schema.Table

7module Rel8.Schema.Table

7 ( TableSchema(..)

8 ( TableSchema(..)

@@ -10,6 +11,7 @@ module Rel8.Schema.Table

10where

11where

11

12

12-- base

13-- base

14+import Data.Kind ( Type )

13import Prelude

15import Prelude

14

16

15-- opaleye

17-- opaleye

@@ -26,6 +28,7 @@ import Text.PrettyPrint ( Doc )

26--

28--

27-- For each selectable table in your database, you should provide a

29-- For each selectable table in your database, you should provide a

28-- @TableSchema@ in order to interact with the table via Rel8.

30-- @TableSchema@ in order to interact with the table via Rel8.

31+type TableSchema :: Type -> Type

29data TableSchema names = TableSchema

32data TableSchema names = TableSchema

30 { name :: String

33 { name :: String

31 -- ^ The name of the table.

34 -- ^ The name of the table.

src/Rel8/Statement/Insert.hs+2−2

@@ -35,7 +35,7 @@ import Rel8.Schema.Name ( Name, Selects, ppColumn )

35import Rel8.Schema.Table ( TableSchema(..), ppTable )

36import Rel8.Statement.OnConflict ( OnConflict, ppOnConflict )

37import Rel8.Statement.Returning ( Returning, decodeReturning, ppReturning )

38−import Rel8.Statement.Select ( ppSelect )

38+import Rel8.Statement.Select ( ppRows )

39import Rel8.Table ( Table )

40import Rel8.Table.Name ( showNames )

41

@@ -66,7 +66,7 @@ ppInsert :: Insert a -> Doc

66ppInsert Insert {..} =

67 text "INSERT INTO" <+>

68 ppInto into $$

69− ppSelect rows $$

69+ ppRows rows $$

70 ppOnConflict into onConflict $$

71 ppReturning into returning

72

src/Rel8/Statement/Select.hs+34−4

@@ -3,6 +3,7 @@

3{-# language FlexibleContexts #-}

4{-# language MonoLocalBinds #-}

5{-# language ScopedTypeVariables #-}

6+{-# language StandaloneKindSignatures #-}

6{-# language TypeApplications #-}

7{-# language TypeApplications #-}

7

8

8module Rel8.Statement.Select

9module Rel8.Statement.Select

@@ -11,10 +12,13 @@ module Rel8.Statement.Select

11

12

12 , Optimized(..)

13 , Optimized(..)

13 , ppPrimSelect

14 , ppPrimSelect

15+ , ppRows

14 )

16 )

15where

17where

16

18

17-- base

19-- base

20+import Data.Foldable ( toList )

21+import Data.Kind ( Type )

18import Data.Void ( Void )

22import Data.Void ( Void )

19import Prelude hiding ( undefined )

23import Prelude hiding ( undefined )

20

24

@@ -24,12 +28,15 @@ import qualified Hasql.Encoders as Hasql

24import qualified Hasql.Statement as Hasql

28import qualified Hasql.Statement as Hasql

25

29

26-- opaleye

30-- opaleye

31+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye

27import qualified Opaleye.Internal.HaskellDB.Sql as Opaleye

32import qualified Opaleye.Internal.HaskellDB.Sql as Opaleye

33+import qualified Opaleye.Internal.HaskellDB.Sql.Print as Opaleye

28import qualified Opaleye.Internal.PrimQuery as Opaleye

34import qualified Opaleye.Internal.PrimQuery as Opaleye

29import qualified Opaleye.Internal.Print as Opaleye

35import qualified Opaleye.Internal.Print as Opaleye

30import qualified Opaleye.Internal.Optimize as Opaleye

36import qualified Opaleye.Internal.Optimize as Opaleye

31import qualified Opaleye.Internal.QueryArr as Opaleye hiding ( Select )

37import qualified Opaleye.Internal.QueryArr as Opaleye hiding ( Select )

32−import qualified Opaleye.Internal.Sql as Opaleye

38+import qualified Opaleye.Internal.Sql as Opaleye hiding ( Values )

39+import qualified Opaleye.Internal.Tag as Opaleye

33

40

34-- pretty

41-- pretty

35import Text.PrettyPrint ( Doc )

42import Text.PrettyPrint ( Doc )

@@ -45,6 +52,7 @@ import Rel8.Table ( Table )

45import Rel8.Table.Cols ( toCols )

52import Rel8.Table.Cols ( toCols )

46import Rel8.Table.Name ( namesFromLabels )

53import Rel8.Table.Name ( namesFromLabels )

47import Rel8.Table.Opaleye ( castTable, exprsWithNames )

54import Rel8.Table.Opaleye ( castTable, exprsWithNames )

55+import qualified Rel8.Table.Opaleye as T

48import Rel8.Table.Serialize ( Serializable, parse )

56import Rel8.Table.Serialize ( Serializable, parse )

49import Rel8.Table.Undefined ( undefined )

57import Rel8.Table.Undefined ( undefined )

50

58

@@ -80,16 +88,38 @@ ppSelect query =

80 never = pure (toPrimExpr false)

88 never = pure (toPrimExpr false)

81

89

82

90

91+ppRows :: Table Expr a => Query a -> Doc

92+ppRows query = case optimize primQuery of

93+ -- Special case VALUES because we can't use DEFAULT inside a SELECT

94+ Optimized (Opaleye.Values symbols rows)

95+ | eqSymbols symbols (toList (T.exprs a)) ->

96+ Opaleye.ppValues_ (map Opaleye.sqlExpr <$> toList rows)

97+ _ -> ppSelect query

98+ where

99+ (a, primQuery, _) = Opaleye.runSimpleQueryArrStart (toOpaleye query) ()

100+

101+ eqSymbols (symbol : symbols) (Opaleye.AttrExpr symbol' : exprs)

102+ | eqSymbol symbol symbol' = eqSymbols symbols exprs

103+ | otherwise = False

104+ eqSymbols [] [] = True

105+ eqSymbols _ _ = False

106+

107+ eqSymbol

108+ (Opaleye.Symbol name (Opaleye.UnsafeTag tag))

109+ (Opaleye.Symbol name' (Opaleye.UnsafeTag tag'))

110+ = name == name' && tag == tag'

111+

112+

83ppPrimSelect :: Query a -> (Optimized Doc, a)

113ppPrimSelect :: Query a -> (Optimized Doc, a)

84ppPrimSelect query =

114ppPrimSelect query =

85 (Opaleye.ppSql . primSelect <$> optimize primQuery, a)

115 (Opaleye.ppSql . primSelect <$> optimize primQuery, a)

86 where

116 where

87− (a, primQuery, _) =

88− Opaleye.runSimpleQueryArrStart (toOpaleye query) ()

117+ (a, primQuery, _) = Opaleye.runSimpleQueryArrStart (toOpaleye query) ()

89

118

90

119

120+type Optimized :: Type -> Type

91data Optimized a = Empty | Unit | Optimized a

121data Optimized a = Empty | Unit | Optimized a

92− deriving stock (Functor, Foldable, Traversable)

122+ deriving stock (Functor, Foldable, Traversable, Show)

93

123

94

124

95optimize :: Opaleye.PrimQuery' a -> Optimized (Opaleye.PrimQuery' Void)

125optimize :: Opaleye.PrimQuery' a -> Optimized (Opaleye.PrimQuery' Void)

src/Rel8/Statement/View.hs+31−12

@@ -3,18 +3,16 @@

3

4module Rel8.Statement.View

5 ( createView

6+ , createOrReplaceView

6 )

7 )

7where

8where

8

9

9-- base

10-- base

10−import Control.Exception ( throwIO )

11import Prelude

12

13-- hasql

14−import Hasql.Connection ( Connection )

15import qualified Hasql.Decoders as Hasql

14import qualified Hasql.Decoders as Hasql

16import qualified Hasql.Encoders as Hasql

15import qualified Hasql.Encoders as Hasql

17−import qualified Hasql.Session as Hasql

18import qualified Hasql.Statement as Hasql

16import qualified Hasql.Statement as Hasql

19

17

20-- rel8

18-- rel8

@@ -32,28 +30,49 @@ import qualified Data.Text as Text

32import Data.Text.Encoding ( encodeUtf8 )

30import Data.Text.Encoding ( encodeUtf8 )

33

31

34

32

33+data CreateView = Create | CreateOrReplace

34+

35+

35-- | Given a 'TableSchema' and 'Query', @createView@ runs a @CREATE VIEW@

36-- | Given a 'TableSchema' and 'Query', @createView@ runs a @CREATE VIEW@

36-- statement that will save the given query as a view. This can be useful if

37-- statement that will save the given query as a view. This can be useful if

37-- you want to share Rel8 queries with other applications.

38-- you want to share Rel8 queries with other applications.

38createView :: Selects names exprs

39createView :: Selects names exprs

39− => Connection -> TableSchema names -> Query exprs -> IO ()

40+ => TableSchema names -> Query exprs -> Hasql.Statement () ()

40−createView connection schema query =

41+createView =

41− Hasql.run session connection >>= either throwIO pure

42+ createViewGeneric Create

43+

44+

45+-- | Given a 'TableSchema' and 'Query', @createOrReplaceView@ runs a

46+-- @CREATE OR REPLACE VIEW@ statement that will save the given query

47+-- as a view, replacing the current view definition if it exists and

48+-- adheres to the restrictions in place for replacing a view in

49+-- PostgreSQL.

50+createOrReplaceView :: Selects names exprs

51+ => TableSchema names -> Query exprs -> Hasql.Statement () ()

52+createOrReplaceView =

53+ createViewGeneric CreateOrReplace

54+

55+

56+createViewGeneric :: Selects names exprs

57+ => CreateView -> TableSchema names -> Query exprs -> Hasql.Statement () ()

58+createViewGeneric replace schema query =

59+ Hasql.Statement bytes params decode prepare

42 where

60 where

43− session = Hasql.statement () statement

44− statement = Hasql.Statement bytes params decode prepare

45 bytes = encodeUtf8 (Text.pack sql)

61 bytes = encodeUtf8 (Text.pack sql)

46 params = Hasql.noParams

62 params = Hasql.noParams

47 decode = Hasql.noResult

63 decode = Hasql.noResult

48 prepare = False

64 prepare = False

49 sql = show doc

65 sql = show doc

50− doc = ppCreateView schema query

66+ doc = ppCreateView schema query replace

51

67

52

68

53ppCreateView :: Selects names exprs

69ppCreateView :: Selects names exprs

54− => TableSchema names -> Query exprs -> Doc

70+ => TableSchema names -> Query exprs -> CreateView -> Doc

55−ppCreateView schema query =

71+ppCreateView schema query replace =

56− text "CREATE VIEW" <+>

72+ createOrReplace replace <+>

57 ppInto schema $$

73 ppInto schema $$

58 text "AS" <+>

74 text "AS" <+>

59 ppSelect query

75 ppSelect query

76+ where

77+ createOrReplace Create = text "CREATE VIEW"

78+ createOrReplace CreateOrReplace = text "CREATE OR REPLACE VIEW"

src/Rel8/Table/Aggregate.hs+12

@@ -37,6 +37,18 @@ import Rel8.Type.Eq ( DBEq )

37

38-- | Group equal tables together. This works by aggregating each column in the

39-- given table with 'groupByExpr'.

40+--

41+-- For example, if we have a table of items, we could group the items by the

42+-- order they belong to:

43+--

44+-- @

45+-- itemsByOrder :: Query (OrderId Expr, ListTable Expr (Item Expr))

46+-- itemsByOrder = aggregate $ do

47+-- item <- each itemSchema

48+-- let orderId = groupBy (itemOrderId item)

49+-- let orderItems = listAgg item

50+-- pure (orderId, orderItems)

51+-- @

40groupBy :: forall exprs aggregates. (EqTable exprs, Aggregates aggregates exprs)

52groupBy :: forall exprs aggregates. (EqTable exprs, Aggregates aggregates exprs)

41 => exprs -> aggregates

53 => exprs -> aggregates

42groupBy = fromColumns . hgroupBy (eqTable @exprs) . toColumns

54groupBy = fromColumns . hgroupBy (eqTable @exprs) . toColumns

src/Rel8/Table/HKD.hs+1

@@ -157,6 +157,7 @@ instance

157 => HKDable a

158

159

160+type Top_ :: Constraint

160class Top_

161class Top_

161instance Top_

162instance Top_

162

163

src/Rel8/Table/List.hs+14−3

@@ -11,7 +11,9 @@

11

12module Rel8.Table.List

13 ( ListTable(..)

14+ , ($*)

15+ , listTable

14− , listTable, nameListTable

16+ , nameListTable

15 )

17 )

16where

18where

17

19

@@ -28,7 +30,7 @@ import Rel8.Schema.HTable.List ( HListTable )

28import Rel8.Schema.HTable.Vectorize

30import Rel8.Schema.HTable.Vectorize

29 ( hvectorize, hunvectorize

31 ( hvectorize, hunvectorize

30 , happend, hempty

32 , happend, hempty

31− , hproject

33+ , hproject, hcolumn

32 )

34 )

33import qualified Rel8.Schema.Kind as K

35import qualified Rel8.Schema.Kind as K

34import Rel8.Schema.Name ( Name( Name ) )

36import Rel8.Schema.Name ( Name( Name ) )

@@ -46,7 +48,9 @@ import Rel8.Table.Alternative

46 )

48 )

47import Rel8.Table.Eq ( EqTable, eqTable )

49import Rel8.Table.Eq ( EqTable, eqTable )

48import Rel8.Table.Ord ( OrdTable, ordTable )

50import Rel8.Table.Ord ( OrdTable, ordTable )

49−import Rel8.Table.Projection ( Projectable, project, apply )

51+import Rel8.Table.Projection

52+ ( Projectable, Projecting, Projection, project, apply

53+ )

50import Rel8.Table.Serialize ( ToExprs )

54import Rel8.Table.Serialize ( ToExprs )

51

55

52

56

@@ -116,6 +120,13 @@ instance (context ~ Expr, Table Expr a) =>

116 mempty = ListTable $ hempty $ \Spec {info} -> sempty info

120 mempty = ListTable $ hempty $ \Spec {info} -> sempty info

117

121

118

122

123+-- | Project a single expression out of a 'ListTable'.

124+($*) :: Projecting a (Expr b)

125+ => Projection a (Expr b) -> ListTable Expr a -> Expr [b]

126+f $* ListTable a = hcolumn $ hproject (apply f) a

127+infixl 4 $*

128+

129+

119-- | Construct a @ListTable@ from a list of expressions.

130-- | Construct a @ListTable@ from a list of expressions.

120listTable :: Table Expr a => [a] -> ListTable Expr a

131listTable :: Table Expr a => [a] -> ListTable Expr a

121listTable =

132listTable =

src/Rel8/Table/Maybe.hs+6

@@ -15,6 +15,7 @@ module Rel8.Table.Maybe

15 ( MaybeTable(..)

16 , maybeTable, nothingTable, justTable

17 , isNothingTable, isJustTable

18+ , fromMaybeTable

18 , ($?)

19 , ($?)

19 , aggregateMaybeTable

20 , aggregateMaybeTable

20 , nameMaybeTable

21 , nameMaybeTable

@@ -206,6 +207,11 @@ justTable :: a -> MaybeTable Expr a

206justTable = MaybeTable mempty . pure

207justTable = MaybeTable mempty . pure

207

208

209

210+-- | 'Data.Maybe.fromMaybe' for 'MaybeTable's.

211+fromMaybeTable :: Table Expr a => a -> MaybeTable Expr a -> a

212+fromMaybeTable fallback = maybeTable fallback id

213+

214+

209-- | Project a single expression out of a 'MaybeTable'. You can think of this

215-- | Project a single expression out of a 'MaybeTable'. You can think of this

210-- operator like the '$' operator, but it also has the ability to return

216-- operator like the '$' operator, but it also has the ability to return

211-- @null@.

217-- @null@.

src/Rel8/Table/NonEmpty.hs+14−3

@@ -11,7 +11,9 @@

11

12module Rel8.Table.NonEmpty

13 ( NonEmptyTable(..)

14+ , ($+)

15+ , nonEmptyTable

14− , nonEmptyTable, nameNonEmptyTable

16+ , nameNonEmptyTable

15 )

17 )

16where

18where

17

19

@@ -29,7 +31,7 @@ import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable )

29import Rel8.Schema.HTable.Vectorize

31import Rel8.Schema.HTable.Vectorize

30 ( hvectorize, hunvectorize

32 ( hvectorize, hunvectorize

31 , happend

33 , happend

32− , hproject

34+ , hproject, hcolumn

33 )

35 )

34import qualified Rel8.Schema.Kind as K

36import qualified Rel8.Schema.Kind as K

35import Rel8.Schema.Name ( Name( Name ) )

37import Rel8.Schema.Name ( Name( Name ) )

@@ -44,7 +46,9 @@ import Rel8.Table

44import Rel8.Table.Alternative ( AltTable, (<|>:) )

46import Rel8.Table.Alternative ( AltTable, (<|>:) )

45import Rel8.Table.Eq ( EqTable, eqTable )

47import Rel8.Table.Eq ( EqTable, eqTable )

46import Rel8.Table.Ord ( OrdTable, ordTable )

48import Rel8.Table.Ord ( OrdTable, ordTable )

47−import Rel8.Table.Projection ( Projectable, project, apply )

49+import Rel8.Table.Projection

50+ ( Projectable, Projecting, Projection, project, apply

51+ )

48import Rel8.Table.Serialize ( ToExprs )

52import Rel8.Table.Serialize ( ToExprs )

49

53

50

54

@@ -110,6 +114,13 @@ instance (Table Expr a, context ~ Expr) => Semigroup (NonEmptyTable context a)

110 happend (const sappend1) as bs

114 happend (const sappend1) as bs

111

115

112

116

117+-- | Project a single expression out of a 'NonEmptyTable'.

118+($+) :: Projecting a (Expr b)

119+ => Projection a (Expr b) -> NonEmptyTable Expr a -> Expr (NonEmpty b)

120+f $+ NonEmptyTable a = hcolumn $ hproject (apply f) a

121+infixl 4 $+

122+

123+

113-- | Construct a @NonEmptyTable@ from a non-empty list of expressions.

124-- | Construct a @NonEmptyTable@ from a non-empty list of expressions.

114nonEmptyTable :: Table Expr a => NonEmpty a -> NonEmptyTable Expr a

125nonEmptyTable :: Table Expr a => NonEmpty a -> NonEmptyTable Expr a

115nonEmptyTable =

126nonEmptyTable =

src/Rel8/Table/Null.hsnew file+147

@@ -0,0 +1,147 @@

1+{-# language DataKinds #-}

2+{-# language FlexibleContexts #-}

3+{-# language FlexibleInstances #-}

4+{-# language MultiParamTypeClasses #-}

5+{-# language ScopedTypeVariables #-}

6+{-# language StandaloneKindSignatures #-}

7+{-# language TypeApplications #-}

8+{-# language TypeFamilies #-}

9+{-# language UndecidableInstances #-}

10+

11+module Rel8.Table.Null

12+ ( NullTable(..)

13+ , nullableTable, nullTable, nullifyTable, unsafeUnnullifyTable

14+ , isNullTable, isNonNullTable

15+ , nameNullTable

16+ , toMaybeTable, toNullTable

17+ )

18+where

19+

20+-- base

21+import Data.Kind ( Type )

22+import Prelude hiding ( null, undefined )

23+

24+-- comonad

25+import Control.Comonad ( extract )

26+

27+-- rel8

28+import Rel8.Expr ( Expr )

29+import Rel8.Expr.Bool ( not_ )

30+import Rel8.Kind.Context ( Reifiable )

31+import qualified Rel8.Schema.Kind as K

32+import Rel8.Schema.Name ( Name )

33+import Rel8.Table

34+ ( Table, Columns, Context, fromColumns, toColumns

35+ , FromExprs, fromResult, toResult

36+ , Transpose

37+ )

38+import Rel8.Table.Alternative

39+ ( AltTable, (<|>:)

40+ , AlternativeTable, emptyTable

41+ )

42+import Rel8.Table.Bool ( bool )

43+import Rel8.Table.Eq ( EqTable, eqTable )

44+import Rel8.Table.Maybe ( MaybeTable, justTable, maybeTable, nothingTable )

45+import Rel8.Table.Nullify ( Nullify, isNull )

46+import Rel8.Table.Ord ( OrdTable, ordTable )

47+import Rel8.Table.Projection ( Projectable, project )

48+import Rel8.Table.Serialize ( ToExprs )

49+import Rel8.Table.Undefined ( undefined )

50+

51+

52+-- | @NullTable t@ is the table @t@, but where all the columns in @t@ have the

53+-- possibility of being 'Rel8.null'. This is very similar to

54+-- 'Rel8.MaybeTable', except that it does not use an extra tag field, so it

55+-- cannot distinguish between @Nothing@ and @Just Nothing@ if nested. In other

56+-- words, if all of the columns of the @t@ passed to @NullTable@ are already

57+-- nullable, then @NullTable@ has no effect.

58+type NullTable :: K.Context -> Type -> Type

59+newtype NullTable context a = NullTable (Nullify context a)

60+

61+

62+instance Projectable (NullTable context) where

63+ project f (NullTable a) = NullTable (project f a)

64+

65+

66+instance context ~ Expr => AltTable (NullTable context) where

67+ ma <|>: mb = bool ma mb (isNullTable ma)

68+

69+

70+instance context ~ Expr => AlternativeTable (NullTable context) where

71+ emptyTable = nullTable

72+

73+

74+instance (Table context a, Reifiable context, context ~ context') =>

75+ Table context' (NullTable context a)

76+ where

77+ type Columns (NullTable context a) = Columns (Nullify context a)

78+ type Context (NullTable context a) = Context (Nullify context a)

79+ type FromExprs (NullTable context a) = FromExprs (Nullify context a)

80+ type Transpose to (NullTable context a) = NullTable to (Transpose to a)

81+

82+ toColumns (NullTable a) = toColumns a

83+ fromColumns = NullTable . fromColumns

84+

85+ toResult = toResult @_ @(Nullify context a)

86+ fromResult = fromResult @_ @(Nullify context a)

87+

88+

89+instance (EqTable a, context ~ Expr) => EqTable (NullTable context a) where

90+ eqTable = eqTable @(Nullify context a)

91+

92+

93+instance (OrdTable a, context ~ Expr) => OrdTable (NullTable context a) where

94+ ordTable = ordTable @(Nullify context a)

95+

96+

97+instance (ToExprs exprs a, context ~ Expr) =>

98+ ToExprs (NullTable context exprs) (Maybe a)

99+

100+

101+-- | Check if any of the non-nullable fields of @a@ are 'Rel8.null' under the

102+-- 'NullTable'. Returns 'Rel8.false' if @a@ has no non-nullable fields.

103+isNullTable :: Table Expr a => NullTable Expr a -> Expr Bool

104+isNullTable (NullTable a) = isNull a

105+

106+

107+-- | The inverse of 'isNullTable'.

108+isNonNullTable :: Table Expr a => NullTable Expr a -> Expr Bool

109+isNonNullTable = not_ . isNullTable

110+

111+

112+-- | Like 'Rel8.nullable'.

113+nullableTable :: (Table Expr a, Table Expr b)

114+ => b -> (a -> b) -> NullTable Expr a -> b

115+nullableTable b f ma@(NullTable a) = bool (f (extract a)) b (isNullTable ma)

116+

117+

118+-- | The null table. Like 'Rel8.null'.

119+nullTable :: Table Expr a => NullTable Expr a

120+nullTable = NullTable (pure undefined)

121+

122+

123+-- | Lift any table into 'NullTable'. Like 'Rel8.nullify'.

124+nullifyTable :: a -> NullTable Expr a

125+nullifyTable = NullTable . pure

126+

127+

128+unsafeUnnullifyTable :: NullTable Expr a -> a

129+unsafeUnnullifyTable (NullTable a) = extract a

130+

131+

132+-- | Construct a 'NullTable' in the 'Name' context. This can be useful if you

133+-- have a 'NullTable' that you are storing in a table and need to construct a

134+-- 'TableSchema'.

135+nameNullTable :: a -> NullTable Name a

136+nameNullTable = NullTable . pure

137+

138+

139+-- | Convert a 'NullTable' to a 'MaybeTable'.

140+toMaybeTable :: Table Expr a => NullTable Expr a -> MaybeTable Expr a

141+toMaybeTable = nullableTable nothingTable justTable

142+

143+

144+-- | Convert a 'MaybeTable' to a 'NullTable'. Note that if the underlying @a@

145+-- has no non-nullable fields, this is a lossy conversion.

146+toNullTable :: Table Expr a => MaybeTable Expr a -> NullTable Expr a

147+toNullTable = maybeTable nullTable nullifyTable

src/Rel8/Table/Nullify.hs+27

@@ -1,7 +1,9 @@

1{-# language DataKinds #-}

2+{-# language FlexibleContexts #-}

2{-# language FlexibleInstances #-}

3{-# language FlexibleInstances #-}

3{-# language LambdaCase #-}

4{-# language LambdaCase #-}

4{-# language MultiParamTypeClasses #-}

5{-# language MultiParamTypeClasses #-}

6+{-# language NamedFieldPuns #-}

5{-# language ScopedTypeVariables #-}

7{-# language ScopedTypeVariables #-}

6{-# language StandaloneKindSignatures #-}

8{-# language StandaloneKindSignatures #-}

7{-# language TypeApplications #-}

9{-# language TypeApplications #-}

@@ -12,11 +14,13 @@ module Rel8.Table.Nullify

12 ( Nullify

14 ( Nullify

13 , aggregateNullify

15 , aggregateNullify

14 , guard

16 , guard

17+ , isNull

15 )

18 )

16where

19where

17

20

18-- base

21-- base

19import Control.Applicative ( liftA2 )

22import Control.Applicative ( liftA2 )

23+import Data.Functor.Const ( Const( Const ), getConst )

20import Data.Functor.Identity ( runIdentity )

24import Data.Functor.Identity ( runIdentity )

21import Data.Kind ( Type )

25import Data.Kind ( Type )

22import Prelude

26import Prelude

@@ -27,6 +31,8 @@ import Control.Comonad ( Comonad, duplicate, extract, ComonadApply, (<@>) )

27-- rel8

31-- rel8

28import Rel8.Aggregate ( Aggregate )

32import Rel8.Aggregate ( Aggregate )

29import Rel8.Expr ( Expr )

33import Rel8.Expr ( Expr )

34+import Rel8.Expr.Bool ( (||.), false )

35+import qualified Rel8.Expr.Null as Expr

30import Rel8.Kind.Context ( Reifiable, contextSing )

36import Rel8.Kind.Context ( Reifiable, contextSing )

31import Rel8.Schema.Context.Nullify

37import Rel8.Schema.Context.Nullify

32 ( Nullifiability( NAggregate, NExpr )

38 ( Nullifiability( NAggregate, NExpr )

@@ -45,12 +51,14 @@ import Rel8.Schema.HTable.Nullify

45 , hproject

51 , hproject

46 )

52 )

47import qualified Rel8.Schema.Kind as K

53import qualified Rel8.Schema.Kind as K

54+import Rel8.Schema.Null ( Nullity( NotNull, Null ) )

48import qualified Rel8.Schema.Result as R

55import qualified Rel8.Schema.Result as R

49import Rel8.Table

56import Rel8.Table

50 ( Table, Columns, Context, toColumns, fromColumns

57 ( Table, Columns, Context, toColumns, fromColumns

51 , FromExprs, fromResult, toResult

58 , FromExprs, fromResult, toResult

52 , Transpose

59 , Transpose

53 )

60 )

61+import Rel8.Schema.Spec ( Spec( Spec, nullity ) )

54import Rel8.Table.Eq ( EqTable, eqTable )

62import Rel8.Table.Eq ( EqTable, eqTable )

55import Rel8.Table.Ord ( OrdTable, ordTable )

63import Rel8.Table.Ord ( OrdTable, ordTable )

56import Rel8.Table.Projection ( Projectable, apply, project )

64import Rel8.Table.Projection ( Projectable, apply, project )

@@ -182,3 +190,22 @@ guard :: (Reifiable context, HTable t)

182 -> HNullify t context

190 -> HNullify t context

183guard tag isNonNull isNonNullExpr =

191guard tag isNonNull isNonNullExpr =

184 hguard (guarder contextSing tag isNonNull isNonNullExpr)

192 hguard (guarder contextSing tag isNonNull isNonNullExpr)

193+

194+

195+isNull :: forall a. Table Expr a => Nullify Expr a -> Expr Bool

196+isNull =

197+ maybe false getAny .

198+ getConst .

199+ hunnullify (\Spec {nullity} a -> Const $ case nullity of

200+ NotNull -> Just $ Any $ Expr.isNull a

201+ Null -> Nothing) .

202+ toColumns

203+

204+

205+newtype Any = Any

206+ { getAny :: Expr Bool

207+ }

208+

209+

210+instance Semigroup Any where

211+ Any a <> Any b = Any (a ||. b)

src/Rel8/Table/Opaleye.hs+31−47

@@ -7,6 +7,8 @@

7{-# language TypeFamilies #-}

8{-# language ViewPatterns #-}

9

10+{-# options_ghc -Wno-deprecations #-}

11+

10module Rel8.Table.Opaleye

12module Rel8.Table.Opaleye

11 ( aggregator

13 ( aggregator

12 , attributes

14 , attributes

@@ -26,17 +28,15 @@ where

26-- base

28-- base

27import Data.Functor.Const ( Const( Const ), getConst )

29import Data.Functor.Const ( Const( Const ), getConst )

28import Data.List.NonEmpty ( NonEmpty )

30import Data.List.NonEmpty ( NonEmpty )

29−import Prelude hiding ( undefined )

31+import Prelude

30

32

31-- opaleye

33-- opaleye

34+import qualified Opaleye.Adaptors as Opaleye

35+import qualified Opaleye.Field as Opaleye ( Field_ )

32import qualified Opaleye.Internal.Aggregate as Opaleye

36import qualified Opaleye.Internal.Aggregate as Opaleye

33−import qualified Opaleye.Internal.Binary as Opaleye

34−import qualified Opaleye.Internal.Distinct as Opaleye

35import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye

37import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye

36−import qualified Opaleye.Internal.PackMap as Opaleye

37−import qualified Opaleye.Internal.Unpackspec as Opaleye

38import qualified Opaleye.Internal.Values as Opaleye

39−import qualified Opaleye.Internal.Table as Opaleye

39+import qualified Opaleye.Table as Opaleye

40

41-- profunctors

42import Data.Profunctor ( dimap, lmap )

@@ -46,27 +46,25 @@ import Rel8.Aggregate ( Aggregate( Aggregate ), Aggregates )

46import Rel8.Expr ( Expr )

47import Rel8.Expr.Opaleye

48 ( fromPrimExpr, toPrimExpr

49− , traversePrimExpr

50− , fromColumn, toColumn

51− , scastExpr

49+ , scastExpr, traverseFieldP

52 )

50 )

53−import Rel8.Schema.HTable ( htabulateA, hfield, htraverse, hspecs, htabulate )

51+import Rel8.Schema.HTable ( htabulateA, hfield, hspecs, htabulate,

52+ htraverseP, htraversePWithField )

54import Rel8.Schema.Name ( Name( Name ), Selects, ppColumn )

53import Rel8.Schema.Name ( Name( Name ), Selects, ppColumn )

55import Rel8.Schema.Spec ( Spec(..) )

54import Rel8.Schema.Spec ( Spec(..) )

56import Rel8.Schema.Table ( TableSchema(..), ppTable )

55import Rel8.Schema.Table ( TableSchema(..), ppTable )

57import Rel8.Table ( Table, fromColumns, toColumns )

56import Rel8.Table ( Table, fromColumns, toColumns )

58−import Rel8.Table.Undefined ( undefined )

57+import Rel8.Type.Information ( typeName )

59

58

60-- semigroupoids

59-- semigroupoids

61import Data.Functor.Apply ( WrappedApplicative(..) )

60import Data.Functor.Apply ( WrappedApplicative(..) )

61+import Data.Profunctor.Product ( ProductProfunctor )

62

63

64aggregator :: Aggregates aggregates exprs => Opaleye.Aggregator aggregates exprs

65−aggregator = Opaleye.Aggregator $ Opaleye.PackMap $ \f aggregates ->

65+aggregator = dimap toColumns fromColumns $

66− fmap fromColumns $ unwrapApplicative $ htabulateA $ \field ->

66+ htraverseP $

67− WrapApplicative $ case hfield (toColumns aggregates) field of

67+ lmap (\(Aggregate a) -> (a, ())) Opaleye.aggregatorApply

68− Aggregate (Opaleye.Aggregator (Opaleye.PackMap inner)) ->

69− inner f ()

70

68

71

69

72attributes :: Selects names exprs => TableSchema names -> exprs

70attributes :: Selects names exprs => TableSchema names -> exprs

@@ -77,22 +75,19 @@ attributes schema@TableSchema {columns} = fromColumns $ htabulate $ \field ->

77 show (ppTable schema) <> "." <> show (ppColumn column)

75 show (ppTable schema) <> "." <> show (ppColumn column)

78

76

79

77

78+fromOpaleyespec :: (ProductProfunctor p, Table Expr a)

79+ => p (Opaleye.Field_ n x) (Opaleye.Field_ n x)

80+ -> p a a

81+fromOpaleyespec x =

82+ dimap toColumns fromColumns (htraverseP (traverseFieldP x))

83+

84+

80binaryspec :: Table Expr a => Opaleye.Binaryspec a a

85binaryspec :: Table Expr a => Opaleye.Binaryspec a a

81−binaryspec = Opaleye.Binaryspec $ Opaleye.PackMap $ \f (as, bs) ->

86+binaryspec = fromOpaleyespec Opaleye.binaryspecField

82− fmap fromColumns $ unwrapApplicative $ htabulateA $ \field ->

83− WrapApplicative $

84− case (hfield (toColumns as) field, hfield (toColumns bs) field) of

85− (a, b) -> fromPrimExpr <$> f (toPrimExpr a, toPrimExpr b)

86

87

88

88distinctspec :: Table Expr a => Opaleye.Distinctspec a a

89distinctspec :: Table Expr a => Opaleye.Distinctspec a a

89−distinctspec =

90+distinctspec = fromOpaleyespec Opaleye.distinctspecField

90− Opaleye.Distinctspec $ Opaleye.Aggregator $ Opaleye.PackMap $ \f ->

91− fmap fromColumns .

92− unwrapApplicative .

93− htraverse

94− (\a -> WrapApplicative $ fromPrimExpr <$> f (Nothing, toPrimExpr a)) .

95− toColumns

96

91

97

92

98exprs :: Table Expr a => a -> NonEmpty Opaleye.PrimExpr

93exprs :: Table Expr a => a -> NonEmpty Opaleye.PrimExpr

@@ -111,8 +106,8 @@ exprsWithNames names as = getConst $ htabulateA $ \field ->

111table :: Selects names exprs => TableSchema names -> Opaleye.Table exprs exprs

106table :: Selects names exprs => TableSchema names -> Opaleye.Table exprs exprs

112table (TableSchema name schema columns) =

107table (TableSchema name schema columns) =

113 case schema of

108 case schema of

114− Nothing -> Opaleye.Table name (tableFields columns)

109+ Nothing -> Opaleye.table name (tableFields columns)

115− Just schemaName -> Opaleye.TableWithSchema schemaName name (tableFields columns)

110+ Just schemaName -> Opaleye.tableWithSchema schemaName name (tableFields columns)

116

111

117

112

118tableFields :: Selects names exprs

113tableFields :: Selects names exprs

@@ -124,21 +119,19 @@ tableFields (toColumns -> names) = dimap toColumns fromColumns $

124 where

119 where

125 go :: Name a -> Opaleye.TableFields (Expr a) (Expr a)

120 go :: Name a -> Opaleye.TableFields (Expr a) (Expr a)

126 go (Name name) =

121 go (Name name) =

127− dimap (toColumn . toPrimExpr) (fromPrimExpr . fromColumn) $

122+ traverseFieldP $

128 Opaleye.requiredTableField name

123 Opaleye.requiredTableField name

129

124

130

125

131unpackspec :: Table Expr a => Opaleye.Unpackspec a a

126unpackspec :: Table Expr a => Opaleye.Unpackspec a a

132−unpackspec = Opaleye.Unpackspec $ Opaleye.PackMap $ \f ->

127+unpackspec = fromOpaleyespec Opaleye.unpackspecField

133− fmap fromColumns .

134− unwrapApplicative .

135− htraverse (WrapApplicative . traversePrimExpr f) .

136− toColumns

137{-# INLINABLE unpackspec #-}

128{-# INLINABLE unpackspec #-}

138

129

139

130

140−valuesspec :: Table Expr a => Opaleye.ValuesspecSafe a a

131+valuesspec :: Table Expr a => Opaleye.Valuesspec a a

141−valuesspec = Opaleye.ValuesspecSafe (toPackMap undefined) unpackspec

132+valuesspec = dimap toColumns fromColumns $

133+ htraversePWithField (traverseFieldP . Opaleye.valuesspecFieldType . typeName)

134+ where typeName = Rel8.Type.Information.typeName . info . hfield hspecs

142

135

143

136

144view :: Selects names exprs => names -> exprs

137view :: Selects names exprs => names -> exprs

@@ -147,15 +140,6 @@ view columns = fromColumns $ htabulate $ \field ->

147 Name column -> fromPrimExpr $ Opaleye.BaseTableAttrExpr column

140 Name column -> fromPrimExpr $ Opaleye.BaseTableAttrExpr column

148

141

149

142

150−toPackMap :: Table Expr a

151− => a -> Opaleye.PackMap Opaleye.PrimExpr Opaleye.PrimExpr () a

152−toPackMap as = Opaleye.PackMap $ \f () ->

153− fmap fromColumns $

154− unwrapApplicative .

155− htraverse (WrapApplicative . traversePrimExpr f) $

156− toColumns as

157−

158−

159-- | Transform a table by adding 'CAST' to all columns. This is most useful for

143-- | Transform a table by adding 'CAST' to all columns. This is most useful for

160-- finalising a SELECT or RETURNING statement, guaranteed that the output

144-- finalising a SELECT or RETURNING statement, guaranteed that the output

161-- matches what is encoded in each columns TypeInformation.

145-- matches what is encoded in each columns TypeInformation.

src/Rel8/Table/Ord.hs+2−2

@@ -146,9 +146,9 @@ infix 4 >=:

146

147-- | Given two 'Table's, return the table that sorts before the other.

148least :: OrdTable a => a -> a -> a

149−least a b = bool a b (a <: b)

149+least a b = bool b a (a <: b)

150

151

152-- | Given two 'Table's, return the table that sorts after the other.

153greatest :: OrdTable a => a -> a -> a

154−greatest a b = bool a b (a >: b)

154+greatest a b = bool b a (a >: b)

src/Rel8/Table/Projection.hs+1−1

@@ -35,7 +35,7 @@ class

35 => Projecting a b

36instance

37 ( Transposes (Context a) (Field a) a (Transpose (Field a) a)

38− , Transposes (Context a) (Field a) b (Transpose (Field b) b)

38+ , Transposes (Context a) (Field a) b (Transpose (Field a) b)

39 )

40 => Projecting a b

41

src/Rel8/Table/These.hs+14−3

@@ -20,6 +20,7 @@ module Rel8.Table.These

20 , isThisTable, isThatTable, isThoseTable

21 , hasHereTable, hasThereTable

22 , justHereTable, justThereTable

23+ , alignMaybeTable

23 , aggregateTheseTable

24 , aggregateTheseTable

24 , nameTheseTable

25 , nameTheseTable

25 )

26 )

@@ -29,13 +30,13 @@ where

29import Data.Bifunctor ( Bifunctor, bimap )

30import Data.Bifunctor ( Bifunctor, bimap )

30import Data.Kind ( Type )

31import Data.Kind ( Type )

31import Data.Maybe ( isJust )

32import Data.Maybe ( isJust )

32−import Prelude hiding ( undefined )

33+import Prelude hiding ( null, undefined )

33

34

34-- rel8

35-- rel8

35import Rel8.Aggregate ( Aggregate )

36import Rel8.Aggregate ( Aggregate )

36import Rel8.Expr ( Expr )

37import Rel8.Expr ( Expr )

37−import Rel8.Expr.Bool ( (&&.), not_ )

38+import Rel8.Expr.Bool ( (&&.), (||.), boolExpr, not_ )

38−import Rel8.Expr.Null ( isNonNull )

39+import Rel8.Expr.Null ( null, isNonNull )

39import Rel8.Kind.Context ( Reifiable )

40import Rel8.Kind.Context ( Reifiable )

40import Rel8.Schema.Context.Nullify ( Nullifiable )

41import Rel8.Schema.Context.Nullify ( Nullifiable )

41import Rel8.Schema.Dict ( Dict( Dict ) )

42import Rel8.Schema.Dict ( Dict( Dict ) )

@@ -288,6 +289,16 @@ justThereTable :: TheseTable context a b -> MaybeTable context b

288justThereTable = there

289justThereTable = there

289

290

291

292+-- | Construct a @TheseTable@ from two 'MaybeTable's.

293+alignMaybeTable :: ()

294+ => MaybeTable Expr a

295+ -> MaybeTable Expr b

296+ -> MaybeTable Expr (TheseTable Expr a b)

297+alignMaybeTable a b = MaybeTable tag (pure (TheseTable a b))

298+ where

299+ tag = boolExpr null mempty (isJustTable a ||. isJustTable b)

300+

301+

291-- | Construct a @TheseTable@. Corresponds to 'This'.

302-- | Construct a @TheseTable@. Corresponds to 'This'.

292thisTable :: Table Expr b => a -> TheseTable Expr a b

303thisTable :: Table Expr b => a -> TheseTable Expr a b

293thisTable a = TheseTable (justTable a) nothingTable

304thisTable a = TheseTable (justTable a) nothingTable

src/Rel8/Table/Window.hsnew file+43

@@ -0,0 +1,43 @@

1+{-# language MonoLocalBinds #-}

2+

3+module Rel8.Table.Window

4+ ( cumulative

5+ , cumulative_

6+ , currentRow

7+ )

8+where

9+

10+-- base

11+import Prelude

12+

13+-- opaleye

14+import qualified Opaleye.Window as Opaleye

15+

16+-- rel8

17+import Rel8.Aggregate ( Aggregates )

18+import qualified Rel8.Expr.Window as Expr

19+import Rel8.Schema.HTable ( hfield, htabulateA )

20+import Rel8.Table ( fromColumns, toColumns )

21+import Rel8.Window ( Window( Window ) )

22+

23+

24+-- | 'cumulative' allows the use of aggregation functions in 'Window'

25+-- expressions. In particular, @'cumulative' 'Rel8.sum'@

26+-- (when combined with 'Rel8.Window.orderPartitionBy') gives a running total,

27+-- also known as a \"cumulative sum\", hence the name @cumulative@.

28+cumulative :: Aggregates aggregates exprs => (a -> aggregates) -> Window a exprs

29+cumulative f =

30+ fmap fromColumns $

31+ htabulateA $ \field ->

32+ Expr.cumulative ((`hfield` field) . toColumns . f)

33+

34+

35+-- | A version of 'cumulative' for use with nullary aggregators like

36+-- 'Rel8.Expr.Aggregate.countStar'.

37+cumulative_ :: Aggregates aggregates exprs => aggregates -> Window a exprs

38+cumulative_ = cumulative . const

39+

40+

41+-- | Return every column of the current row of a window query.

42+currentRow :: Window a a

43+currentRow = Window $ Opaleye.over (Opaleye.noWindowFunction id) mempty mempty

src/Rel8/Tabulate.hs+24−21

@@ -58,7 +58,7 @@ import Data.Function ( on )

58import Data.Functor.Contravariant ( Contravariant, (>$<), contramap )

59import Data.Int ( Int64 )

60import Data.Kind ( Type )

61−import Data.Maybe ( fromMaybe )

61+import Data.Maybe ( fromJust, fromMaybe )

62import Prelude hiding ( lookup, zip, zipWith )

63

64-- bifunctors

@@ -69,9 +69,7 @@ import Control.Comonad ( extract )

69

70-- opaleye

71import qualified Opaleye.Aggregate as Opaleye

72−import qualified Opaleye.Internal.Order as Opaleye

72+import qualified Opaleye.Order as Opaleye ( orderBy, distinctOnExplicit )

73−import qualified Opaleye.Internal.QueryArr as Opaleye

74−import qualified Opaleye.Order as Opaleye ( orderBy )

75

73

76-- profunctors

74-- profunctors

77import Data.Profunctor ( dimap, lmap )

75import Data.Profunctor ( dimap, lmap )

@@ -92,10 +90,10 @@ import Rel8.Order ( Order( Order ) )

92import Rel8.Query ( Query )

90import Rel8.Query ( Query )

93import qualified Rel8.Query.Exists as Q ( exists, present, absent )

91import qualified Rel8.Query.Exists as Q ( exists, present, absent )

94import Rel8.Query.Filter ( where_ )

92import Rel8.Query.Filter ( where_ )

95−import Rel8.Query.Limit ( limit )

96import Rel8.Query.List ( catNonEmptyTable )

93import Rel8.Query.List ( catNonEmptyTable )

97import qualified Rel8.Query.Maybe as Q ( optional )

94import qualified Rel8.Query.Maybe as Q ( optional )

98import Rel8.Query.Opaleye ( mapOpaleye, unsafePeekQuery )

95import Rel8.Query.Opaleye ( mapOpaleye, unsafePeekQuery )

96+import Rel8.Query.Rebind ( rebind )

99import Rel8.Query.These ( alignBy )

97import Rel8.Query.These ( alignBy )

100import Rel8.Table ( Table, fromColumns, toColumns )

98import Rel8.Table ( Table, fromColumns, toColumns )

101import Rel8.Table.Aggregate ( hgroupBy, listAgg, nonEmptyAgg )

99import Rel8.Table.Aggregate ( hgroupBy, listAgg, nonEmptyAgg )

@@ -179,7 +177,7 @@ ensure (Predicate mp) = traverse_ (\k -> traverse_ (\p -> where_ (p k)) mp)

179-- stopping a 'Tabulation' from containing multiple rows with the same key, so

177-- stopping a 'Tabulation' from containing multiple rows with the same key, so

180-- technically @Map k (NonEmpty a)@ is more accurate.

178-- technically @Map k (NonEmpty a)@ is more accurate.

181--

179--

182−-- 'Tabulation's can be created from 'Query's with 'fromQuery' and 'littQuery'

180+-- 'Tabulation's can be created from 'Query's with 'fromQuery' and 'liftQuery'

183-- and converted back to 'Query's with 'lookup' and 'toQuery' (though note the

181-- and converted back to 'Query's with 'lookup' and 'toQuery' (though note the

184-- caveats that come with the latter).

182-- caveats that come with the latter).

185type Tabulation :: Type -> Type -> Type

183type Tabulation :: Type -> Type -> Type

@@ -236,7 +234,13 @@ instance EqTable k => Monad (Tabulation k) where

236-- | If @'Tabulation' k a@ is @Map k (NonEmpty a)@, then @(<|>:)@ is

234-- | If @'Tabulation' k a@ is @Map k (NonEmpty a)@, then @(<|>:)@ is

237-- @unionWith (<>)@.

235-- @unionWith (<>)@.

238instance EqTable k => AltTable (Tabulation k) where

236instance EqTable k => AltTable (Tabulation k) where

237+ tas <|>: tbs = do

238+ eas <- peek tas

239+ ebs <- peek tbs

240+ case (eas, ebs) of

241+ (Left as, Left bs) -> liftQuery $ as <|>: bs

242+ (Right as, Right bs) -> fromQuery $ as <|>: bs

239− as <|>: bs = catNonEmptyTable `through` ((<>) `on` some) as bs

243+ _ -> catNonEmptyTable `through` ((<>) `on` some) tas tbs

240

244

241

245

242instance EqTable k => AlternativeTable (Tabulation k) where

246instance EqTable k => AlternativeTable (Tabulation k) where

@@ -345,19 +349,8 @@ aggregate (Tabulation f) = Tabulation $

345-- \"first\" value it encounters for each key, but note that \"first\" is

349-- \"first\" value it encounters for each key, but note that \"first\" is

346-- undefined unless you first call 'order'.

350-- undefined unless you first call 'order'.

347distinct :: EqTable k => Tabulation k a -> Tabulation k a

351distinct :: EqTable k => Tabulation k a -> Tabulation k a

348−distinct (Tabulation f) = Tabulation $ \p ->

352+distinct (Tabulation f) = Tabulation $

349− -- workaround for https://github.com/tomjaguarpaw/haskell-opaleye/pull/518

350− case fst (unsafePeekQuery (f p)) of

351− Nothing -> limit 1 (f p)

352− Just _ ->

353− mapOpaleye

354− (\q ->

355− Opaleye.productQueryArr

356− ( Opaleye.distinctOn (key unpackspec) fst

353+ mapOpaleye (Opaleye.distinctOnExplicit (key unpackspec) fst) . f

357− . Opaleye.runSimpleQueryArr q

358− )

359− )

360− (f p)

361

354

362

355

363-- | 'order' orders the /values/ of a 'Tabulation' within their

356-- | 'order' orders the /values/ of a 'Tabulation' within their

@@ -516,8 +509,8 @@ alignWith :: EqTable k

516 -> Tabulation k a -> Tabulation k b -> Tabulation k c

509 -> Tabulation k a -> Tabulation k b -> Tabulation k c

517alignWith f (Tabulation as) (Tabulation bs) = Tabulation $ \p -> do

510alignWith f (Tabulation as) (Tabulation bs) = Tabulation $ \p -> do

518 tkab <- liftF2 (alignBy condition) as bs p

511 tkab <- liftF2 (alignBy condition) as bs p

512+ k <- traverse (rebind "key") $ recover $ bimap fst fst tkab

519 let

513 let

520− k = recover $ bimap fst fst tkab

521 tab = bimap snd snd tkab

514 tab = bimap snd snd tkab

522 pure (k, f tab)

515 pure (k, f tab)

523 where

516 where

@@ -635,3 +628,13 @@ similarity a b = a <* present b

635-- @do@-notation.

628-- @do@-notation.

636difference :: EqTable k => Tabulation k a -> Tabulation k b -> Tabulation k a

629difference :: EqTable k => Tabulation k a -> Tabulation k b -> Tabulation k a

637difference a b = a <* absent b

630difference a b = a <* absent b

631+

632+

633+-- | 'Tabulation's can be produced with either 'fromQuery' or 'liftQuery', and

634+-- in some cases we might want to treat these differently. 'peek' uses

635+-- 'unsafePeekQuery' to determine which type of 'Tabulation' we have.

636+peek :: Tabulation k a -> Tabulation k (Either (Query a) (Query (k, a)))

637+peek (Tabulation f) = Tabulation $ \p ->

638+ pure $ (empty,) $ case unsafePeekQuery (f p) of

639+ (Nothing, _) -> Left $ fmap snd (f p)

640+ (Just _, _) -> Right $ fmap (first fromJust) (f p)

src/Rel8/Type.hs+9−8

@@ -1,3 +1,4 @@

1+{-# language FlexibleContexts #-}

1{-# language FlexibleInstances #-}

2{-# language FlexibleInstances #-}

2{-# language MonoLocalBinds #-}

3{-# language MonoLocalBinds #-}

3{-# language MultiWayIf #-}

4{-# language MultiWayIf #-}

@@ -127,10 +128,10 @@ instance DBType Int64 where

127instance DBType Float where

128instance DBType Float where

128 typeInformation = TypeInformation

129 typeInformation = TypeInformation

129 { encode = \x -> Opaleye.ConstExpr

130 { encode = \x -> Opaleye.ConstExpr

130− if | x == (1 /0) -> Opaleye.OtherLit "'Infinity'"

131+ if | x == (1 / 0) -> Opaleye.OtherLit "'Infinity'"

131− | isNaN x -> Opaleye.OtherLit "'NaN'"

132+ | isNaN x -> Opaleye.OtherLit "'NaN'"

132− | x == (-1/0) -> Opaleye.OtherLit "'-Infinity'"

133+ | x == (-1 / 0) -> Opaleye.OtherLit "'-Infinity'"

133− | otherwise -> Opaleye.NumericLit $ realToFrac x

134+ | otherwise -> Opaleye.NumericLit $ realToFrac x

134 , decode = Hasql.float4

135 , decode = Hasql.float4

135 , typeName = "float4"

136 , typeName = "float4"

136 }

137 }

@@ -140,10 +141,10 @@ instance DBType Float where

140instance DBType Double where

141instance DBType Double where

141 typeInformation = TypeInformation

142 typeInformation = TypeInformation

142 { encode = \x -> Opaleye.ConstExpr

143 { encode = \x -> Opaleye.ConstExpr

143− if | x == (1 /0) -> Opaleye.OtherLit "'Infinity'"

144+ if | x == (1 / 0) -> Opaleye.OtherLit "'Infinity'"

144− | isNaN x -> Opaleye.OtherLit "'NaN'"

145+ | isNaN x -> Opaleye.OtherLit "'NaN'"

145− | x == (-1/0) -> Opaleye.OtherLit "'-Infinity'"

146+ | x == (-1 / 0) -> Opaleye.OtherLit "'-Infinity'"

146− | otherwise -> Opaleye.NumericLit $ realToFrac x

147+ | otherwise -> Opaleye.NumericLit $ realToFrac x

147 , decode = Hasql.float8

148 , decode = Hasql.float8

148 , typeName = "float8"

149 , typeName = "float8"

149 }

150 }

src/Rel8/Type/Enum.hs+1

@@ -106,6 +106,7 @@ class (DBType a, Enumable a) => DBEnum a where

106

107-- | Types that are sum types, where each constructor is unary (that is, has no

108-- fields).

109+type Enumable :: Type -> Constraint

109class (Generic a, GEnumable (Rep a)) => Enumable a

110class (Generic a, GEnumable (Rep a)) => Enumable a

110instance (Generic a, GEnumable (Rep a)) => Enumable a

111instance (Generic a, GEnumable (Rep a)) => Enumable a

111

112

src/Rel8/Type/JSONBEncoded.hs+4

@@ -1,3 +1,5 @@

1+{-# language StandaloneKindSignatures #-}

2+

1module Rel8.Type.JSONBEncoded ( JSONBEncoded(..) ) where

3module Rel8.Type.JSONBEncoded ( JSONBEncoded(..) ) where

2

4

3-- aeson

5-- aeson

@@ -6,6 +8,7 @@ import Data.Aeson.Types ( parseEither )

6

8

7-- base

9-- base

8import Data.Bifunctor ( first )

10import Data.Bifunctor ( first )

11+import Data.Kind ( Type )

9import Prelude

12import Prelude

10

13

11-- hasql

14-- hasql

@@ -20,6 +23,7 @@ import Data.Text ( pack )

20

23

21

24

22-- | Like 'Rel8.JSONEncoded', but works for @jsonb@ columns.

25-- | Like 'Rel8.JSONEncoded', but works for @jsonb@ columns.

26+type JSONBEncoded :: Type -> Type

23newtype JSONBEncoded a = JSONBEncoded { fromJSONBEncoded :: a }

27newtype JSONBEncoded a = JSONBEncoded { fromJSONBEncoded :: a }

24

28

25

29

src/Rel8/Type/JSONEncoded.hs+4

@@ -1,3 +1,5 @@

1+{-# language StandaloneKindSignatures #-}

2+

1module Rel8.Type.JSONEncoded ( JSONEncoded(..) ) where

3module Rel8.Type.JSONEncoded ( JSONEncoded(..) ) where

2

4

3-- aeson

5-- aeson

@@ -5,6 +7,7 @@ import Data.Aeson ( FromJSON, ToJSON, parseJSON, toJSON )

5import Data.Aeson.Types ( parseEither )

7import Data.Aeson.Types ( parseEither )

6

8

7-- base

9-- base

10+import Data.Kind ( Type )

8import Prelude

11import Prelude

9

12

10-- rel8

13-- rel8

@@ -15,6 +18,7 @@ import Rel8.Type.Information ( parseTypeInformation )

15-- | A deriving-via helper type for column types that store a Haskell value

18-- | A deriving-via helper type for column types that store a Haskell value

16-- using a JSON encoding described by @aeson@'s 'ToJSON' and 'FromJSON' type

19-- using a JSON encoding described by @aeson@'s 'ToJSON' and 'FromJSON' type

17-- classes.

20-- classes.

21+type JSONEncoded :: Type -> Type

18newtype JSONEncoded a = JSONEncoded { fromJSONEncoded :: a }

22newtype JSONEncoded a = JSONEncoded { fromJSONEncoded :: a }

19

23

20

24

src/Rel8/Type/Num.hs+4−1

@@ -18,6 +18,7 @@ import Prelude

18

19-- rel8

20import Rel8.Type ( DBType )

21+import Rel8.Type.Ord ( DBOrd )

21

22

22-- scientific

23-- scientific

23import Data.Scientific ( Scientific )

24import Data.Scientific ( Scientific )

@@ -39,13 +40,14 @@ instance DBNum Scientific

39-- expressions. This is a Rel8 concept, and allows us to provide

40-- expressions. This is a Rel8 concept, and allows us to provide

40-- 'fromIntegral'.

41-- 'fromIntegral'.

41type DBIntegral :: Type -> Constraint

42type DBIntegral :: Type -> Constraint

42−class DBNum a => DBIntegral a

43+class (DBNum a, DBOrd a) => DBIntegral a

43instance DBIntegral Int16

44instance DBIntegral Int16

44instance DBIntegral Int32

45instance DBIntegral Int32

45instance DBIntegral Int64

46instance DBIntegral Int64

46

47

48

48-- | The class of database types that support the @/@ operator.

49-- | The class of database types that support the @/@ operator.

50+type DBFractional :: Type -> Constraint

49class DBNum a => DBFractional a

51class DBNum a => DBFractional a

50instance DBFractional Float

52instance DBFractional Float

51instance DBFractional Double

53instance DBFractional Double

@@ -53,6 +55,7 @@ instance DBFractional Scientific

53

55

54

56

55-- | The class of database types that support the @/@ operator.

57-- | The class of database types that support the @/@ operator.

58+type DBFloating :: Type -> Constraint

56class DBFractional a => DBFloating a

59class DBFractional a => DBFloating a

57instance DBFloating Float

60instance DBFloating Float

58instance DBFloating Double

61instance DBFloating Double

src/Rel8/Type/Ord.hs−2

@@ -75,7 +75,6 @@ instance Sql DBOrd a => DBOrd (NonEmpty a)

75-- | The class of database types that support the @max@ aggregation function.

76type DBMax :: Type -> Constraint

77class DBOrd a => DBMax a

78−instance DBMax Bool

79instance DBMax Char

78instance DBMax Char

80instance DBMax Int16

79instance DBMax Int16

81instance DBMax Int32

80instance DBMax Int32

@@ -101,7 +100,6 @@ instance Sql DBMax a => DBMax (NonEmpty a)

101-- | The class of database types that support the @min@ aggregation function.

100-- | The class of database types that support the @min@ aggregation function.

102type DBMin :: Type -> Constraint

101type DBMin :: Type -> Constraint

103class DBOrd a => DBMin a

102class DBOrd a => DBMin a

104−instance DBMin Bool

105instance DBMin Char

103instance DBMin Char

106instance DBMin Int16

104instance DBMin Int16

107instance DBMin Int32

105instance DBMin Int32

src/Rel8/Type/ReadShow.hs+3

@@ -1,10 +1,12 @@

1{-# language ScopedTypeVariables #-}

2+{-# language StandaloneKindSignatures #-}

2{-# language TypeApplications #-}

3{-# language TypeApplications #-}

3{-# language ViewPatterns #-}

4{-# language ViewPatterns #-}

4

5

5module Rel8.Type.ReadShow ( ReadShow(..) ) where

6module Rel8.Type.ReadShow ( ReadShow(..) ) where

6

7

7-- base

8-- base

9+import Data.Kind ( Type )

8import Data.Proxy ( Proxy( Proxy ) )

10import Data.Proxy ( Proxy( Proxy ) )

9import Data.Typeable ( Typeable, typeRep )

11import Data.Typeable ( Typeable, typeRep )

10import Prelude

12import Prelude

@@ -20,6 +22,7 @@ import qualified Data.Text as Text

20

22

21-- | A deriving-via helper type for column types that store a Haskell value

23-- | A deriving-via helper type for column types that store a Haskell value

22-- using a Haskell's 'Read' and 'Show' type classes.

24-- using a Haskell's 'Read' and 'Show' type classes.

25+type ReadShow :: Type -> Type

23newtype ReadShow a = ReadShow { fromReadShow :: a }

26newtype ReadShow a = ReadShow { fromReadShow :: a }

24

27

25

28

src/Rel8/Type/Tag.hs+1

@@ -90,6 +90,7 @@ instance DBMonoid MaybeTag where

90 memptyExpr = litExpr mempty

91

92

93+type Tag :: Type

93newtype Tag = Tag Text

94newtype Tag = Tag Text

94 deriving newtype

95 deriving newtype

95 ( Eq, Ord, Read, Show

96 ( Eq, Ord, Read, Show

src/Rel8/Window.hsnew file+97

@@ -0,0 +1,97 @@

1+{-# language DerivingVia #-}

2+{-# language FlexibleContexts #-}

3+{-# language GeneralizedNewtypeDeriving #-}

4+{-# language ScopedTypeVariables #-}

5+{-# language StandaloneKindSignatures #-}

6+{-# language TypeApplications #-}

7+

8+module Rel8.Window

9+ ( Window(..)

10+ , Partition

11+ , over

12+ , partitionBy

13+ , orderPartitionBy

14+ )

15+where

16+

17+-- base

18+import Data.Functor.Const ( Const( Const ), getConst )

19+import Data.Functor.Contravariant ( Contravariant, contramap )

20+import Data.Kind ( Type )

21+import Prelude

22+

23+-- opaleye

24+import qualified Opaleye.Internal.Window as Opaleye

25+import qualified Opaleye.Internal.PackMap as Opaleye

26+

27+-- profunctors

28+import Data.Profunctor ( Profunctor )

29+

30+-- product-profunctors

31+import Data.Profunctor.Product ( ProductProfunctor, (****), purePP )

32+

33+-- rel8

34+import Rel8.Expr.Opaleye ( toColumn, toPrimExpr )

35+import Rel8.Order( Order( Order ) )

36+import Rel8.Schema.HTable ( hfield, htabulateA )

37+import Rel8.Table ( Columns, toColumns )

38+import Rel8.Table.Eq ( EqTable )

39+

40+-- semigroupoids

41+import Data.Functor.Apply ( Apply, WrappedApplicative(..) )

42+

43+

44+-- | 'Window' is an applicative functor that represents expressions that

45+-- contain

46+-- [window functions](https://www.postgresql.org/docs/current/tutorial-window.html).

47+-- 'Rel8.Query.Window.window' can be used to

48+-- evaluate these expressions over a particular query.

49+type Window :: Type -> Type -> Type

50+newtype Window a b = Window (Opaleye.Windows a b)

51+ deriving newtype (Profunctor)

52+ deriving newtype (Functor, Applicative)

53+ deriving (Apply) via (WrappedApplicative (Window a))

54+

55+

56+instance ProductProfunctor Window where

57+ purePP = pure

58+ (****) = (<*>)

59+

60+

61+-- | In PostgreSQL, window functions must specify the \"window\" or

62+-- \"partition\" over which they operate. The syntax for this looks like:

63+-- @SUM(salary) OVER (PARTITION BY department)@. The Rel8 type 'Partition'

64+-- represents everything that comes after @OVER@.

65+--

66+-- 'Partition' is a 'Monoid', so 'Window's created with 'partitionBy' and

67+-- 'orderWindowBy' can be combined using '<>'.

68+type Partition :: Type -> Type

69+newtype Partition a = Partition (Opaleye.Window a)

70+ deriving newtype (Contravariant, Semigroup, Monoid)

71+

72+

73+-- | 'over' adds a 'Partition' to a 'Window' expression.

74+--

75+-- @@@

76+-- 'Rel8.Table.Window.cumulative' ('Rel8.Expr.Aggregate.sum' . salary) `over` 'partitionBy' department <> 'orderPartitionBy' (salary >$< 'Rel8.desc')

77+-- @@@

78+over :: Window a b -> Partition a -> Window a b

79+over (Window (Opaleye.Windows (Opaleye.PackMap w))) (Partition p) =

80+ Window $ Opaleye.Windows $ Opaleye.PackMap $ \f ->

81+ w (\(o, p') -> f (o, p' <> p))

82+infixl 1 `over`

83+

84+

85+-- | Restricts a window function to operate only the group of rows that share

86+-- the same value(s) for the given expression(s).

87+partitionBy :: forall b a. EqTable b => (a -> b) -> Partition a

88+partitionBy f =

89+ Partition $ contramap (toColumns . f) $ getConst $

90+ htabulateA @(Columns b) $ \field ->

91+ Const $ Opaleye.partitionBy (toColumn . toPrimExpr . (`hfield` field))

92+

93+

94+-- | Controls the order in which rows are processed by window functions. This

95+-- does not need to match the ordering of the overall query.

96+orderPartitionBy :: Order a -> Partition a

97+orderPartitionBy (Order ordering) = Partition $ Opaleye.orderPartitionBy ordering

tests/Main.hs+94

@@ -1,3 +1,4 @@

1+{-# language BangPatterns #-}

1{-# language BlockArguments #-}

2{-# language BlockArguments #-}

2{-# language DeriveAnyClass #-}

3{-# language DeriveAnyClass #-}

3{-# language DeriveGeneric #-}

4{-# language DeriveGeneric #-}

@@ -5,6 +6,7 @@

5{-# language FlexibleContexts #-}

6{-# language FlexibleContexts #-}

6{-# language FlexibleInstances #-}

7{-# language FlexibleInstances #-}

7{-# language MonoLocalBinds #-}

8{-# language MonoLocalBinds #-}

9+{-# language NamedFieldPuns #-}

8{-# language OverloadedStrings #-}

10{-# language OverloadedStrings #-}

9{-# language RecordWildCards #-}

11{-# language RecordWildCards #-}

10{-# language ScopedTypeVariables #-}

12{-# language ScopedTypeVariables #-}

@@ -36,6 +38,7 @@ import qualified Data.ByteString.Lazy

36import Data.CaseInsensitive ( mk )

38import Data.CaseInsensitive ( mk )

37

39

38-- containers

40-- containers

41+import Data.Containers.ListUtils ( nubOrdOn )

39import qualified Data.Map.Strict as Map

42import qualified Data.Map.Strict as Map

40

43

41-- hasql

44-- hasql

@@ -113,11 +116,13 @@ tests =

113 , testCatMaybeTable getTestDatabase

116 , testCatMaybeTable getTestDatabase

114 , testCatMaybe getTestDatabase

117 , testCatMaybe getTestDatabase

115 , testMaybeTable getTestDatabase

118 , testMaybeTable getTestDatabase

119+ , testAggregateMaybeTable getTestDatabase

116 , testNestedTables getTestDatabase

120 , testNestedTables getTestDatabase

117 , testMaybeTableApplicative getTestDatabase

121 , testMaybeTableApplicative getTestDatabase

118 , testLogicalFixities getTestDatabase

122 , testLogicalFixities getTestDatabase

119 , testUpdate getTestDatabase

123 , testUpdate getTestDatabase

120 , testDelete getTestDatabase

124 , testDelete getTestDatabase

125+ , testUpsert getTestDatabase

121 , testSelectNestedPairs getTestDatabase

126 , testSelectNestedPairs getTestDatabase

122 , testSelectArray getTestDatabase

127 , testSelectArray getTestDatabase

123 , testNestedMaybeTable getTestDatabase

128 , testNestedMaybeTable getTestDatabase

@@ -133,6 +138,7 @@ tests =

133 flip run conn do

138 flip run conn do

134 sql "CREATE EXTENSION citext"

139 sql "CREATE EXTENSION citext"

135 sql "CREATE TABLE test_table ( column1 text not null, column2 bool not null )"

140 sql "CREATE TABLE test_table ( column1 text not null, column2 bool not null )"

141+ sql "CREATE TABLE unique_table ( \"key\" text not null unique, \"value\" text not null )"

136 sql "CREATE SEQUENCE test_seq"

142 sql "CREATE SEQUENCE test_seq"

137

143

138 return db

144 return db

@@ -555,6 +561,28 @@ testMaybeTable = databasePropertyTest "maybeTable" \transaction -> evalM do

555 _ -> sort selected === sort rows

561 _ -> sort selected === sort rows

556

562

557

563

564+testAggregateMaybeTable :: IO TmpPostgres.DB -> TestTree

565+testAggregateMaybeTable = databasePropertyTest "aggregateMaybeTable" \transaction -> evalM do

566+ rows <- forAll $ Gen.list (Range.linear 0 10) (Gen.maybe (Gen.int64 (Range.linear 0 10)))

567+

568+ let

569+ aggregate = go 0 False False

570+ where

571+ go !n nothing _ (Just a : as) = go (n + a) nothing True as

572+ go n _ just (Nothing : as) = go n True just as

573+ go _ False False [] = []

574+ go _ True False [] = [Nothing]

575+ go n False True [] = [Just n]

576+ go n True True [] = [Nothing, Just n]

577+

578+ transaction do

579+ selected <- lift do

580+ statement () $ Rel8.select do

581+ Rel8.aggregate $ Rel8.aggregateMaybeTable Rel8.sum <$> Rel8.values (Rel8.lit <$> rows)

582+

583+ sort selected === aggregate rows

584+

585+

558data TwoTestTables f =

586data TwoTestTables f =

559 TwoTestTables

587 TwoTestTables

560 { testTable1 :: TestTable f

588 { testTable1 :: TestTable f

@@ -685,6 +713,72 @@ testDelete = databasePropertyTest "Can DELETE TestTable" \transaction -> do

685 sort (deleted <> selected) === sort rows

713 sort (deleted <> selected) === sort rows

686

714

687

715

716+data UniqueTable f = UniqueTable

717+ { uniqueTableKey :: Rel8.Column f Text

718+ , uniqueTableValue :: Rel8.Column f Text

719+ }

720+ deriving stock Generic

721+ deriving anyclass Rel8.Rel8able

722+

723+

724+deriving stock instance Eq (UniqueTable Result)

725+deriving stock instance Ord (UniqueTable Result)

726+deriving stock instance Show (UniqueTable Result)

727+

728+

729+uniqueTableSchema :: Rel8.TableSchema (UniqueTable Rel8.Name)

730+uniqueTableSchema =

731+ Rel8.TableSchema

732+ { name = "unique_table"

733+ , schema = Nothing

734+ , columns = UniqueTable

735+ { uniqueTableKey = "key"

736+ , uniqueTableValue = "value"

737+ }

738+ }

739+

740+

741+genUniqueTable :: Gen (UniqueTable Result)

742+genUniqueTable = do

743+ uniqueTableKey <- Gen.text (Range.linear 0 5) Gen.alphaNum

744+ uniqueTableValue <- Gen.text (Range.linear 0 5) Gen.alphaNum

745+ pure UniqueTable {..}

746+

747+

748+testUpsert :: IO TmpPostgres.DB -> TestTree

749+testUpsert = databasePropertyTest "Can UPSERT UniqueTable" \transaction -> do

750+ as <- unique $ forAll $ Gen.list (Range.linear 0 20) genUniqueTable

751+ bs <- unique $ forAll $ Gen.list (Range.linear 0 20) genUniqueTable

752+

753+ transaction do

754+ selected <- lift do

755+ statement () $ Rel8.insert Rel8.Insert

756+ { into = uniqueTableSchema

757+ , rows = Rel8.values $ Rel8.lit <$> as

758+ , onConflict = Rel8.DoNothing

759+ , returning = pure ()

760+ }

761+

762+ statement () $ Rel8.insert Rel8.Insert

763+ { into = uniqueTableSchema

764+ , rows = Rel8.values $ Rel8.lit <$> bs

765+ , onConflict = Rel8.DoUpdate Rel8.Upsert

766+ { index = uniqueTableKey

767+ , set = \UniqueTable {uniqueTableValue} old -> old {uniqueTableValue}

768+ , updateWhere = \_ _ -> Rel8.true

769+ }

770+ , returning = pure ()

771+ }

772+

773+ statement () $ Rel8.select do

774+ Rel8.each uniqueTableSchema

775+

776+ fromUniqueTables selected === fromUniqueTables bs <> fromUniqueTables as

777+ where

778+ unique = fmap (nubOrdOn uniqueTableKey)

779+ fromUniqueTables = Map.fromList . map \(UniqueTable key value) -> (key, value)

780+

781+

688newtype HKNestedPair f = HKNestedPair { pairOne :: (TestTable f, TestTable f) }

782newtype HKNestedPair f = HKNestedPair { pairOne :: (TestTable f, TestTable f) }

689 deriving stock Generic

783 deriving stock Generic

690 deriving anyclass Rel8.Rel8able

784 deriving anyclass Rel8.Rel8able

tests/Rel8/Generic/Rel8able/Test.hs+10−1

@@ -5,6 +5,7 @@

5{-# language DuplicateRecordFields #-}

6{-# language FlexibleInstances #-}

7{-# language MultiParamTypeClasses #-}

8+{-# language StandaloneKindSignatures #-}

8{-# language TypeFamilies #-}

9{-# language TypeFamilies #-}

9{-# language UndecidableInstances #-}

10{-# language UndecidableInstances #-}

10

11

@@ -171,9 +172,17 @@ data NestedTableTestB f = NestedTableTestB

171 deriving anyclass Rel8able

172 deriving anyclass Rel8able

172

173

174

174−

175newtype IdRecord a f = IdRecord { recordId :: Column f a }

176 deriving stock Generic

177

178

179instance DBType a => Rel8able (IdRecord a)

180+

181+

182+type Nest :: KRel8able -> KRel8able -> KRel8able

183+data Nest t u f = Nest

184+ { foo :: t f

185+ , bar :: u f

186+ }

187+ deriving stock Generic

188+ deriving anyclass Rel8able