7c5422f..master · rel8

git.iko.soy/rel8

123 files changed+4415−2224

unifiedsplit

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

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

99 persist-credentials: false

1010 submodules: true

1111

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

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

1313 with:

1414 nix_path: nixpkgs=channel:nixos-unstable

1515 extra_nix_config: |

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

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

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

1818

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

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

2020 with:

2121 name: rel8

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

Changelog.md+128−1

@@ -1,13 +1,140 @@

1−# 1.1.0.0 (??)

1+# 1.4.0.0 (2002-08-17)

33## Breaking changes

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

7+## New features

9+* `NullTable`/`HNull` have been added. This is an alternative to `MaybeTable` that doesn't use a tag columns. It's less flexible (no `Functor` or `Applicative` instance) and is meaningless when used with a table that has no non-nullable columns (so nesting `NullTable` is redundant). But in situations where the underlying `Table` does have non-nullable columns, it can losslessly converted to and from `MaybeTable`. It is useful for embedding into a base table when you don't want to store the extra tag column in your schema. ([#173](https://github.com/circuithub/rel8/pull/173))

10+* Add `fromMaybeTable`. ([#179](https://github.com/circuithub/rel8/pull/179))

11+* Add `alignMaybeTable`. ([#196](https://github.com/circuithub/rel8/pull/196))

12+

13+## Improvements

14+

15+* Optimize implementation of `AltTable` for `Tabulation` ([#178](https://github.com/circuithub/rel8/pull/178))

16+

17+## Other

18+

19+* Documentation improvements for `HADT`. ([#177](https://github.com/circuithub/rel8/pull/177))

20+* Document example usage of `groupBy`. ([#184](https://github.com/circuithub/rel8/pull/184))

21+* Build with and require Opaleye >= 0.9.3.3. ([#190](https://github.com/circuithub/rel8/pull/190))

22+* Build with `hasql` 1.6. ([#195](https://github.com/circuithub/rel8/pull/195))

23+

24+# 1.3.1.0 (2022-01-20)

25+

26+## Other

27+

28+* Rel8 now requires Opaleye >= 0.9.1. ([#165](https://github.com/circuithub/rel8/pull/165))

29+

30+# 1.3.0.0 (2022-01-31)

31+

32+## Breaking changes

33+

34+* `div` and `mod` have been changed to match Haskell semantics. If you need the PostgreSQL `div()` and `mod()` functions, use `quot` and `rem`. While this is not an API change, we feel this is a breaking change in semantics and have bumped the major version number. ([#155](https://github.com/circuithub/rel8/pull/155))

35+

36+## New features

37+

38+* `divMod` and `quotRem` functions have been added, matching Haskell's `Prelude` functions. ([#155](https://github.com/circuithub/rel8/pull/155))

39+* `avg` and `mode` aggregation functions to find the mean value of an expression, or the most common row in a query, respectively. ([#152](https://github.com/circuithub/rel8/pull/152))

40+* The full `EqTable` and `OrdTable` classes have been exported, allowing for instances to be manually created. ([#157](https://github.com/circuithub/rel8/pull/157))

41+* Added `like` and `ilike` (for the `LIKE` and `ILIKE` operators). ([#146](https://github.com/circuithub/rel8/pull/146))

42+

43+## Other

44+

45+* Rel8 now requires Opaleye 0.9. ([#158](https://github.com/circuithub/rel8/pull/158))

46+* Rel8's test suite supports Hedgehog 1.1. ([#160](https://github.com/circuithub/rel8/pull/160))

47+* The documentation for binary operations has been corrected. ([#162](https://github.com/circuithub/rel8/pull/162))

48+

49+# 1.2.2.0 (2021-11-21)

50+

51+## Other

52+

53+* Support GHC 9.2 ([#145](https://github.com/circuithub/rel8/pull/145))

54+* Correct the documentation for `except` ([#147](https://github.com/circuithub/rel8/pull/147))

55+* Support `hasql` 1.5 ([#149](https://github.com/circuithub/rel8/pull/149))

56+

57+# 1.2.1.0 (2021-11-21)

58+

59+## New features

60+

61+* `castTable` has been added, which casts all columns selected from in `Query` according to the types of columns. This can occasionally be useful when using `many`/`some` on older PostgreSQL versions. ([#137](https://github.com/circuithub/rel8/pull/137))

62+

63+* Added `<:`, `<=:`, `>:`, `>=:`, `greatest` and `least`, which sort all columns in a table lexicographically. These operators are like the `<.` operators which operate on `Expr`s, but the `<:` operate on entire tables. ([#139](https://github.com/circuithub/rel8/pull/139))

64+

65+## Other

66+

67+* Support opaleye-0.8 ([#142](https://github.com/circuithub/rel8/pull/142))

68+

69+# 1.2.0.0 (2021-10-22)

70+

71+## New features

72+

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

74+

75+## Bug fixes

76+

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

78+

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

80+

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

82+

83+## Breaking changes

84+

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

86+

87+# 1.1.0.0 (2021-07-16)

88+

89+## New features

90+

91+* You can derive `Rel8able` for "vanilla" higher-kinded data types - data types that don't use the `Column` type family. For example, the following is now possible:

92+

93+ ```haskell

94+ data MyTable f = MyTable

95+ { myTableX :: f Int32

96+ , myTableY :: f Text

97+ } deriving (Generic, Rel8able)

98+ ```

99+

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:

101+

102+ ```haskell

103+ x <- project myTableX <$> many ...

104+ ```

105+

106+* `Insert`'s `onConflict` field now has a new option - `DoUpdate`. This maps to PostgreSQL's `ON CONFLICT DO UPDATE` syntax, which provides upsert support. ([#85](https://github.com/circuithub/rel8/pull/85))

107+

108+* `Insert`, `Update` and `Delete` has all been expanded to work with `Query`s. In particular:

109+

110+ * `Delete` now supports a `USING` sub-query

111+ * `Update` now supports a `FROM` sub-query

112+ * `Insert` can delete the result of any arbitrary `Query` (providing the types match)

113+

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

115+

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

117+

118+## Breaking changes

119+

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

121+

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

6123

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

8125

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

10127

128+* `EitherTable`, `ListTable`, `MaybeTable`, `NonEmptyTable` and `TheseTable` now all have an extra parameter which tracks the context of the table. If you manually specified any types before, you need to provide this parameter - usually `Expr` will be the correct choice. ([#101](https://github.com/circuithub/rel8/pull/101))

129+

130+* We've done a lot of work to simplify the internals of Rel8, but some of these are breaking changes. However, most of these API changes shouldn't affect users as they are mostly types used in type inference, or affect classes where users don't need to define their own instances.

131+

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

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

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

135+

136+* `select`, `insert`, `update` and `delete` now produce Hasql `Statement`s, rather than actually running the statement as IO. This allows Rel8 to be used with transaction/connection-managing monads like [`hasql-transaction`](https://hackage.haskell.org/package/hasql-transaction). ([#94](https://github.com/circuithub/rel8/pull/94))

137+

11138## Bug fixes

12139

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

cabal.project−5

@@ -1,6 +1 @@

11packages: .

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

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

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

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

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

11let

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

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

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

66 nixpkgsArgs = haskellNix.nixpkgsArgs;

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

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

1010 pkgs = import nixpkgsSrc nixpkgsArgs;

1111

docs/concepts/insert.rst+37−10

@@ -21,9 +21,16 @@ using ``delete``. ``Delete`` takes:

2121``from``

2222 The ``TableSchema`` for the table to delete rows from.

2323

24+``using``

25+ This is a simple ``Query`` that forms the ``USING`` clause of the ``DELETE``

26+ statement. This can be used to join against other tables, and the results

27+ can be referenced in the ``deleteWhere`` parameter. For simple ``DELETE``\s

28+ where you don't need to do this, you can set ``using = pure ()``.

29+

2430``deleteWhere``

2531 The ``WHERE`` clause of the ``DELETE`` statement. This is a function that

26− takes a single ``Expr`` table as input.

32+ takes two inputs: the result of the ``using`` query, and the current value

33+ of the row.

2734

2835``returning``

2936 What to return - see :ref:`returning`.

@@ -37,16 +44,23 @@ using ``update``. ``Update`` takes:

3744``target``

3845 The ``TableSchema`` for the table to update rows in.

3946

40−``updateWhere``

41− The ``WHERE`` clause of the ``UPDATE`` statement. This is a function that

42− takes a single ``Expr`` table as input.

47+``from``

48+ This is a simple ``Query`` that forms the ``FROM`` clause of the ``UPDATE``

49+ statement. This can be used to join against other tables, and the results

50+ can be referenced in the ``set`` and ``updateWhere`` parameters. For simple

51+ ``UPDATE``\s where you don't need to do this, you can set ``from = pure ()``.

4352

4453``set``

4554 A row to row transformation function, indicating how to update selected rows.

4655 This function takes rows of the same shape as ``target`` but in the ``Expr``

4756 context. One way to write this function is to use record update syntax::

4857

49− set = \row -> row { rowName = "new name" }

58+ set = \from row -> row { rowName = "new name" }

59+

60+``updateWhere``

61+ The ``WHERE`` clause of the ``UPDATE`` statement. This is a function that

62+ takes two inputs: the result of the ``from`` query, and the current value of

63+ the row.

5064

5165``returning``

5266 What to return - see :ref:`returning`.

@@ -64,11 +78,11 @@ using ``insert``. ``Insert`` takes:

6478 The rows to insert. These are the same as ``into``, but in the ``Expr``

6579 context. You can construct rows from their individual fields::

6680

67− rows = [ MyTable { myTableA = lit "A", myTableB = lit 42 }

81+ rows = values [ MyTable { myTableA = lit "A", myTableB = lit 42 }

6882

6983 or you can use ``lit`` on a table value in the ``Result`` context::

7084

71− rows = [ lit MyTable { myTableA = "A", myTableB = 42 }

85+ rows = values [ lit MyTable { myTableA = "A", myTableB = 42 }

7286

7387``onConflict``

7488 What should happen if an insert clashes with rows that already exist. This

@@ -80,6 +94,10 @@ using ``insert``. ``Insert`` takes:

8094 ``DoNothing``

8195 PostgreSQL should not insert the duplicate rows.

8296

97+ ``DoUpdate``

98+ PostgreSQL should instead try to update any existing rows that conflict

99+ with rows proposed for insertion.

100+

83101``returning``

84102 What to return - see :ref:`returning`.

85103

@@ -99,11 +117,20 @@ For example, if we are inserting orders, we might want the order ids returned::

99117

100118 insert Insert

101119 { into = orderSchema

102− , rows = [ order ]

120+ , rows = values [ order ]

103121 , onConflict = Abort

104122 , returning = Projection orderId

105123 }

106124

125+If we don't want to return anything, we can use ``pure ()``::

126+

127+ insert Insert

128+ { into = orderSchema

129+ , rows = values [ order ]

130+ , onConflict = Abort

131+ , returning = pure ()

132+ }

133+

107134Default values

108135--------------

109136

@@ -119,7 +146,7 @@ construct the ``DEFAULT`` expression::

119146

120147 insert Insert

121148 { into = orderSchema

122− , rows = [ Order { orderId = unsafeDefault, ... } ]

149+ , rows = values [ Order { orderId = unsafeDefault, ... } ]

123150 , onConflict = Abort

124151 , returning = Projection orderId

125152 }

@@ -148,7 +175,7 @@ them in Rel8, rather than in your database schema.

148175

149176 insert Insert

150177 { into = orderSchema

151− , rows = [ Order { orderId = nextval "order_id_seq", ... } ]

178+ , rows = values [ Order { orderId = nextval "order_id_seq", ... } ]

152179 , onConflict = Abort

153180 , returning = Projection orderId

154181 }

docs/cookbook.rst+9−7

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

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

143143posts. We want our query to return:

144144

145−1. The latest 5 blog posts.

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

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

148148

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

150150

151151 latestBlogPosts = do

152152 post <- each postSchema

153153

154− tags <- aggregate do

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

155+ tags <- some $ do

155156 tag <- each tagSchema

156157 where_ (tagPostId tag ==. postId post)

157− return (listAgg (tagName tag))

158+ return (tagName tag)

158159

159− latestComments <-

160− many $

161− limit 3 $

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

161+ latestComments <-

162+ many $

163+ limit 3 $

162164 orderBy (commentCreatedAt >$< desc) do

163165 comment <- each commentSchema

164166 where_ (commentPostId comment ==. postId post)

nix/sources.json+9−9

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

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

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

77 "repo": "haskell.nix",

8− "rev": "3856d2d24dca0ecc71fcfc314253a2a2d07a3c4f",

9− "sha256": "0s69nasqhkv8n0qmdv075k83p3z584ja9vkzdnp2291mymghvx87",

8+ "rev": "0837156c56cb5350dd9bd84eb424187e00aa1e8a",

9+ "sha256": "1djmv5a0vfj78csw2cad6nicrs8iqrp928b9b3v4h7lwwhhzliwl",

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

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

1313 },

1414 "niv": {

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

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

1818 "owner": "nmattia",

1919 "repo": "niv",

20− "rev": "e0ca65c81a2d7a4d82a189f1e23a48d59ad42070",

21− "sha256": "1pq9nh1d8nn3xvbdny8fafzw87mj7gsmp6pxkdl65w2g18rmcmzx",

20+ "rev": "acdb1726783637852c01e0ad639ac9cbec28d8c8",

21+ "sha256": "1wszl8q70z6wfgkh2dvgmhhry6qp9nar421qq2ifd17hq2jj9ck3",

2222 "type": "tarball",

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

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

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

2525 },

2626 "nixpkgs": {

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

2929 "homepage": null,

3030 "owner": "nixos",

3131 "repo": "nixpkgs",

32− "rev": "59b8d9cf24e9fcf10341a0923c9bdca088dca8c8",

33− "sha256": "08f38v4b2kcxnbapdwrb54bglka92cxj9qlnqlk5px206jyq9v4c",

32+ "rev": "1c1f5649bb9c1b0d98637c8c365228f57126f361",

33+ "sha256": "0f2nvdijyxfgl5kwyb4465pppd5vkhqxddx6v40k2s0z9jfhj0xl",

3434 "type": "tarball",

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

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

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

3737 }

3838}

nix/sources.nix+21−1

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

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

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

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

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

35+ submoduleArg =

36+ let

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

38+ emptyArgWithWarning =

39+ if submodules == true

40+ then

41+ builtins.trace

42+ (

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

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

45+ + "does not support them"

46+ )

47+ {}

48+ else {};

49+ in

50+ if nixSupportsSubmodules

51+ then { inherit submodules; }

52+ else emptyArgWithWarning;

3453 in

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

54+ builtins.fetchGit

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

3656

3757 fetch_local = spec: spec.path;

3858

rel8.cabal+32−12

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

11cabal-version: 2.0

22name: rel8

3−version: 1.0.0.1

3+version: 1.4.0.0

44synopsis: Hey! Hey! Can u rel8?

55license: BSD3

66license-file: LICENSE

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

2020library

2121 build-depends:

2222 aeson

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

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

24+ , bifunctors

2425 , bytestring

2526 , case-insensitive

2627 , comonad

2728 , contravariant

28− , hasql ^>= 1.4.5.1

29− , opaleye ^>= 0.7.3.0

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

30+ , opaleye ^>= 0.9.6.1

31+ , pretty

3032 , profunctors

33+ , product-profunctors

3134 , scientific

3235 , semialign

3336 , semigroupoids

3437 , text

3538 , these

3639 , time

37− , transformers

3840 , uuid

3941 default-language:

4042 Haskell2010

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

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

4547 -Wno-monomorphism-restriction

4648 -Wno-missing-local-signatures

49+ -Wno-missing-kind-signatures

4750 hs-source-dirs:

4851 src

4952 exposed-modules:

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

5154 Rel8.Expr.Num

5255 Rel8.Expr.Text

5356 Rel8.Expr.Time

57+ Rel8.Tabulate

5458

5559 other-modules:

5660 Rel8.Aggregate

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

6266 Rel8.Column.List

6367 Rel8.Column.Maybe

6468 Rel8.Column.NonEmpty

69+ Rel8.Column.Null

6570 Rel8.Column.These

6671

6772 Rel8.Expr

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

7782 Rel8.Expr.Order

7883 Rel8.Expr.Sequence

7984 Rel8.Expr.Serialize

85+ Rel8.Expr.Window

8086

8187 Rel8.FCF

8288

@@ -103,21 +109,23 @@ library

103109 Rel8.Query.Evaluate

104110 Rel8.Query.Exists

105111 Rel8.Query.Filter

112+ Rel8.Query.Indexed

106113 Rel8.Query.Limit

107114 Rel8.Query.List

108115 Rel8.Query.Maybe

109116 Rel8.Query.Null

110117 Rel8.Query.Opaleye

111118 Rel8.Query.Order

119+ Rel8.Query.Rebind

112120 Rel8.Query.Set

113121 Rel8.Query.SQL

114122 Rel8.Query.These

115123 Rel8.Query.Values

124+ Rel8.Query.Window

116125

117− Rel8.Schema.Context

118126 Rel8.Schema.Context.Nullify

119− Rel8.Schema.Context.Virtual

120127 Rel8.Schema.Dict

128+ Rel8.Schema.Field

121129 Rel8.Schema.HTable

122130 Rel8.Schema.HTable.Either

123131 Rel8.Schema.HTable.Identity

@@ -135,21 +143,26 @@ library

135143 Rel8.Schema.Null

136144 Rel8.Schema.Result

137145 Rel8.Schema.Spec

138− Rel8.Schema.Spec.Constrain

139146 Rel8.Schema.Table

140147

141148 Rel8.Statement.Delete

142149 Rel8.Statement.Insert

150+ Rel8.Statement.OnConflict

143151 Rel8.Statement.Returning

144152 Rel8.Statement.Select

153+ Rel8.Statement.Set

154+ Rel8.Statement.SQL

145155 Rel8.Statement.Update

156+ Rel8.Statement.Using

146157 Rel8.Statement.View

158+ Rel8.Statement.Where

147159

148160 Rel8.Table

149161 Rel8.Table.ADT

150162 Rel8.Table.Aggregate

151163 Rel8.Table.Alternative

152164 Rel8.Table.Bool

165+ Rel8.Table.Cols

153166 Rel8.Table.Either

154167 Rel8.Table.Eq

155168 Rel8.Table.HKD

@@ -157,15 +170,18 @@ library

157170 Rel8.Table.Maybe

158171 Rel8.Table.Name

159172 Rel8.Table.NonEmpty

173+ Rel8.Table.Null

160174 Rel8.Table.Nullify

161175 Rel8.Table.Opaleye

162176 Rel8.Table.Ord

163177 Rel8.Table.Order

164− Rel8.Table.Recontextualize

178+ Rel8.Table.Projection

165179 Rel8.Table.Rel8able

166180 Rel8.Table.Serialize

167181 Rel8.Table.These

182+ Rel8.Table.Transpose

168183 Rel8.Table.Undefined

184+ Rel8.Table.Window

169185

170186 Rel8.Type

171187 Rel8.Type.Array

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

184200 Rel8.Type.Sum

185201 Rel8.Type.Tag

186202

203+ Rel8.Window

204+

205+

187206test-suite tests

188207 type: exitcode-stdio-1.0

189208 build-depends:

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

192211 , case-insensitive

193212 , containers

194213 , hasql

195− , hedgehog ^>=1.0.2

196− , lifted-base ^>=0.2.3.12

197− , monad-control ^>=1.0.2.3

214+ , hasql-transaction

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

216+ , mmorph

198217 , rel8

199218 , scientific

200219 , tasty

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

202221 , text

203222 , time

204223 , tmp-postgres ^>=1.34.1.0

224+ , transformers

205225 , uuid

206226

207227 other-modules:

shell.nix+1−1

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

11let

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

3− pkgs = import sources.nixpkgs {};

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

44 hsPkgs = import ./default.nix;

55in

66 hsPkgs.shellFor {

src/Rel8.hs+297−10

@@ -38,24 +38,27 @@ module Rel8

3838 , HMaybe

3939 , HList

4040 , HNonEmpty

41+ , HNull

4142 , HThese

4243 , Lift

4344

4445 , Table(..)

4546 , HTable

46− , Recontextualize

47+ , Transposes

4748 , AltTable((<|>:))

4849 , AlternativeTable( emptyTable )

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

50− , OrdTable, ascTable, descTable

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

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

5152 , lit

5253 , bool

5354 , case_

55+ , castTable

5456

5557 -- ** @MaybeTable@

5658 , MaybeTable

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

5860 , isNothingTable, isJustTable

61+ , fromMaybeTable

5962 , optional

6063 , catMaybeTable

6164 , traverseMaybeTable

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

7881 , isThisTable, isThatTable, isThoseTable

7982 , hasHereTable, hasThereTable

8083 , justHereTable, justThereTable

84+ , alignMaybeTable

8185 , alignBy

8286 , keepHereTable, loseHereTable

8387 , keepThereTable, loseThereTable

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

9094

9195 -- ** @ListTable@

9296 , ListTable

93− , listTable

97+ , listTable, ($*)

9498 , nameListTable

9599 , many

96100 , manyExpr

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

99103

100104 -- ** @NonEmptyTable@

101105 , NonEmptyTable

102− , nonEmptyTable

106+ , nonEmptyTable, ($+)

103107 , nameNonEmptyTable

104108 , some

105109 , someExpr

106110 , catNonEmptyTable

107111 , catNonEmpty

108112

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

110127 , ADT, ADTable

128+

129+ -- *** Deconstruction of ADTs

130+ -- $deconstruction

131+ , DeconstructADT, deconstructADT

132+

133+ -- *** Construction of ADTs

134+ -- $construction

111135 , BuildADT, buildADT

112136 , ConstructADT, constructADT

113− , DeconstructADT, deconstructADT

114− , NameADT, nameADT

137+

138+ -- *** Other ADT operations

115139 , AggregateADT, aggregateADT

116140

141+ -- *** Miscellaneous notes

142+ -- $misc-notes

143+

117144 -- ** @HKD@

118145 , HKD, HKDable

119146 , BuildHKD, buildHKD

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

138165 -- ** @null@

139166 , NotNull

140167 , Nullable

168+ , Homonullable

141169 , null

142170 , nullify

143171 , nullable

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

156184 , (==.), (/=.), (==?), (/=?)

157185 , in_

158186 , boolExpr, caseExpr

187+ , like, ilike

159188

160189 -- ** Ordering

161190 , DBOrd

@@ -173,6 +202,13 @@ module Rel8

173202 , Query

174203 , showQuery

175204

205+ -- ** Projection

206+ , Projection

207+ , Projectable( project )

208+ , Biprojectable( biproject )

209+ , Projecting

210+ , Field

211+

176212 -- ** Selecting rows

177213 , Selects

178214 , each

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

217253 , countRows

218254 , groupBy

219255 , listAgg, listAggExpr

256+ , mode

220257 , nonEmptyAgg, nonEmptyAggExpr

221258 , DBMax, max

222259 , DBMin, min

223− , DBSum, sum, sumWhere

260+ , DBSum, sum, sumWhere, avg

224261 , DBString, stringAgg

225262 , count

226263 , countStar

@@ -237,6 +274,32 @@ module Rel8

237274 , nullsFirst

238275 , nullsLast

239276

277+ -- ** Window functions

278+ , Window

279+ , window

280+ , Partition

281+ , over

282+ , partitionBy

283+ , orderPartitionBy

284+ , cumulative

285+ , cumulative_

286+ , currentRow

287+ , rowNumber

288+ , rank

289+ , denseRank

290+ , percentRank

291+ , cumeDist

292+ , ntile

293+ , lag

294+ , lead

295+ , firstValue

296+ , lastValue

297+ , nthValue

298+ , indexed

299+

300+ -- ** Bindings

301+ , rebind

302+

240303 -- * IO

241304 , Serializable

242305 , ToExprs

@@ -251,22 +314,27 @@ module Rel8

251314 -- ** @INSERT@

252315 , Insert(..)

253316 , OnConflict(..)

317+ , Upsert(..)

254318 , insert

255319 , unsafeDefault

320+ , showInsert

256321

257322 -- ** @DELETE@

258323 , Delete(..)

259324 , delete

325+ , showDelete

260326

261327 -- ** @UPDATE@

262328 , Update(..)

263329 , update

330+ , showUpdate

264331

265332 -- ** @.. RETURNING@

266333 , Returning(..)

267334

268335 -- ** @CREATE VIEW@

269336 , createView

337+ , createOrReplaceView

270338

271339 -- ** Sequences

272340 , nextval

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

285353import Rel8.Column.List

286354import Rel8.Column.Maybe

287355import Rel8.Column.NonEmpty

356+import Rel8.Column.Null

288357import Rel8.Column.These

289358import Rel8.Expr

290359import Rel8.Expr.Aggregate

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

298367import Rel8.Expr.Order

299368import Rel8.Expr.Serialize

300369import Rel8.Expr.Sequence

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

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

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

302373import Rel8.Order

303374import Rel8.Query

@@ -308,15 +379,19 @@ import Rel8.Query.Either

308379import Rel8.Query.Evaluate

309380import Rel8.Query.Exists

310381import Rel8.Query.Filter

382+import Rel8.Query.Indexed

311383import Rel8.Query.Limit

312384import Rel8.Query.List

313385import Rel8.Query.Maybe

314386import Rel8.Query.Null

315387import Rel8.Query.Order

388+import Rel8.Query.Rebind

316389import Rel8.Query.SQL (showQuery)

317390import Rel8.Query.Set

318391import Rel8.Query.These

319392import Rel8.Query.Values

393+import Rel8.Query.Window

394+import Rel8.Schema.Field

320395import Rel8.Schema.HTable

321396import Rel8.Schema.Name

322397import Rel8.Schema.Null hiding ( nullable )

@@ -324,8 +399,10 @@ import Rel8.Schema.Result ( Result )

324399import Rel8.Schema.Table

325400import Rel8.Statement.Delete

326401import Rel8.Statement.Insert

402+import Rel8.Statement.OnConflict

327403import Rel8.Statement.Returning

328404import Rel8.Statement.Select

405+import Rel8.Statement.SQL

329406import Rel8.Statement.Update

330407import Rel8.Statement.View

331408import Rel8.Table

@@ -340,12 +417,16 @@ import Rel8.Table.List

340417import Rel8.Table.Maybe

341418import Rel8.Table.Name

342419import Rel8.Table.NonEmpty

420+import Rel8.Table.Null

421+import Rel8.Table.Opaleye ( castTable )

343422import Rel8.Table.Ord

344423import Rel8.Table.Order

345−import Rel8.Table.Recontextualize

424+import Rel8.Table.Projection

346425import Rel8.Table.Rel8able ()

347426import Rel8.Table.Serialize

348427import Rel8.Table.These

428+import Rel8.Table.Transpose

429+import Rel8.Table.Window

349430import Rel8.Type

350431import Rel8.Type.Composite

351432import Rel8.Type.Eq

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

360441import Rel8.Type.Semigroup

361442import Rel8.Type.String

362443import Rel8.Type.Sum

444+import Rel8.Window

363445

364446

365447-- $running

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

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

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

369451-- `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+35−90

@@ -1,138 +1,83 @@

11{-# language DataKinds #-}

22{-# language FlexibleContexts #-}

33{-# language FlexibleInstances #-}

4−{-# language GADTs #-}

54{-# language MultiParamTypeClasses #-}

6−{-# language NamedFieldPuns #-}

7−{-# language PolyKinds #-}

5+{-# language RankNTypes #-}

86{-# language StandaloneKindSignatures #-}

97{-# language TypeFamilies #-}

108{-# language UndecidableInstances #-}

11−{-# language UndecidableSuperClasses #-}

129

1310module Rel8.Aggregate

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

15− , Aggregator(..), unsafeMakeAggregate

11+ ( Aggregate(..), zipOutputs

12+ , unsafeMakeAggregate

1613 , Aggregates

17− , Col( A, unA )

1814 )

1915where

2016

2117-- base

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

18+import Control.Applicative ( liftA2 )

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

2320import Data.Kind ( Constraint, Type )

2421import Prelude

2522

23+-- profunctors

24+import Data.Profunctor ( dimap )

25+

2626-- opaleye

27−import qualified Opaleye.Internal.Aggregate as Opaleye

27+import qualified Opaleye.Aggregate as Opaleye

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

29−import qualified Opaleye.Internal.PackMap as Opaleye

29+import qualified Opaleye.Internal.Column as Opaleye

3030

3131-- rel8

3232import Rel8.Expr ( Expr )

33−import Rel8.Schema.Context ( Interpretation(..) )

34−import Rel8.Schema.HTable.Identity ( HIdentity(..), HType )

35−import Rel8.Schema.Name ( Name )

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

34+import qualified Rel8.Schema.Kind as K

3635import Rel8.Schema.Null ( Sql )

37−import Rel8.Schema.Result ( Col( R ) )

38−import Rel8.Schema.Spec ( Spec( Spec ) )

3936import Rel8.Table

4037 ( Table, Columns, Context, fromColumns, toColumns

4138 , FromExprs, fromResult, toResult

39+ , Transpose

4240 )

43−import Rel8.Table.Recontextualize ( Recontextualize )

41+import Rel8.Table.Transpose ( Transposes )

4442import Rel8.Type ( DBType )

4543

4644

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

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

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

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

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

52−type Aggregate :: k -> Type

53−data Aggregate a where

54− Aggregate :: !(Opaleye.Aggregator () (Expr a)) -> Aggregate a

55−

56−

57−instance Interpretation Aggregate where

58− data Col Aggregate _spec where

59− A :: ()

60− => { unA :: !(Aggregate a) }

61− -> Col Aggregate ('Spec a)

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

46+type Aggregate :: K.Context

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

6248

6349

6450instance Sql DBType a => Table Aggregate (Aggregate a) where

65− type Columns (Aggregate a) = HType a

51+ type Columns (Aggregate a) = HIdentity a

6652 type Context (Aggregate a) = Aggregate

6753 type FromExprs (Aggregate a) = a

54+ type Transpose to (Aggregate a) = to a

6855

69− toColumns = HIdentity . A

70− fromColumns (HIdentity (A a)) = a

71− toResult = HIdentity . R

72− fromResult (HIdentity (R a)) = a

73−

74−

75−instance Sql DBType a =>

76− Recontextualize Aggregate Aggregate (Aggregate a) (Aggregate a)

77−

78−

79−instance Sql DBType a =>

80− Recontextualize Aggregate Expr (Aggregate a) (Expr a)

81−

82−

83−instance Sql DBType a =>

84− Recontextualize Aggregate Name (Aggregate a) (Name a)

56+ toColumns = HIdentity

57+ fromColumns (HIdentity a) = a

58+ toResult = HIdentity . Identity

59+ fromResult (HIdentity (Identity a)) = a

8560

8661

87−instance Sql DBType a =>

88− Recontextualize Expr Aggregate (Expr a) (Aggregate a)

89−

90−

91−instance Sql DBType a =>

92− Recontextualize Name Aggregate (Name a) (Aggregate a)

93−

94−

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

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

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

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

9764type Aggregates :: Type -> Type -> Constraint

98−class Recontextualize Aggregate Expr aggregates exprs => Aggregates aggregates exprs

99−instance Recontextualize Aggregate Expr aggregates exprs => Aggregates aggregates exprs

100−

101−

102−foldInputs :: Monoid b

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

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

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

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

107− where

108− detuplize (operation, ordering, distinction) =

109− Aggregator {operation, ordering, distinction}

110−

111−

112−mapInputs :: ()

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

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

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

116− f (fmap transform input)

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

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

11767

11868

119−type Aggregator :: Type

120−data Aggregator = Aggregator

121− { operation :: Opaleye.AggrOp

122− , ordering :: [Opaleye.OrderExpr]

123− , distinction :: Opaleye.AggrDistinct

124− }

69+zipOutputs :: ()

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

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

12572

12673

127−unsafeMakeAggregate :: ()

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

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

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

130− -> Maybe Aggregator

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

13178 -> Expr input

13279 -> Aggregate output

13380unsafeMakeAggregate input output aggregator expr =

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

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

136− where

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

138− (operation, ordering, distinction)

81+ Aggregate $ dimap in_ out aggregator

82+ where out = output . Opaleye.unColumn

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

src/Rel8/Column.hs+2−7

@@ -13,11 +13,8 @@ import Data.Kind ( Type )

1313import Prelude ()

1414

1515-- rel8

16−import Rel8.Aggregate ( Aggregate )

17−import Rel8.Expr ( Expr )

1816import Rel8.FCF ( Eval, Exp )

1917import qualified Rel8.Schema.Kind as K

20−import Rel8.Schema.Name ( Name(..) )

2118import Rel8.Schema.Result ( Result )

2219

2320

@@ -26,10 +23,8 @@ import Rel8.Schema.Result ( Result )

2623-- 'Rel8able' definitions), and @a@ is the type of the column.

2724type Column :: K.Context -> Type -> Type

2825type family Column context a where

29− Column Aggregate a = Aggregate a

30− Column Expr a = Expr a

31− Column Name a = Name a

32− Column Result a = a

26+ Column Result a = a

27+ Column context a = context a

3328

3429

3530data TColumn :: K.Context -> Type -> Exp Type

src/Rel8/Column/Either.hs+1−6

@@ -12,10 +12,7 @@ import Data.Kind ( Type )

1212import Prelude

1313

1414-- rel8

15−import Rel8.Aggregate ( Aggregate )

16−import Rel8.Expr ( Expr )

1715import qualified Rel8.Schema.Kind as K

18−import Rel8.Schema.Name ( Name )

1916import Rel8.Schema.Result ( Result )

2017import Rel8.Table.Either ( EitherTable )

2118

@@ -25,7 +22,5 @@ import Rel8.Table.Either ( EitherTable )

2522-- 'Result' context.

2623type HEither :: K.Context -> Type -> Type -> Type

2724type family HEither context = either | either -> context where

28− HEither Aggregate = EitherTable Aggregate

29− HEither Expr = EitherTable Expr

30− HEither Name = EitherTable Name

3125 HEither Result = Either

26+ HEither context = EitherTable context

src/Rel8/Column/List.hs+1−6

@@ -12,10 +12,7 @@ import Data.Kind ( Type )

1212import Prelude ()

1313

1414-- rel8

15−import Rel8.Aggregate ( Aggregate )

16−import Rel8.Expr ( Expr )

1715import qualified Rel8.Schema.Kind as K

18−import Rel8.Schema.Name ( Name )

1916import Rel8.Schema.Result ( Result )

2017import Rel8.Table.List ( ListTable )

2118

@@ -24,7 +21,5 @@ import Rel8.Table.List ( ListTable )

2421-- @a@ in the 'Expr' context, and a @[a]@ in the 'Result' context.

2522type HList :: K.Context -> Type -> Type

2623type family HList context = list | list -> context where

27− HList Aggregate = ListTable Aggregate

28− HList Expr = ListTable Expr

29− HList Name = ListTable Name

3024 HList Result = []

25+ HList context = ListTable context

src/Rel8/Column/Maybe.hs+1−6

@@ -12,10 +12,7 @@ import Data.Kind ( Type )

1212import Prelude

1313

1414-- rel8

15−import Rel8.Aggregate ( Aggregate )

16−import Rel8.Expr ( Expr )

1715import qualified Rel8.Schema.Kind as K

18−import Rel8.Schema.Name ( Name )

1916import Rel8.Schema.Result ( Result )

2017import Rel8.Table.Maybe ( MaybeTable )

2118

@@ -25,7 +22,5 @@ import Rel8.Table.Maybe ( MaybeTable )

2522-- context.

2623type HMaybe :: K.Context -> Type -> Type

2724type family HMaybe context = maybe | maybe -> context where

28− HMaybe Aggregate = MaybeTable Aggregate

29− HMaybe Expr = MaybeTable Expr

30− HMaybe Name = MaybeTable Name

3125 HMaybe Result = Maybe

26+ HMaybe context = MaybeTable context

src/Rel8/Column/NonEmpty.hs+1−6

@@ -13,10 +13,7 @@ import Data.List.NonEmpty ( NonEmpty )

1313import Prelude ()

1414

1515-- rel8

16−import Rel8.Aggregate ( Aggregate )

17−import Rel8.Expr ( Expr )

1816import qualified Rel8.Schema.Kind as K

19−import Rel8.Schema.Name ( Name )

2017import Rel8.Schema.Result ( Result )

2118import Rel8.Table.NonEmpty ( NonEmptyTable )

2219

@@ -26,7 +23,5 @@ import Rel8.Table.NonEmpty ( NonEmptyTable )

2623-- 'Result' context.

2724type HNonEmpty :: K.Context -> Type -> Type

2825type family HNonEmpty context = nonEmpty | nonEmpty -> context where

29− HNonEmpty Aggregate = NonEmptyTable Aggregate

30− HNonEmpty Expr = NonEmptyTable Expr

31− HNonEmpty Name = NonEmptyTable Name

3226 HNonEmpty Result = NonEmpty

27+ HNonEmpty context = NonEmptyTable context

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

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

1+{-# language DataKinds #-}

2+{-# language StandaloneKindSignatures #-}

3+{-# language TypeFamilyDependencies #-}

5+module Rel8.Column.Null

6+ ( HNull

7+ )

8+where

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/Column/These.hs+1−6

@@ -12,10 +12,7 @@ import Data.Kind ( Type )

1212import Prelude ()

1313

1414-- rel8

15−import Rel8.Aggregate ( Aggregate )

16−import Rel8.Expr ( Expr )

1715import qualified Rel8.Schema.Kind as K

18−import Rel8.Schema.Name ( Name )

1916import Rel8.Schema.Result ( Result )

2017import Rel8.Table.These ( TheseTable )

2118

@@ -28,7 +25,5 @@ import Data.These ( These )

2825-- 'Result' context.

2926type HThese :: K.Context -> Type -> Type -> Type

3027type family HThese context = these | these -> context where

31− HThese Aggregate = TheseTable Aggregate

32− HThese Expr = TheseTable Expr

33− HThese Name = TheseTable Name

3428 HThese Result = These

29+ HThese context = TheseTable context

src/Rel8/Expr.hs+14−32

@@ -1,26 +1,21 @@

11{-# language DataKinds #-}

22{-# language DerivingStrategies #-}

3+{-# language FlexibleContexts #-}

34{-# language FlexibleInstances #-}

4−{-# language GADTs #-}

55{-# language MultiParamTypeClasses #-}

6−{-# language PolyKinds #-}

7−{-# language RoleAnnotations #-}

86{-# language ScopedTypeVariables #-}

9−{-# language StandaloneDeriving #-}

107{-# language StandaloneKindSignatures #-}

118{-# language TypeApplications #-}

129{-# language TypeFamilies #-}

1310{-# language UndecidableInstances #-}

14−{-# language UndecidableSuperClasses #-}

1511

1612module Rel8.Expr

1713 ( Expr(..)

18− , Col( E, unE )

1914 )

2015where

2116

2217-- base

23−import Data.Kind ( Type )

18+import Data.Functor.Identity ( Identity( Identity ) )

2419import Data.String ( IsString, fromString )

2520import Prelude hiding ( null )

2621

@@ -37,16 +32,14 @@ import Rel8.Expr.Opaleye

3732 , zipPrimExprsWith

3833 )

3934import Rel8.Expr.Serialize ( litExpr )

40−import Rel8.Schema.Context ( Interpretation, Col )

41−import Rel8.Schema.HTable.Identity ( HIdentity( HType ), HType )

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

36+import qualified Rel8.Schema.Kind as K

4237import Rel8.Schema.Null ( Nullity( Null, NotNull ), Sql, nullable )

43−import Rel8.Schema.Result ( Col( R ) )

44−import Rel8.Schema.Spec ( Spec( Spec ) )

4538import Rel8.Table

4639 ( Table, Columns, Context, fromColumns, toColumns

4740 , FromExprs, fromResult, toResult

41+ , Transpose

4842 )

49−import Rel8.Table.Recontextualize ( Recontextualize )

5043import Rel8.Type ( DBType )

5144import Rel8.Type.Monoid ( DBMonoid, memptyExpr )

5245import Rel8.Type.Num ( DBFloating, DBFractional, DBNum )

@@ -54,13 +47,9 @@ import Rel8.Type.Semigroup ( DBSemigroup, (<>.) )

5447

5548

5649-- | Typed SQL expressions.

57−type role Expr representational

58−type Expr :: k -> Type

59−data Expr a where

60− Expr :: k ~ Type => !Opaleye.PrimExpr -> Expr (a :: k)

61−

62−

63−deriving stock instance Show (Expr a)

50+type Expr :: K.Context

51+newtype Expr a = Expr Opaleye.PrimExpr

52+ deriving stock Show

6453

6554

6655instance Sql DBSemigroup a => Semigroup (Expr a) where

@@ -124,20 +113,13 @@ instance Sql DBFloating a => Floating (Expr a) where

124113 atanh = function "atanh"

125114

126115

127−instance Interpretation Expr where

128− data Col Expr _spec where

129− E :: {unE :: !(Expr a)} -> Col Expr ('Spec a)

130−

131−

132116instance Sql DBType a => Table Expr (Expr a) where

133− type Columns (Expr a) = HType a

117+ type Columns (Expr a) = HIdentity a

134118 type Context (Expr a) = Expr

135119 type FromExprs (Expr a) = a

120+ type Transpose to (Expr a) = to a

136121

137− toColumns a = HType (E a)

138− fromColumns (HType (E a)) = a

139− toResult a = HType (R a)

140− fromResult (HType (R a)) = a

141−

142−

143−instance Sql DBType a => Recontextualize Expr Expr (Expr a) (Expr a)

122+ toColumns a = HIdentity a

123+ fromColumns (HIdentity a) = a

124+ toResult a = HIdentity (Identity a)

125+ fromResult (HIdentity (Identity a)) = a

src/Rel8/Expr.hs-boot+6−8

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

1−{-# language GADTs #-}

2−{-# language PolyKinds #-}

3−{-# language RoleAnnotations #-}

1+{-# language DataKinds #-}

42{-# language StandaloneKindSignatures #-}

64module Rel8.Expr

@@ -9,14 +7,14 @@ module Rel8.Expr

97where

108

119-- base

12−import Data.Kind ( Type )

1310import Prelude ()

1411

1512-- opaleye

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

1714

15+-- rel8

16+import Rel8.Schema.Kind ( Context )

1817

19−type role Expr representational

20−type Expr :: k -> Type

21−data Expr a where

22− Expr :: k ~ Type => !Opaleye.PrimExpr -> Expr (a :: k)

18+

19+type Expr :: Context

20+newtype Expr a = Expr Opaleye.PrimExpr

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

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

1010 , and, or

1111 , min, max

1212 , sum, sumWhere

13+ , avg

1314 , stringAgg

1415 , groupByExpr

1516 , listAggExpr, nonEmptyAggExpr

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

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

2425

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

2730

2831-- rel8

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

32+import Rel8.Aggregate ( Aggregate, unsafeMakeAggregate )

3033import Rel8.Expr ( Expr )

3134import Rel8.Expr.Bool ( caseExpr )

3235import Rel8.Expr.Opaleye

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

5053

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

5255count :: Expr a -> Aggregate Int64

53−count = unsafeMakeAggregate toPrimExpr fromPrimExpr $

54− Just Aggregator

55− { operation = Opaleye.AggrCount

56− , ordering = []

57− , distinction = Opaleye.AggrAll

58− }

59−

56+count = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.count

6057

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

6259-- @COUNT(DISTINCT a)@

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

6461countDistinct = unsafeMakeAggregate toPrimExpr fromPrimExpr $

65− Just Aggregator

66− { operation = Opaleye.AggrCount

67− , ordering = []

68− , distinction = Opaleye.AggrDistinct

69− }

62+ Opaleye.distinctAggregator Opaleye.count

7063

7164

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

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

8174

8275-- | Corresponds to @bool_and@.

8376and :: Expr Bool -> Aggregate Bool

84−and = unsafeMakeAggregate toPrimExpr fromPrimExpr $

85− Just Aggregator

86− { operation = Opaleye.AggrBoolAnd

87− , ordering = []

88− , distinction = Opaleye.AggrAll

89− }

77+and = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.boolAnd

9078

9179

9280-- | Corresponds to @bool_or@.

9381or :: Expr Bool -> Aggregate Bool

94−or = unsafeMakeAggregate toPrimExpr fromPrimExpr $

95− Just Aggregator

96− { operation = Opaleye.AggrBoolOr

97− , ordering = []

98− , distinction = Opaleye.AggrAll

99− }

82+or = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.boolOr

10083

10184

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

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

104−max = unsafeMakeAggregate toPrimExpr fromPrimExpr $

105− Just Aggregator

106− { operation = Opaleye.AggrMax

107− , ordering = []

108− , distinction = Opaleye.AggrAll

109− }

87+max = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.unsafeMax

11088

11189

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

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

114−min = unsafeMakeAggregate toPrimExpr fromPrimExpr $

115− Just Aggregator

116− { operation = Opaleye.AggrMin

117− , ordering = []

118− , distinction = Opaleye.AggrAll

119− }

92+min = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.unsafeMin

12093

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

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

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

12598-- your input.

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

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

128− Just Aggregator

129− { operation = Opaleye.AggrSum

130− , ordering = []

131− , distinction = Opaleye.AggrAll

132− }

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

101+

133102

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

134110

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

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

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

142118stringAgg :: Sql DBString a

143119 => Expr db -> Expr a -> Aggregate a

144120stringAgg delimiter =

145− unsafeMakeAggregate toPrimExpr (castExpr . fromPrimExpr) $

146− Just Aggregator

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

148− , ordering = []

149− , distinction = Opaleye.AggrAll

150− }

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

151122

152123

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

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

155−groupByExpr = unsafeMakeAggregate toPrimExpr fromPrimExpr Nothing

126+groupByExpr = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.groupBy

156127

157128

158129-- | Collect expressions values as a list.

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

167138

168139slistAggExpr :: ()

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

170−slistAggExpr info = unsafeMakeAggregate to fromPrimExpr $ Just

171− Aggregator

172− { operation = Opaleye.AggrArr

173− , ordering = []

174− , distinction = Opaleye.AggrAll

175− }

141+slistAggExpr info = unsafeMakeAggregate to fromPrimExpr Opaleye.arrayAgg

176142 where

177143 to = encodeArrayElement info . toPrimExpr

178144

179145

180146snonEmptyAggExpr :: ()

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

182−snonEmptyAggExpr info = unsafeMakeAggregate to fromPrimExpr $ Just

183− Aggregator

184− { operation = Opaleye.AggrArr

185− , ordering = []

186− , distinction = Opaleye.AggrAll

187− }

148+snonEmptyAggExpr info = unsafeMakeAggregate to fromPrimExpr Opaleye.arrayAgg

188149 where

189150 to = encodeArrayElement info . toPrimExpr

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

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

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

66module Rel8.Expr.Num

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

7+ ( fromIntegral

8+ , realToFrac

9+ , div, mod, divMod

10+ , quot, rem, quotRem

11+ , ceiling, floor, round, truncate

812 )

913where

1014

1115-- base

12−import Prelude ()

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

1317

1418-- rel

1519import Rel8.Expr ( Expr( Expr ) )

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

1621import Rel8.Expr.Function ( function )

1722import Rel8.Expr.Opaleye ( castExpr )

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

24+import Rel8.Table.Bool ( bool )

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

2026

2127

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

4248ceiling = function "ceiling"

4349

4450

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

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

52+-- PostgreSQL.

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

47−div = function "div"

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

4855

4956

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

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

58+-- PostgreSQL.

5159mod :: 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)

5386

5487

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

1010 , scastExpr, sunsafeCastExpr

1111 , unsafeLiteral

1212 , fromPrimExpr, toPrimExpr, mapPrimExpr, zipPrimExprsWith, traversePrimExpr

13− , toColumn, fromColumn

13+ , toColumn, fromColumn, traverseFieldP

1414 )

1515where

1616

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

2727import Rel8.Type ( DBType, typeInformation )

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

2929

30+-- profunctors

31+import Data.Profunctor ( Profunctor, dimap )

32+

3033

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

3235castExpr = scastExpr typeInformation

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

8083traversePrimExpr f = fmap fromPrimExpr . f . toPrimExpr

8184

8285

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

86+traverseFieldP :: Profunctor p

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

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

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

90+

91+

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

8493toColumn = Opaleye.Column

8594

8695

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

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

8897fromColumn (Opaleye.Column a) = a

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

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

1111import Rel8.Expr ( Expr )

1212import Rel8.Expr.Function ( function )

1313import Rel8.Expr.Serialize ( litExpr )

14+import Rel8.Expr.Text ( quoteIdent )

1415

1516-- text

1617import Data.Text ( pack )

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

1819

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

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

1717 , pgClientEncoding, quoteIdent, quoteLiteral, quoteNullable, regexpReplace

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

1919 , splitPart, strpos, substr, translate

20+

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

22+ , like, ilike

2023 )

2124where

2225

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

2427import Data.Bool ( Bool )

2528import Data.Int ( Int32 )

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

27−import Prelude ()

30+import Prelude ( flip )

2831

2932-- bytestring

3033import Data.ByteString ( ByteString )

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

4952

5053

5154-- | Matches regular expression, case sensitive

52−--

55+--

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

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

5558(~.) = binaryOperator "~."

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

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

274277translate :: Expr Text -> Expr Text -> Expr Text -> Expr Text

275278translate = 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.hs+50−50

@@ -29,8 +29,8 @@ import GHC.TypeLits ( Symbol )

2929import Prelude

3030

3131-- rel8

32−import Rel8.Aggregate ( Col( A ), Aggregate( Aggregate ) )

33−import Rel8.Expr ( Col( E ), Expr )

32+import Rel8.Aggregate ( Aggregate( Aggregate ) )

33+import Rel8.Expr ( Expr )

3434import Rel8.Expr.Aggregate ( groupByExpr )

3535import Rel8.Expr.Eq ( (==.) )

3636import Rel8.Expr.Null ( nullify, snull, unsafeUnnullify )

@@ -57,11 +57,11 @@ import Rel8.Kind.Algebra

5757import qualified Rel8.Kind.Algebra as K

5858import Rel8.Schema.Context.Nullify ( sguard, snullify )

5959import Rel8.Schema.HTable ( HTable )

60−import Rel8.Schema.HTable.Identity ( HIdentity( HType ) )

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

6161import qualified Rel8.Schema.Kind as K

62−import Rel8.Schema.Name ( Col( N ), Name( Name ) )

62+import Rel8.Schema.Name ( Name( Name ) )

6363import Rel8.Schema.Null ( Nullity( Null, NotNull ) )

64−import Rel8.Schema.Spec ( SSpec( SSpec, nullity, info ) )

64+import Rel8.Schema.Spec ( Spec( Spec, nullity, info ) )

6565import Rel8.Table

6666 ( TTable, TColumns

6767 , Table, fromColumns, toColumns

@@ -86,11 +86,11 @@ type family GGBuildable' algebra name rep where

8686 GGBuildable' 'K.Product name rep =

8787 ( name ~ GConstructor (Eval (rep Expr))

8888 , Representable Id (Eval (rep Expr))

89− , GConstructable (TTable Expr) TColumns Id (Col Expr) (Eval (rep Expr))

89+ , GConstructable (TTable Expr) TColumns Id Expr (Eval (rep Expr))

9090 )

9191 GGBuildable' 'K.Sum name rep =

9292 ( Representable Id (GConstructorADT name (Eval (rep Expr)))

93− , GMakeableADT (TTable Expr) TColumns Id (Col Expr) name (Eval (rep Expr))

93+ , GMakeableADT (TTable Expr) TColumns Id Expr name (Eval (rep Expr))

9494 )

9595

9696

@@ -103,7 +103,7 @@ type family GGBuild algebra name rep r where

103103

104104

105105ggbuild :: forall algebra name rep a. GGBuildable algebra name rep

106− => (Eval (GGColumns algebra TColumns (Eval (rep Expr))) (Col Expr) -> a)

106+ => (Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr -> a)

107107 -> GGBuild algebra name rep a

108108ggbuild gfromColumns = case algebraSing @algebra of

109109 SProduct ->

@@ -113,7 +113,7 @@ ggbuild gfromColumns = case algebraSing @algebra of

113113 @(TTable Expr)

114114 @TColumns

115115 @Id

116− @(Col Expr)

116+ @Expr

117117 @(Eval (rep Expr))

118118 (const toColumns)

119119 SSum ->

@@ -123,15 +123,15 @@ ggbuild gfromColumns = case algebraSing @algebra of

123123 @(TTable Expr)

124124 @TColumns

125125 @Id

126− @(Col Expr)

126+ @Expr

127127 @name

128128 @(Eval (rep Expr))

129129 (const toColumns)

130− (\SSpec {info} -> E (snull info))

131− (\SSpec {nullity} -> case nullity of

130+ (\Spec {info} -> snull info)

131+ (\Spec {nullity} -> case nullity of

132132 Null -> id

133− NotNull -> \(E a) -> E (nullify a))

134− (HType . E . litExpr)

133+ NotNull -> nullify)

134+ (HIdentity . litExpr)

135135

136136

137137type GGConstructable :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Constraint

@@ -151,9 +151,9 @@ type family GGConstructable' algebra rep where

151151 ( Representable Id (Eval (rep Aggregate))

152152 , Representable Id (Eval (rep Expr))

153153 , Representable Id (Eval (rep Name))

154− , GConstructable (TTable Aggregate) TColumns Id (Col Aggregate) (Eval (rep Aggregate))

155− , GConstructable (TTable Expr) TColumns Id (Col Expr) (Eval (rep Expr))

156− , GConstructable (TTable Name) TColumns Id (Col Name) (Eval (rep Name))

154+ , GConstructable (TTable Aggregate) TColumns Id Aggregate (Eval (rep Aggregate))

155+ , GConstructable (TTable Expr) TColumns Id Expr (Eval (rep Expr))

156+ , GConstructable (TTable Name) TColumns Id Name (Eval (rep Name))

157157 )

158158 GGConstructable' 'K.Sum rep =

159159 ( RepresentableConstructors Id (Eval (rep Expr))

@@ -161,9 +161,9 @@ type family GGConstructable' algebra rep where

161161 , RepresentableFields Id (Eval (rep Expr))

162162 , RepresentableFields Id (Eval (rep Name))

163163 , Functor (GConstructors Id (Eval (rep Expr)))

164− , GConstructableADT (TTable Aggregate) TColumns Id (Col Aggregate) (Eval (rep Aggregate))

165− , GConstructableADT (TTable Expr) TColumns Id (Col Expr) (Eval (rep Expr))

166− , GConstructableADT (TTable Name) TColumns Id (Col Name) (Eval (rep Name))

164+ , GConstructableADT (TTable Aggregate) TColumns Id Aggregate (Eval (rep Aggregate))

165+ , GConstructableADT (TTable Expr) TColumns Id Expr (Eval (rep Expr))

166+ , GConstructableADT (TTable Name) TColumns Id Name (Eval (rep Name))

167167 )

168168

169169

@@ -174,7 +174,7 @@ type family GGConstruct algebra rep r where

174174

175175

176176ggconstruct :: forall algebra rep a. GGConstructable algebra rep

177− => (Eval (GGColumns algebra TColumns (Eval (rep Expr))) (Col Expr) -> a)

177+ => (Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr -> a)

178178 -> GGConstruct algebra rep a -> a

179179ggconstruct gfromColumns f = case algebraSing @algebra of

180180 SProduct ->

@@ -185,7 +185,7 @@ ggconstruct gfromColumns f = case algebraSing @algebra of

185185 @(TTable Expr)

186186 @TColumns

187187 @Id

188− @(Col Expr)

188+ @Expr

189189 @(Eval (rep Expr))

190190 (const toColumns)

191191 SSum ->

@@ -195,14 +195,14 @@ ggconstruct gfromColumns f = case algebraSing @algebra of

195195 @(TTable Expr)

196196 @TColumns

197197 @Id

198− @(Col Expr)

198+ @Expr

199199 @(Eval (rep Expr))

200200 (const toColumns)

201− (\SSpec {info} -> E (snull info))

202− (\SSpec {nullity} -> case nullity of

201+ (\Spec {info} -> snull info)

202+ (\Spec {nullity} -> case nullity of

203203 Null -> id

204− NotNull -> \(E a) -> E (nullify a))

205− (HType . E . litExpr)

204+ NotNull -> nullify)

205+ (HIdentity . litExpr)

206206

207207

208208type GGDeconstruct :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Type -> Type -> Type

@@ -214,7 +214,7 @@ type family GGDeconstruct algebra rep a r where

214214

215215

216216ggdeconstruct :: forall algebra rep a r. (GGConstructable algebra rep, Table Expr r)

217− => (a -> Eval (GGColumns algebra TColumns (Eval (rep Expr))) (Col Expr))

217+ => (a -> Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr)

218218 -> GGDeconstruct algebra rep a r

219219ggdeconstruct gtoColumns = case algebraSing @algebra of

220220 SProduct -> \build ->

@@ -223,24 +223,24 @@ ggdeconstruct gtoColumns = case algebraSing @algebra of

223223 @(TTable Expr)

224224 @TColumns

225225 @Id

226− @(Col Expr)

226+ @Expr

227227 @(Eval (rep Expr))

228228 (const fromColumns) .

229229 gtoColumns

230230 SSum ->

231231 gctabulate @Id @(Eval (rep Expr)) @r @(a -> r) $ \constructors as ->

232232 let

233− (HType (E tag), cases) =

233+ (HIdentity tag, cases) =

234234 gdeconstructADT

235235 @(TTable Expr)

236236 @TColumns

237237 @Id

238− @(Col Expr)

238+ @Expr

239239 @(Eval (rep Expr))

240240 (const fromColumns)

241− (\SSpec {nullity} -> case nullity of

241+ (\Spec {nullity} -> case nullity of

242242 Null -> id

243− NotNull -> \(E a) -> E (unsafeUnnullify a))

243+ NotNull -> unsafeUnnullify)

244244 constructors $

245245 gtoColumns as

246246 in

@@ -256,7 +256,7 @@ type family GGName algebra rep a where

256256

257257

258258ggname :: forall algebra rep a. GGConstructable algebra rep

259− => (Eval (GGColumns algebra TColumns (Eval (rep Expr))) (Col Name) -> a)

259+ => (Eval (GGColumns algebra TColumns (Eval (rep Expr))) Name -> a)

260260 -> GGName algebra rep a

261261ggname gfromColumns = case algebraSing @algebra of

262262 SProduct ->

@@ -266,7 +266,7 @@ ggname gfromColumns = case algebraSing @algebra of

266266 @(TTable Name)

267267 @TColumns

268268 @Id

269− @(Col Name)

269+ @Name

270270 @(Eval (rep Name))

271271 (const toColumns)

272272 SSum -> \tag ->

@@ -276,11 +276,11 @@ ggname gfromColumns = case algebraSing @algebra of

276276 @(TTable Name)

277277 @TColumns

278278 @Id

279− @(Col Name)

279+ @Name

280280 @(Eval (rep Name))

281281 (const toColumns)

282− (\_ _ (N (Name a)) -> N (Name a))

283− (HType (N tag))

282+ (\_ _ (Name a) -> Name a)

283+ (HIdentity tag)

284284

285285

286286type GGAggregate :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Type -> Type

@@ -294,8 +294,8 @@ type family GGAggregate algebra rep r where

294294

295295

296296ggaggregate :: forall algebra rep exprs agg. GGConstructable algebra rep

297− => (Eval (GGColumns algebra TColumns (Eval (rep Expr))) (Col Aggregate) -> agg)

298− -> (exprs -> Eval (GGColumns algebra TColumns (Eval (rep Expr))) (Col Expr))

297+ => (Eval (GGColumns algebra TColumns (Eval (rep Expr))) Aggregate -> agg)

298+ -> (exprs -> Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr)

299299 -> GGAggregate algebra rep agg -> exprs -> agg

300300ggaggregate gfromColumns gtoColumns agg es = case algebraSing @algebra of

301301 SProduct -> flip f exprs $

@@ -304,7 +304,7 @@ ggaggregate gfromColumns gtoColumns agg es = case algebraSing @algebra of

304304 @(TTable Aggregate)

305305 @TColumns

306306 @Id

307− @(Col Aggregate)

307+ @Aggregate

308308 @(Eval (rep Aggregate))

309309 (const toColumns)

310310 where

@@ -317,7 +317,7 @@ ggaggregate gfromColumns gtoColumns agg es = case algebraSing @algebra of

317317 @(TTable Expr)

318318 @TColumns

319319 @Id

320− @(Col Expr)

320+ @Expr

321321 @(Eval (rep Expr))

322322 (const fromColumns) $

323323 gtoColumns es

@@ -327,26 +327,26 @@ ggaggregate gfromColumns gtoColumns agg es = case algebraSing @algebra of

327327 @(TTable Aggregate)

328328 @TColumns

329329 @Id

330− @(Col Aggregate)

330+ @Aggregate

331331 @(Eval (rep Aggregate))

332332 (const toColumns)

333− (\tag' SSpec {nullity} (A (Aggregate a)) ->

334− A $ Aggregate $ sguard (tag ==. litExpr tag') . snullify nullity <$> a)

335− (HType (A (groupByExpr tag)))

333+ (\tag' Spec {nullity} (Aggregate a) ->

334+ Aggregate $ sguard (tag ==. litExpr tag') . snullify nullity <$> a)

335+ (HIdentity (groupByExpr tag))

336336 where

337337 f =

338338 gfindex @Id @(Eval (rep Expr)) @agg .

339339 agg .

340340 gftabulate @Id @(Eval (rep Aggregate)) @agg

341− (HType (E tag), exprs) =

341+ (HIdentity tag, exprs) =

342342 gunbuildADT

343343 @(TTable Expr)

344344 @TColumns

345345 @Id

346− @(Col Expr)

346+ @Expr

347347 @(Eval (rep Expr))

348348 (const fromColumns)

349− (\SSpec {nullity} -> case nullity of

349+ (\Spec {nullity} -> case nullity of

350350 Null -> id

351− NotNull -> \(E a) -> E (unsafeUnnullify a)) $

351+ NotNull -> unsafeUnnullify) $

352352 gtoColumns es

src/Rel8/Generic/Construction/ADT.hs+20−27

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

11{-# language AllowAmbiguousTypes #-}

22{-# language BlockArguments #-}

33{-# language DataKinds #-}

4+{-# language FlexibleContexts #-}

45{-# language FlexibleInstances #-}

56{-# language MultiParamTypeClasses #-}

67{-# language RankNTypes #-}

@@ -49,12 +50,12 @@ import Rel8.Generic.Construction.Record

4950import Rel8.Generic.Table.ADT ( GColumnsADT, GColumnsADT' )

5051import Rel8.Generic.Table.Record ( GColumns )

5152import Rel8.Schema.HTable ( HTable )

52−import Rel8.Schema.HTable.Identity ( HType )

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

5354import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )

5455import Rel8.Schema.HTable.Nullify ( HNullify, hnulls, hnullify, hunnullify )

5556import Rel8.Schema.HTable.Product ( HProduct( HProduct ) )

5657import Rel8.Schema.Null ( Nullify )

57−import Rel8.Schema.Spec ( Spec( Spec ), SSpec )

58+import Rel8.Schema.Spec ( Spec )

5859import qualified Rel8.Schema.Kind as K

5960import Rel8.Type.Tag ( Tag( Tag ) )

6061

@@ -62,24 +63,16 @@ import Rel8.Type.Tag ( Tag( Tag ) )

6263import Data.Text ( pack )

6364

6465

65−type Null :: K.HContext -> Type

66−type Null context = forall a. ()

67− => SSpec ('Spec a)

68− -> context ('Spec (Nullify a))

66+type Null :: K.Context -> Type

67+type Null context = forall a. Spec a -> context (Nullify a)

6968

7069

71−type Nullifier :: K.HContext -> Type

72−type Nullifier context = forall a. ()

73− => SSpec ('Spec a)

74− -> context ('Spec a)

75− -> context ('Spec (Nullify a))

70+type Nullifier :: K.Context -> Type

71+type Nullifier context = forall a. Spec a -> context a -> context (Nullify a)

7672

7773

78−type Unnullifier :: K.HContext -> Type

79−type Unnullifier context = forall a. ()

80− => SSpec ('Spec a)

81− -> context ('Spec (Nullify a))

82− -> context ('Spec a)

74+type Unnullifier :: K.Context -> Type

75+type Unnullifier context = forall a. Spec a -> context (Nullify a) -> context a

8376

8477

8578type NoConstructor :: Symbol -> Symbol -> ErrorMessage

@@ -188,12 +181,12 @@ type GConstructableADT

188181 :: (Type -> Exp Constraint)

189182 -> (Type -> Exp K.HTable)

190183 -> (Type -> Exp Type)

191− -> K.HContext -> (Type -> Type) -> Constraint

184+ -> K.Context -> (Type -> Type) -> Constraint

192185class GConstructableADT _Table _Columns f context rep where

193186 gbuildADT :: ()

194187 => ToColumns _Table _Columns f context

195188 -> (Tag -> Nullifier context)

196− -> HType Tag context

189+ -> HIdentity Tag context

197190 -> GFieldsADT f rep

198191 -> GColumnsADT _Columns rep context

199192

@@ -201,13 +194,13 @@ class GConstructableADT _Table _Columns f context rep where

201194 => FromColumns _Table _Columns f context

202195 -> Unnullifier context

203196 -> GColumnsADT _Columns rep context

204− -> (HType Tag context, GFieldsADT f rep)

197+ -> (HIdentity Tag context, GFieldsADT f rep)

205198

206199 gconstructADT :: ()

207200 => ToColumns _Table _Columns f context

208201 -> Null context

209202 -> Nullifier context

210− -> (Tag -> HType Tag context)

203+ -> (Tag -> HIdentity Tag context)

211204 -> GConstructors f rep (GColumnsADT _Columns rep context)

212205

213206 gdeconstructADT :: ()

@@ -215,11 +208,11 @@ class GConstructableADT _Table _Columns f context rep where

215208 -> Unnullifier context

216209 -> GConstructors f rep r

217210 -> GColumnsADT _Columns rep context

218− -> (HType Tag context, NonEmpty (Tag, r))

211+ -> (HIdentity Tag context, NonEmpty (Tag, r))

219212

220213

221214instance

222− ( htable ~ HLabel "tag" (HType Tag)

215+ ( htable ~ HLabel "tag" (HIdentity Tag)

223216 , GConstructableADT' _Table _Columns f context htable rep

224217 )

225218 => GConstructableADT _Table _Columns f context (M1 D meta rep)

@@ -245,7 +238,7 @@ type GConstructableADT'

245238 :: (Type -> Exp Constraint)

246239 -> (Type -> Exp K.HTable)

247240 -> (Type -> Exp Type)

248− -> K.HContext -> K.HTable -> (Type -> Type) -> Constraint

241+ -> K.Context -> K.HTable -> (Type -> Type) -> Constraint

249242class GConstructableADT' _Table _Columns f context htable rep where

250243 gbuildADT' :: ()

251244 => ToColumns _Table _Columns f context

@@ -383,19 +376,19 @@ type GMakeableADT

383376 :: (Type -> Exp Constraint)

384377 -> (Type -> Exp K.HTable)

385378 -> (Type -> Exp Type)

386− -> K.HContext -> Symbol -> (Type -> Type) -> Constraint

379+ -> K.Context -> Symbol -> (Type -> Type) -> Constraint

387380class GMakeableADT _Table _Columns f context name rep where

388381 gmakeADT :: ()

389382 => ToColumns _Table _Columns f context

390383 -> Null context

391384 -> Nullifier context

392− -> (Tag -> HType Tag context)

385+ -> (Tag -> HIdentity Tag context)

393386 -> GFields f (GConstructorADT name rep)

394387 -> GColumnsADT _Columns rep context

395388

396389

397390instance

398− ( htable ~ HLabel "tag" (HType Tag)

391+ ( htable ~ HLabel "tag" (HIdentity Tag)

399392 , meta ~ 'MetaData datatype _module _package _newtype

400393 , fallback ~ TypeError (NoConstructor datatype name)

401394 , fields ~ GFields f (GConstructorADT' name rep fallback)

@@ -417,7 +410,7 @@ type GMakeableADT'

417410 :: (Type -> Exp Constraint)

418411 -> (Type -> Exp K.HTable)

419412 -> (Type -> Exp Type)

420− -> K.HContext -> K.HTable -> Symbol -> (Type -> Type) -> Type -> Constraint

413+ -> K.Context -> K.HTable -> Symbol -> (Type -> Type) -> Type -> Constraint

421414class GMakeableADT' _Table _Columns f context htable name rep fields where

422415 gmakeADT' :: ()

423416 => ToColumns _Table _Columns f context

src/Rel8/Generic/Construction/Record.hs+3−3

@@ -43,7 +43,7 @@ type FromColumns

4343 :: (Type -> Exp Constraint)

4444 -> (Type -> Exp K.HTable)

4545 -> (Type -> Exp Type)

46− -> K.HContext

46+ -> K.Context

4747 -> Type

4848type FromColumns _Table _Columns f context = forall proxy x.

4949 Eval (_Table x) => proxy x -> Eval (_Columns x) context -> Eval (f x)

@@ -53,7 +53,7 @@ type ToColumns

5353 :: (Type -> Exp Constraint)

5454 -> (Type -> Exp K.HTable)

5555 -> (Type -> Exp Type)

56− -> K.HContext

56+ -> K.Context

5757 -> Type

5858type ToColumns _Table _Columns f context = forall proxy x.

5959 Eval (_Table x) => proxy x -> Eval (f x) -> Eval (_Columns x) context

@@ -117,7 +117,7 @@ type GConstructable

117117 :: (Type -> Exp Constraint)

118118 -> (Type -> Exp K.HTable)

119119 -> (Type -> Exp Type)

120− -> K.HContext -> (Type -> Type) -> Constraint

120+ -> K.Context -> (Type -> Type) -> Constraint

121121class GConstructable _Table _Columns f context rep where

122122 gconstruct :: ()

123123 => ToColumns _Table _Columns f context

src/Rel8/Generic/Map.hs+20

@@ -2,9 +2,11 @@

22{-# language StandaloneKindSignatures #-}

33{-# language TypeFamilies #-}

44{-# language TypeOperators #-}

5+{-# language UndecidableInstances #-}

67module Rel8.Generic.Map

78 ( GMap

9+ , Map

810 )

911where

1012

@@ -27,3 +29,21 @@ type family GMap f rep where

2729 GMap _ U1 = U1

2830 GMap f (rep1 :*: rep2) = GMap f rep1 :*: GMap f rep2

2931 GMap f (K1 i a) = K1 i (Eval (f a))

32+

33+

34+-- | Map a @Type -> Type@ function over the @Type@-kinded type variables in

35+-- of a type constructor.

36+type Map :: (Type -> Exp Type) -> Type -> Type

37+type family Map f a where

38+ Map p (t a b c d e f g) =

39+ t (Eval (p a)) (Eval (p b)) (Eval (p c)) (Eval (p d)) (Eval (p e))

40+ (Eval (p f)) (Eval (p g))

41+ Map p (t a b c d e f) =

42+ t (Eval (p a)) (Eval (p b)) (Eval (p c)) (Eval (p d)) (Eval (p e))

43+ (Eval (p f))

44+ Map p (t a b c d e) =

45+ t (Eval (p a)) (Eval (p b)) (Eval (p c)) (Eval (p d)) (Eval (p e))

46+ Map p (t a b c d) = t (Eval (p a)) (Eval (p b)) (Eval (p c)) (Eval (p d))

47+ Map p (t a b c) = t (Eval (p a)) (Eval (p b)) (Eval (p c))

48+ Map p (t a b) = t (Eval (p a)) (Eval (p b))

49+ Map p (t a) = t (Eval (p a))

src/Rel8/Generic/Record.hs+2

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

11{-# language AllowAmbiguousTypes #-}

22{-# language DataKinds #-}

3+{-# language FlexibleContexts #-}

34{-# language FlexibleInstances #-}

45{-# language MultiParamTypeClasses #-}

56{-# language PolyKinds #-}

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

141142 uncount = id

142143

143144

145+type Record :: Type -> Type

144146newtype Record a = Record

145147 { unrecord :: a

146148 }

src/Rel8/Generic/Rel8able.hs+157−72

@@ -3,11 +3,16 @@

33{-# language DataKinds #-}

44{-# language DefaultSignatures #-}

55{-# language FlexibleContexts #-}

6+{-# language FlexibleInstances #-}

67{-# language LambdaCase #-}

8+{-# language MultiParamTypeClasses #-}

9+{-# language PolyKinds #-}

10+{-# language QuantifiedConstraints #-}

711{-# language ScopedTypeVariables #-}

812{-# language StandaloneKindSignatures #-}

913{-# language TypeApplications #-}

10−{-# language TypeFamilies #-}

14+{-# language TypeFamilyDependencies #-}

15+{-# language TypeOperators #-}

1116{-# language UndecidableInstances #-}

1217

1318module Rel8.Generic.Rel8able

@@ -16,32 +21,38 @@ module Rel8.Generic.Rel8able

1621 , GRep

1722 , GColumns, gfromColumns, gtoColumns

1823 , GFromExprs, gfromResult, gtoResult

24+ , TSerialize, serialize, deserialize

1925 )

2026where

2127

2228-- base

29+import Data.Functor.Identity ( Identity )

2330import Data.Kind ( Constraint, Type )

31+import Data.Type.Bool ( type (&&) )

2432import GHC.Generics ( Generic, Rep, from, to )

2533import Prelude

2634

2735-- rel8

2836import Rel8.Aggregate ( Aggregate )

2937import Rel8.Expr ( Expr )

30−import Rel8.Generic.Map ( GMap )

38+import Rel8.FCF ( Exp, Eval )

3139import Rel8.Generic.Record ( Record(..) )

3240import Rel8.Generic.Table ( GAlgebra )

3341import qualified Rel8.Generic.Table.Record as G

3442import qualified Rel8.Kind.Algebra as K ( Algebra(..) )

35−import Rel8.Schema.Context ( Col )

36−import Rel8.Schema.Context.Virtual ( Abstract(..) )

43+import Rel8.Kind.Context ( SContext(..) )

44+import Rel8.Schema.Field ( Field )

3745import Rel8.Schema.HTable ( HTable )

3846import qualified Rel8.Schema.Kind as K

3947import Rel8.Schema.Name ( Name )

4048import Rel8.Schema.Result ( Result )

4149import Rel8.Table

42− ( fromColumns, toColumns, fromResult, toResult

43− , TTable, TColumns, TFromExprs

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

51+ , FromExprs, fromResult, toResult

52+ , Transpose

53+ , TTable, TColumns

4454 )

55+import Rel8.Table.Transpose ( Transposes )

4556

4657

4758-- | The kind of 'Rel8able' types

@@ -49,6 +60,59 @@ type KRel8able :: Type

4960type KRel8able = K.Rel8able

5061

5162

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

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

65+type family a == b where

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

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

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

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

70+

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

72+ -- which occurs when we have polymorphic Rel8ables

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

74+ a == Identity a = 'False

75+

76+ -- These cases are exactly the same as those in 'Data.Type.Equality.==.

77+ f a == g b = f == g && a == b

78+ a == a = 'True

79+ _ == _ = 'False

80+

81+

82+type Serialize :: Bool -> Type -> Type -> Constraint

83+class transposition ~ (a == Transpose Result expr) =>

84+ Serialize transposition expr a

85+ where

86+ serialize :: a -> Columns expr Result

87+ deserialize :: Columns expr Result -> a

88+

89+

90+instance

91+ ( (a == Transpose Result expr) ~ 'True

92+ , Transposes Expr Result expr a

93+ )

94+ => Serialize 'True expr a

95+ where

96+ serialize = toColumns

97+ deserialize = fromColumns

98+

99+

100+instance

101+ ( (a == Transpose Result expr) ~ 'False

102+ , Table (Context expr) expr

103+ , FromExprs expr ~ a

104+ )

105+ => Serialize 'False expr a

106+ where

107+ serialize = toResult @_ @expr

108+ deserialize = fromResult @_ @expr

109+

110+

111+data TSerialize :: Type -> Type -> Exp Constraint

112+type instance Eval (TSerialize expr a) =

113+ Serialize (a == Transpose Result expr) expr a

114+

115+

52116-- | This type class allows you to define custom 'Table's using higher-kinded

53117-- data types. Higher-kinded data types are data types of the pattern:

54118--

@@ -82,7 +146,7 @@ type KRel8able = K.Rel8able

82146-- [Supplying @Rel8able@ instances]

83147--

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

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

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

86150-- extensions:

87151--

88152-- @

@@ -96,72 +160,52 @@ class HTable (GColumns t) => Rel8able t where

96160 type GColumns t :: K.HTable

97161 type GFromExprs t :: Type

98162

99− gfromColumns :: Abstract context -> GColumns t (Col context) -> t context

100− gtoColumns :: Abstract context -> t context -> GColumns t (Col context)

163+ gfromColumns :: SContext context -> GColumns t context -> t context

164+ gtoColumns :: SContext context -> t context -> GColumns t context

101165

102− gfromResult :: GColumns t (Col Result) -> GFromExprs t

103− gtoResult :: GFromExprs t -> GColumns t (Col Result)

166+ gfromResult :: GColumns t Result -> GFromExprs t

167+ gtoResult :: GFromExprs t -> GColumns t Result

104168

105169 type GColumns t = G.GColumns TColumns (GRep t Expr)

106170 type GFromExprs t = t Result

107171

108172 default gfromColumns :: forall context.

109− ( VRel8able t Aggregate

110− , VRel8able t Expr

111− , VRel8able t Name

173+ ( SRel8able t Aggregate

174+ , SRel8able t Expr

175+ , forall table. SRel8able t (Field table)

176+ , SRel8able t Name

177+ , SSerialize t

112178 )

113− => Abstract context -> GColumns t (Col context) -> t context

179+ => SContext context -> GColumns t context -> t context

114180 gfromColumns = \case

115− VAggregate -> vfromColumns

116− VExpr -> vfromColumns

117− VName -> vfromColumns

181+ SAggregate -> sfromColumns

182+ SExpr -> sfromColumns

183+ SField -> sfromColumns

184+ SName -> sfromColumns

185+ SResult -> sfromResult

118186

119187 default gtoColumns :: forall context.

120− ( VRel8able t Aggregate

121− , VRel8able t Expr

122− , VRel8able t Name

188+ ( SRel8able t Aggregate

189+ , SRel8able t Expr

190+ , forall table. SRel8able t (Field table)

191+ , SRel8able t Name

192+ , SSerialize t

123193 )

124− => Abstract context -> t context -> GColumns t (Col context)

194+ => SContext context -> t context -> GColumns t context

125195 gtoColumns = \case

126− VAggregate -> vtoColumns

127− VExpr -> vtoColumns

128− VName -> vtoColumns

129−

130− default gfromResult ::

131− ( Generic (Record (t Result))

132− , G.GTable (TTable Expr) TColumns TFromExprs (GRep t Expr)

133− , G.GColumns TColumns (GRep t Expr) ~ GColumns t

134− , Rep (Record (t Result)) ~ GMap TFromExprs (GRep t Expr)

135− , GFromExprs t ~ t Result

136− )

137− => GColumns t (Col Result) -> GFromExprs t

138− gfromResult =

139− unrecord .

140− to .

141− G.gfromResult

142− @(TTable Expr)

143− @TColumns

144− @TFromExprs

145− @(GRep t Expr)

146− (\(_ :: proxy x) -> fromResult @Expr @x)

147−

148− default gtoResult ::

149− ( Generic (Record (t Result))

150− , G.GTable (TTable Expr) TColumns TFromExprs (GRep t Expr)

151− , G.GColumns TColumns (GRep t Expr) ~ GColumns t

152− , Rep (Record (t Result)) ~ GMap TFromExprs (GRep t Expr)

153− , GFromExprs t ~ t Result

154− )

155− => GFromExprs t -> GColumns t (Col Result)

156− gtoResult =

157− G.gtoResult

158− @(TTable Expr)

159− @TColumns

160− @TFromExprs

161− @(GRep t Expr)

162− (\(_ :: proxy x) -> toResult @Expr @x) .

163− from .

164− Record

196+ SAggregate -> stoColumns

197+ SExpr -> stoColumns

198+ SField -> stoColumns

199+ SName -> stoColumns

200+ SResult -> stoResult

201+

202+ default gfromResult :: (SSerialize t, GFromExprs t ~ t Result)

203+ => GColumns t Result -> GFromExprs t

204+ gfromResult = sfromResult

205+

206+ default gtoResult :: (SSerialize t, GFromExprs t ~ t Result)

207+ => GFromExprs t -> GColumns t Result

208+ gtoResult = stoResult

165209

166210

167211type Algebra :: K.Rel8able -> K.Algebra

@@ -172,25 +216,66 @@ type GRep :: K.Rel8able -> K.Context -> Type -> Type

172216type GRep t context = Rep (Record (t context))

173217

174218

175−type VRel8able :: K.Rel8able -> K.Context -> Constraint

176−type VRel8able t context =

219+type SRel8able :: K.Rel8able -> K.Context -> Constraint

220+class

221+ ( Generic (Record (t context))

222+ , G.GTable (TTable context) TColumns (GRep t context)

223+ , G.GColumns TColumns (GRep t context) ~ GColumns t

224+ )

225+ => SRel8able t context

226+instance

177227 ( Generic (Record (t context))

178− , G.GTable (TTable context) TColumns TFromExprs (GRep t context)

228+ , G.GTable (TTable context) TColumns (GRep t context)

179229 , G.GColumns TColumns (GRep t context) ~ GColumns t

180230 )

231+ => SRel8able t context

232+

233+

234+type SSerialize :: K.Rel8able -> Constraint

235+type SSerialize t =

236+ ( Generic (Record (t Result))

237+ , G.GSerialize TSerialize TColumns (GRep t Expr) (GRep t Result)

238+ , G.GColumns TColumns (GRep t Expr) ~ GColumns t

239+ )

240+

241+

242+sfromColumns :: forall t context. SRel8able t context

243+ => GColumns t context -> t context

244+sfromColumns =

245+ unrecord .

246+ to .

247+ G.gfromColumns @(TTable context) @TColumns fromColumns

248+

249+

250+stoColumns :: forall t context. SRel8able t context

251+ => t context -> GColumns t context

252+stoColumns =

253+ G.gtoColumns @(TTable context) @TColumns toColumns .

254+ from .

255+ Record

181256

182257

183−vfromColumns :: forall t context. VRel8able t context

184− => GColumns t (Col context) -> t context

185−vfromColumns =

258+sfromResult :: forall t. SSerialize t

259+ => GColumns t Result -> t Result

260+sfromResult =

186261 unrecord .

187262 to .

188− G.gfromColumns @(TTable context) @TColumns @TFromExprs fromColumns

263+ G.gfromResult

264+ @TSerialize

265+ @TColumns

266+ @(GRep t Expr)

267+ @(GRep t Result)

268+ (\(_ :: proxy x) -> deserialize @_ @x)

189269

190270

191−vtoColumns :: forall t context. VRel8able t context

192− => t context -> GColumns t (Col context)

193−vtoColumns =

194− G.gtoColumns @(TTable context) @TColumns @TFromExprs toColumns .

271+stoResult :: forall t. SSerialize t

272+ => t Result -> GColumns t Result

273+stoResult =

274+ G.gtoResult

275+ @TSerialize

276+ @TColumns

277+ @(GRep t Expr)

278+ @(GRep t Result)

279+ (\(_ :: proxy x) -> serialize @_ @x) .

195280 from .

196281 Record

src/Rel8/Generic/Table.hs+26−28

@@ -12,7 +12,7 @@

1212{-# language UndecidableInstances #-}

1313

1414module Rel8.Generic.Table

15− ( GGTable, GGColumns, ggfromResult, ggtoResult

15+ ( GGSerialize, GGColumns, ggfromResult, ggtoResult

1616 , GAlgebra

1717 )

1818where

@@ -24,36 +24,34 @@ import Prelude ()

2424

2525-- rel8

2626import Rel8.FCF ( Eval, Exp )

27−import Rel8.Generic.Map ( GMap )

2827import Rel8.Generic.Table.ADT

29− ( GTableADT, GColumnsADT, gtoResultADT, gfromResultADT

28+ ( GSerializeADT, GColumnsADT, gtoResultADT, gfromResultADT

3029 )

31−import Rel8.Generic.Table.Record ( GTable, GColumns, gtoResult, gfromResult )

30+import Rel8.Generic.Table.Record ( GSerialize, GColumns, gtoResult, gfromResult )

3231import Rel8.Kind.Algebra

3332 ( Algebra( Product, Sum )

3433 , SAlgebra( SProduct, SSum )

3534 , KnownAlgebra, algebraSing

3635 )

37−import Rel8.Schema.Context ( Col )

3836import qualified Rel8.Schema.Kind as K

3937import Rel8.Schema.Result ( Result )

4038

4139

42−data GGTable

40+data GGSerialize

4341 :: Algebra

44− -> (Type -> Exp Constraint)

42+ -> (Type -> Type -> Exp Constraint)

4543 -> (Type -> Exp K.HTable)

46− -> (Type -> Exp Type)

44+ -> (Type -> Type)

4745 -> (Type -> Type)

4846 -> Exp Constraint

4947

5048

51−type instance Eval (GGTable 'Product _Table _Columns _FromExprs rep) =

52− GTable _Table _Columns _FromExprs rep

49+type instance Eval (GGSerialize 'Product _Serialize _Columns exprs rep) =

50+ GSerialize _Serialize _Columns exprs rep

5351

5452

55−type instance Eval (GGTable 'Sum _Table _Columns _FromExprs rep) =

56− GTableADT _Table _Columns _FromExprs rep

53+type instance Eval (GGSerialize 'Sum _Serialize _Columns exprs rep) =

54+ GSerializeADT _Serialize _Columns exprs rep

5755

5856

5957data GGColumns

@@ -79,27 +77,27 @@ type family GAlgebra rep where

7977 GAlgebra (K1 _ _) = 'Product

8078

8179

82−ggfromResult :: forall algebra _Table _Columns _FromExprs rep x.

80+ggfromResult :: forall algebra _Serialize _Columns exprs rep x.

8381 ( KnownAlgebra algebra

84− , Eval (GGTable algebra _Table _Columns _FromExprs rep)

82+ , Eval (GGSerialize algebra _Serialize _Columns exprs rep)

8583 )

86− => (forall a proxy. Eval (_Table a)

87− => proxy a -> Eval (_Columns a) (Col Result) -> Eval (_FromExprs a))

88− -> Eval (GGColumns algebra _Columns rep) (Col Result)

89− -> GMap _FromExprs rep x

84+ => (forall expr a proxy. Eval (_Serialize expr a)

85+ => proxy expr -> Eval (_Columns expr) Result -> a)

86+ -> Eval (GGColumns algebra _Columns exprs) Result

87+ -> rep x

9088ggfromResult f x = case algebraSing @algebra of

91− SProduct -> gfromResult @_Table @_Columns @_FromExprs @rep f x

92− SSum -> gfromResultADT @_Table @_Columns @_FromExprs @rep f x

89+ SProduct -> gfromResult @_Serialize @_Columns @exprs @rep f x

90+ SSum -> gfromResultADT @_Serialize @_Columns @exprs @rep f x

9391

9492

95−ggtoResult :: forall algebra _Table _Columns _FromExprs rep x.

93+ggtoResult :: forall algebra _Serialize _Columns exprs rep x.

9694 ( KnownAlgebra algebra

97− , Eval (GGTable algebra _Table _Columns _FromExprs rep)

95+ , Eval (GGSerialize algebra _Serialize _Columns exprs rep)

9896 )

99− => (forall a proxy. Eval (_Table a)

100− => proxy a -> Eval (_FromExprs a) -> Eval (_Columns a) (Col Result))

101− -> GMap _FromExprs rep x

102− -> Eval (GGColumns algebra _Columns rep) (Col Result)

97+ => (forall expr a proxy. Eval (_Serialize expr a)

98+ => proxy expr -> a -> Eval (_Columns expr) Result)

99+ -> rep x

100+ -> Eval (GGColumns algebra _Columns exprs) Result

103101ggtoResult f x = case algebraSing @algebra of

104− SProduct -> gtoResult @_Table @_Columns @_FromExprs @rep f x

105− SSum -> gtoResultADT @_Table @_Columns @_FromExprs @rep f x

102+ SProduct -> gtoResult @_Serialize @_Columns @exprs @rep f x

103+ SSum -> gtoResultADT @_Serialize @_Columns @exprs @rep f x

src/Rel8/Generic/Table/ADT.hs+70−76

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

11{-# language AllowAmbiguousTypes #-}

22{-# language DataKinds #-}

3+{-# language FlexibleContexts #-}

34{-# language FlexibleInstances #-}

45{-# language LambdaCase #-}

56{-# language MultiParamTypeClasses #-}

@@ -12,12 +13,13 @@

1213{-# language UndecidableInstances #-}

1314

1415module Rel8.Generic.Table.ADT

15− ( GTableADT, GColumnsADT, gfromResultADT, gtoResultADT

16− , GTableADT', GColumnsADT'

16+ ( GSerializeADT, GColumnsADT, gfromResultADT, gtoResultADT

17+ , GSerializeADT', GColumnsADT'

1718 )

1819where

1920

2021-- base

22+import Data.Functor.Identity ( Identity( Identity ) )

2123import Data.Kind ( Constraint, Type )

2224import Data.Proxy ( Proxy( Proxy ) )

2325import GHC.Generics

@@ -30,18 +32,14 @@ import Prelude hiding ( null )

3032

3133-- rel8

3234import Rel8.FCF ( Eval, Exp )

33−import Rel8.Generic.Map ( GMap )

34−import Rel8.Generic.Table.Record ( GTable, GColumns, gfromResult, gtoResult )

35+import Rel8.Generic.Table.Record ( GSerialize, GColumns, gfromResult, gtoResult )

3536import Rel8.Schema.HTable ( HTable )

36−import Rel8.Schema.HTable.Identity ( HIdentity( HType ), HType )

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

3738import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )

3839import Rel8.Schema.HTable.Nullify ( HNullify, hnulls, hnullify, hunnullify )

3940import Rel8.Schema.HTable.Product ( HProduct( HProduct ) )

4041import qualified Rel8.Schema.Kind as K

41−import Rel8.Schema.Result

42− ( Col( R ), Result

43− , null, nullifier, unnullifier

44− )

42+import Rel8.Schema.Result ( Result, null, nullifier, unnullifier )

4543import Rel8.Type.Tag ( Tag( Tag ) )

4644

4745-- text

@@ -53,7 +51,7 @@ type GColumnsADT

5351 -> (Type -> Type) -> K.HTable

5452type family GColumnsADT _Columns rep where

5553 GColumnsADT _Columns (M1 D _ rep) =

56− GColumnsADT' _Columns (HLabel "tag" (HType Tag)) rep

54+ GColumnsADT' _Columns (HLabel "tag" (HIdentity Tag)) rep

5755

5856

5957type GColumnsADT'

@@ -67,122 +65,118 @@ type family GColumnsADT' _Columns htable rep where

6765 HProduct htable (HLabel label (HNullify (GColumns _Columns rep)))

6866

6967

70−type GTableADT

71− :: (Type -> Exp Constraint)

68+type GSerializeADT

69+ :: (Type -> Type -> Exp Constraint)

7270 -> (Type -> Exp K.HTable)

73− -> (Type -> Exp Type)

74− -> (Type -> Type) -> Constraint

75−class GTableADT _Table _Columns _FromExprs rep where

71+ -> (Type -> Type) -> (Type -> Type) -> Constraint

72+class GSerializeADT _Serialize _Columns exprs rep where

7673 gfromResultADT :: ()

77− => (forall a proxy. Eval (_Table a)

78− => proxy a -> Eval (_Columns a) (Col Result) -> Eval (_FromExprs a))

79− -> GColumnsADT _Columns rep (Col Result)

80− -> GMap _FromExprs rep x

74+ => (forall expr a proxy. Eval (_Serialize expr a)

75+ => proxy expr -> Eval (_Columns expr) Result -> a)

76+ -> GColumnsADT _Columns exprs Result

77+ -> rep x

8178

8279 gtoResultADT :: ()

83− => (forall a proxy. Eval (_Table a)

84− => proxy a -> Eval (_FromExprs a) -> Eval (_Columns a) (Col Result))

85− -> GMap _FromExprs rep x

86− -> GColumnsADT _Columns rep (Col Result)

80+ => (forall expr a proxy. Eval (_Serialize expr a)

81+ => proxy expr -> a -> Eval (_Columns expr) Result)

82+ -> rep x

83+ -> GColumnsADT _Columns exprs Result

8784

8885

8986instance

90− ( htable ~ HLabel "tag" (HType Tag)

91− , Eval (_Table (htable context))

92− , Eval (_Columns (htable context)) ~ htable

93− , GTableADT' _Table _Columns _FromExprs htable rep

87+ ( htable ~ HLabel "tag" (HIdentity Tag)

88+ , GSerializeADT' _Serialize _Columns htable exprs rep

9489 )

95− => GTableADT _Table _Columns _FromExprs (M1 D meta rep)

90+ => GSerializeADT _Serialize _Columns (M1 D meta exprs) (M1 D meta rep)

9691 where

9792 gfromResultADT fromResult columns =

98− case gfromResultADT' @_Table @_Columns @_FromExprs @htable @rep fromResult tag columns of

93+ case gfromResultADT' @_Serialize @_Columns @htable @exprs @rep fromResult tag columns of

9994 Just rep -> M1 rep

10095 _ -> error "ADT.fromColumns: mismatch between tag and data"

10196 where

102− tag = (\(HType (R a)) -> a) . hunlabel @"tag"

97+ tag = (\(HIdentity (Identity a)) -> a) . hunlabel @"tag"

10398

10499 gtoResultADT toResult (M1 rep) =

105− gtoResultADT' @_Table @_Columns @_FromExprs @htable @rep toResult tag (Just rep)

100+ gtoResultADT' @_Serialize @_Columns @htable @exprs @rep toResult tag (Just rep)

106101 where

107− tag = hlabel @"tag" . HType . R

102+ tag = hlabel @"tag" . HIdentity . Identity

108103

109104

110−type GTableADT'

111− :: (Type -> Exp Constraint)

105+type GSerializeADT'

106+ :: (Type -> Type -> Exp Constraint)

112107 -> (Type -> Exp K.HTable)

113− -> (Type -> Exp Type)

114− -> K.HTable -> (Type -> Type) -> Constraint

115−class GTableADT' _Table _Columns _FromExprs htable rep where

116− gfromResultADT' :: context ~ Col Result

117− => (forall a proxy. Eval (_Table a)

118− => proxy a -> Eval (_Columns a) context -> Eval (_FromExprs a))

119− -> (htable (Col Result) -> Tag)

120− -> GColumnsADT' _Columns htable rep context

121− -> Maybe (GMap _FromExprs rep x)

122−

123− gtoResultADT' :: context ~ Col Result

124− => (forall a proxy. Eval (_Table a)

125− => proxy a -> Eval (_FromExprs a) -> Eval (_Columns a) context)

126− -> (Tag -> htable (Col Result))

127− -> Maybe (GMap _FromExprs rep x)

128− -> GColumnsADT' _Columns htable rep context

129−

130− extract :: GColumnsADT' _Columns htable rep context -> htable context

108+ -> K.HTable -> (Type -> Type) -> (Type -> Type) -> Constraint

109+class GSerializeADT' _Serialize _Columns htable exprs rep where

110+ gfromResultADT' :: context ~ Result

111+ => (forall expr a proxy. Eval (_Serialize expr a)

112+ => proxy expr -> Eval (_Columns expr) context -> a)

113+ -> (htable Result -> Tag)

114+ -> GColumnsADT' _Columns htable exprs context

115+ -> Maybe (rep x)

116+

117+ gtoResultADT' :: context ~ Result

118+ => (forall expr a proxy. Eval (_Serialize expr a)

119+ => proxy expr -> a -> Eval (_Columns expr) context)

120+ -> (Tag -> htable Result)

121+ -> Maybe (rep x)

122+ -> GColumnsADT' _Columns htable exprs context

123+

124+ extract :: GColumnsADT' _Columns htable exprs context -> htable context

131125

132126

133127instance

134− ( htable' ~ GColumnsADT' _Columns htable a

135− , GTableADT' _Table _Columns _FromExprs htable a

136− , GTableADT' _Table _Columns _FromExprs htable' b

128+ ( htable' ~ GColumnsADT' _Columns htable exprs1

129+ , GSerializeADT' _Serialize _Columns htable exprs1 a

130+ , GSerializeADT' _Serialize _Columns htable' exprs2 b

137131 )

138− => GTableADT' _Table _Columns _FromExprs htable (a :+: b)

132+ => GSerializeADT' _Serialize _Columns htable (exprs1 :+: exprs2) (a :+: b)

139133 where

140134 gfromResultADT' fromResult f columns =

141135 case ma of

142136 Just a -> Just (L1 a)

143137 Nothing -> R1 <$>

144− gfromResultADT' @_Table @_Columns @_FromExprs @_ @b

138+ gfromResultADT' @_Serialize @_Columns @_ @exprs2 @b

145139 fromResult

146− (f . extract @_Table @_Columns @_FromExprs @_ @a)

140+ (f . extract @_Serialize @_Columns @_ @exprs1 @a)

147141 columns

148142 where

149143 ma =

150− gfromResultADT' @_Table @_Columns @_FromExprs @_ @a

144+ gfromResultADT' @_Serialize @_Columns @_ @exprs1 @a

151145 fromResult

152146 f

153− (extract @_Table @_Columns @_FromExprs @_ @b columns)

147+ (extract @_Serialize @_Columns @_ @exprs2 @b columns)

154148

155149 gtoResultADT' toResult tag = \case

156150 Just (L1 a) ->

157− gtoResultADT' @_Table @_Columns @_FromExprs @_ @b

151+ gtoResultADT' @_Serialize @_Columns @_ @exprs2 @b

158152 toResult

159− (\_ -> gtoResultADT' @_Table @_Columns @_FromExprs @_ @a

153+ (\_ -> gtoResultADT' @_Serialize @_Columns @_ @exprs1 @a

160154 toResult

161155 tag

162156 (Just a))

163157 Nothing

164158 Just (R1 b) ->

165− gtoResultADT' @_Table @_Columns @_FromExprs @_ @b

159+ gtoResultADT' @_Serialize @_Columns @_ @exprs2 @b

166160 toResult

167161 (\tag' ->

168− gtoResultADT' @_Table @_Columns @_FromExprs @_ @a

162+ gtoResultADT' @_Serialize @_Columns @_ @exprs1 @a

169163 toResult

170164 (\_ -> tag tag')

171165 Nothing)

172166 (Just b)

173167 Nothing ->

174− gtoResultADT' @_Table @_Columns @_FromExprs @_ @b

168+ gtoResultADT' @_Serialize @_Columns @_ @exprs2 @b

175169 toResult

176− (\_ -> gtoResultADT' @_Table @_Columns @_FromExprs @_ @a toResult tag Nothing)

170+ (\_ -> gtoResultADT' @_Serialize @_Columns @_ @exprs1 @a toResult tag Nothing)

177171 Nothing

178172

179173 extract =

180− extract @_Table @_Columns @_FromExprs @_ @a .

181− extract @_Table @_Columns @_FromExprs @_ @b

174+ extract @_Serialize @_Columns @_ @exprs1 @a .

175+ extract @_Serialize @_Columns @_ @exprs2 @b

182176

183177

184178instance (meta ~ 'MetaCons label _fixity _isRecord, KnownSymbol label) =>

185− GTableADT' _Table _Columns _FromExprs htable (M1 C meta U1)

179+ GSerializeADT' _Serialize _Columns _htable (M1 C meta U1) (M1 C meta U1)

186180 where

187181 gfromResultADT' _ tag columns

188182 | tag columns == tag' = Just (M1 U1)

@@ -198,18 +192,18 @@ instance (meta ~ 'MetaCons label _fixity _isRecord, KnownSymbol label) =>

198192

199193

200194instance {-# OVERLAPPABLE #-}

201− ( HTable (GColumns _Columns rep)

202− , GTable _Table _Columns _FromExprs rep

195+ ( HTable (GColumns _Columns exprs)

196+ , GSerialize _Serialize _Columns exprs rep

203197 , meta ~ 'MetaCons label _fixity _isRecord

204198 , KnownSymbol label

205− , GColumnsADT' _Columns htable (M1 C ('MetaCons label _fixity _isRecord) rep) ~

206− HProduct htable (HLabel label (HNullify (GColumns _Columns rep)))

199+ , GColumnsADT' _Columns htable (M1 C ('MetaCons label _fixity _isRecord) exprs) ~

200+ HProduct htable (HLabel label (HNullify (GColumns _Columns exprs)))

207201 )

208− => GTableADT' _Table _Columns _FromExprs htable (M1 C meta rep)

202+ => GSerializeADT' _Serialize _Columns htable (M1 C meta exprs) (M1 C meta rep)

209203 where

210204 gfromResultADT' fromResult tag (HProduct a b)

211205 | tag a == tag' =

212− M1 . gfromResult @_Table @_Columns @_FromExprs @rep fromResult <$>

206+ M1 . gfromResult @_Serialize @_Columns @exprs @rep fromResult <$>

213207 hunnullify unnullifier (hunlabel b)

214208 | otherwise = Nothing

215209 where

@@ -220,7 +214,7 @@ instance {-# OVERLAPPABLE #-}

220214 Just (M1 rep) -> HProduct (tag tag') $

221215 hlabel $

222216 hnullify nullifier $

223− gtoResult @_Table @_Columns @_FromExprs @rep toResult rep

217+ gtoResult @_Serialize @_Columns @exprs @rep toResult rep

224218 where

225219 tag' = Tag $ pack $ symbolVal (Proxy @label)

226220

src/Rel8/Generic/Table/Record.hs+78−50

@@ -13,8 +13,8 @@

1313{-# language UndecidableInstances #-}

1414

1515module Rel8.Generic.Table.Record

16− ( GTable, GColumns, GContext

17− , gfromColumns, gtoColumns, gfromResult, gtoResult, gtable

16+ ( GTable, GColumns, GContext, gfromColumns, gtoColumns, gtable

17+ , GSerialize, gfromResult, gtoResult

1818 )

1919where

2020

@@ -30,7 +30,6 @@ import Prelude hiding ( null )

3030

3131-- rel8

3232import Rel8.FCF ( Eval, Exp )

33−import Rel8.Generic.Map ( GMap )

3433import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )

3534import Rel8.Schema.HTable.Product ( HProduct(..) )

3635import qualified Rel8.Schema.Kind as K

@@ -56,9 +55,8 @@ type family GContext _Context rep where

5655type GTable

5756 :: (Type -> Exp Constraint)

5857 -> (Type -> Exp K.HTable)

59− -> (Type -> Exp Type)

6058 -> (Type -> Type) -> Constraint

61−class GTable _Table _Columns _FromExprs rep

59+class GTable _Table _Columns rep

6260 where

6361 gfromColumns :: ()

6462 => (forall a. Eval (_Table a) => Eval (_Columns a) context -> a)

@@ -70,73 +68,93 @@ class GTable _Table _Columns _FromExprs rep

7068 -> rep x

7169 -> GColumns _Columns rep context

7270

73− gfromResult :: ()

74− => (forall a proxy. Eval (_Table a)

75− => proxy a -> Eval (_Columns a) context -> Eval (_FromExprs a))

76− -> GColumns _Columns rep context

77− -> GMap _FromExprs rep x

78−

79− gtoResult :: ()

80− => (forall a proxy. Eval (_Table a)

81− => proxy a -> Eval (_FromExprs a) -> Eval (_Columns a) context)

82− -> GMap _FromExprs rep x

83− -> GColumns _Columns rep context

84−

8571 gtable :: ()

8672 => (forall a proxy. Eval (_Table a) => proxy a -> Eval (_Columns a) context)

8773 -> GColumns _Columns rep context

8874

8975

90−instance GTable _Table _Columns _FromExprs rep =>

91− GTable _Table _Columns _FromExprs (M1 D c rep)

76+type GSerialize

77+ :: (Type -> Type -> Exp Constraint)

78+ -> (Type -> Exp K.HTable)

79+ -> (Type -> Type) -> (Type -> Type) -> Constraint

80+class GSerialize _Serialize _Columns exprs rep

81+ where

82+ gfromResult :: ()

83+ => (forall expr a proxy. Eval (_Serialize expr a)

84+ => proxy expr -> Eval (_Columns expr) context -> a)

85+ -> GColumns _Columns exprs context

86+ -> rep x

87+

88+ gtoResult :: ()

89+ => (forall expr a proxy. Eval (_Serialize expr a)

90+ => proxy expr -> a -> Eval (_Columns expr) context)

91+ -> rep x

92+ -> GColumns _Columns exprs context

93+

94+

95+instance GTable _Table _Columns rep => GTable _Table _Columns (M1 D c rep)

9296 where

9397 gfromColumns fromColumns =

94− M1 . gfromColumns @_Table @_Columns @_FromExprs @rep fromColumns

98+ M1 . gfromColumns @_Table @_Columns @rep fromColumns

9599 gtoColumns toColumns (M1 a) =

96− gtoColumns @_Table @_Columns @_FromExprs @rep toColumns a

100+ gtoColumns @_Table @_Columns @rep toColumns a

101+ gtable = gtable @_Table @_Columns @rep

102+

103+

104+instance GSerialize _Serialize _Columns exprs rep =>

105+ GSerialize _Serialize _Columns (M1 D c exprs) (M1 D c rep)

106+ where

97107 gfromResult fromResult =

98− M1 . gfromResult @_Table @_Columns @_FromExprs @rep fromResult

108+ M1 . gfromResult @_Serialize @_Columns @exprs @rep fromResult

99109 gtoResult toResult (M1 a) =

100− gtoResult @_Table @_Columns @_FromExprs @rep toResult a

101− gtable = gtable @_Table @_Columns @_FromExprs @rep

110+ gtoResult @_Serialize @_Columns @exprs @rep toResult a

102111

103112

104−instance GTable _Table _Columns _FromExprs rep =>

105− GTable _Table _Columns _FromExprs (M1 C c rep)

113+instance GTable _Table _Columns rep => GTable _Table _Columns (M1 C c rep)

106114 where

107115 gfromColumns fromColumns =

108− M1 . gfromColumns @_Table @_Columns @_FromExprs @rep fromColumns

116+ M1 . gfromColumns @_Table @_Columns @rep fromColumns

109117 gtoColumns toColumns (M1 a) =

110− gtoColumns @_Table @_Columns @_FromExprs @rep toColumns a

118+ gtoColumns @_Table @_Columns @rep toColumns a

119+ gtable = gtable @_Table @_Columns @rep

120+

121+

122+instance GSerialize _Serialize _Columns exprs rep =>

123+ GSerialize _Serialize _Columns (M1 C c exprs) (M1 C c rep)

124+ where

111125 gfromResult fromResult =

112− M1 . gfromResult @_Table @_Columns @_FromExprs @rep fromResult

126+ M1 . gfromResult @_Serialize @_Columns @exprs @rep fromResult

113127 gtoResult toResult (M1 a) =

114− gtoResult @_Table @_Columns @_FromExprs @rep toResult a

115− gtable = gtable @_Table @_Columns @_FromExprs @rep

128+ gtoResult @_Serialize @_Columns @exprs @rep toResult a

116129

117130

118−instance

119− ( GTable _Table _Columns _FromExprs rep1

120− , GTable _Table _Columns _FromExprs rep2

121− )

122− => GTable _Table _Columns _FromExprs (rep1 :*: rep2)

131+instance (GTable _Table _Columns rep1, GTable _Table _Columns rep2) =>

132+ GTable _Table _Columns (rep1 :*: rep2)

123133 where

124134 gfromColumns fromColumns (HProduct a b) =

125− gfromColumns @_Table @_Columns @_FromExprs @rep1 fromColumns a :*:

126− gfromColumns @_Table @_Columns @_FromExprs @rep2 fromColumns b

135+ gfromColumns @_Table @_Columns @rep1 fromColumns a :*:

136+ gfromColumns @_Table @_Columns @rep2 fromColumns b

127137 gtoColumns toColumns (a :*: b) = HProduct

128− (gtoColumns @_Table @_Columns @_FromExprs @rep1 toColumns a)

129− (gtoColumns @_Table @_Columns @_FromExprs @rep2 toColumns b)

138+ (gtoColumns @_Table @_Columns @rep1 toColumns a)

139+ (gtoColumns @_Table @_Columns @rep2 toColumns b)

140+ gtable table = HProduct

141+ (gtable @_Table @_Columns @rep1 table)

142+ (gtable @_Table @_Columns @rep2 table)

143+

144+

145+instance

146+ ( GSerialize _Serialize _Columns expr1 rep1

147+ , GSerialize _Serialize _Columns expr2 rep2

148+ )

149+ => GSerialize _Serialize _Columns (expr1 :*: expr2) (rep1 :*: rep2)

150+ where

130151 gfromResult fromResult (HProduct a b) =

131− gfromResult @_Table @_Columns @_FromExprs @rep1 fromResult a :*:

132− gfromResult @_Table @_Columns @_FromExprs @rep2 fromResult b

152+ gfromResult @_Serialize @_Columns @expr1 @rep1 fromResult a :*:

153+ gfromResult @_Serialize @_Columns @expr2 @rep2 fromResult b

133154 gtoResult toResult (a :*: b) =

134155 HProduct

135− (gtoResult @_Table @_Columns @_FromExprs @rep1 toResult a)

136− (gtoResult @_Table @_Columns @_FromExprs @rep2 toResult b)

137− gtable table = HProduct

138− (gtable @_Table @_Columns @_FromExprs @rep1 table)

139− (gtable @_Table @_Columns @_FromExprs @rep2 table)

156+ (gtoResult @_Serialize @_Columns @expr1 @rep1 toResult a)

157+ (gtoResult @_Serialize @_Columns @expr2 @rep2 toResult b)

140158

141159

142160instance

@@ -144,10 +162,20 @@ instance

144162 , meta ~ 'MetaSel ('Just label) _su _ss _ds

145163 , k1 ~ K1 i a

146164 )

147− => GTable _Table _Columns _FromExprs (M1 S meta k1)

165+ => GTable _Table _Columns (M1 S meta k1)

148166 where

149167 gfromColumns fromColumns = M1 . K1 . fromColumns . hunlabel

150168 gtoColumns toColumns (M1 (K1 a)) = hlabel (toColumns a)

151− gfromResult fromResult = M1 . K1 . fromResult (Proxy @a) . hunlabel

152− gtoResult toResult (M1 (K1 a)) = hlabel (toResult (Proxy @a) a)

153169 gtable table = hlabel (table (Proxy @a))

170+

171+

172+instance

173+ ( Eval (_Serialize expr a)

174+ , meta ~ 'MetaSel ('Just label) _su _ss _ds

175+ , k1 ~ K1 i expr

176+ , k1' ~ K1 i a

177+ )

178+ => GSerialize _Serialize _Columns (M1 S meta k1) (M1 S meta k1')

179+ where

180+ gfromResult fromResult = M1 . K1 . fromResult (Proxy @expr) . hunlabel

181+ gtoResult toResult (M1 (K1 a)) = hlabel (toResult (Proxy @expr) a)

src/Rel8/Kind/Context.hs+7

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

11{-# language DataKinds #-}

22{-# language GADTs #-}

33{-# language StandaloneKindSignatures #-}

4+{-# language TypeSynonymInstances #-}

56module Rel8.Kind.Context

67 ( Reifiable( contextSing )

@@ -15,6 +16,7 @@ import Prelude ()

1516-- rel8

1617import Rel8.Aggregate ( Aggregate )

1718import Rel8.Expr ( Expr )

19+import Rel8.Schema.Field ( Field )

1820import Rel8.Schema.Kind ( Context )

1921import Rel8.Schema.Name ( Name )

2022import Rel8.Schema.Result ( Result )

@@ -24,6 +26,7 @@ type SContext :: Context -> Type

2426data SContext context where

2527 SAggregate :: SContext Aggregate

2628 SExpr :: SContext Expr

29+ SField :: SContext (Field table)

2730 SName :: SContext Name

2831 SResult :: SContext Result

2932

@@ -41,6 +44,10 @@ instance Reifiable Expr where

4144 contextSing = SExpr

4245

4346

47+instance Reifiable (Field table) where

48+ contextSing = SField

49+

50+

4451instance Reifiable Result where

4552 contextSing = SResult

4653

src/Rel8/Order.hs+1−8

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

55module Rel8.Order

66 ( Order(..)

7− , toOrderExprs

87 )

98where

109

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

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

1817

1918-- opaleye

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

21−import qualified Opaleye.Internal.Order as Opaleye

19+import qualified Opaleye.Order as Opaleye

2220

2321

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

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

3028type Order :: Type -> Type

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

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

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

1+{-# language FlexibleContexts #-}

12{-# language StandaloneKindSignatures #-}

3+{-# language UndecidableInstances #-}

35module Rel8.Query

46 ( Query( Query )

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

1517-- opaleye

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

1719import qualified Opaleye.Internal.PackMap as Opaleye

18−import qualified Opaleye.Internal.PrimQuery as Opaleye

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

1921import qualified Opaleye.Internal.QueryArr as Opaleye

2022import qualified Opaleye.Internal.Tag as Opaleye

2123

2224-- rel8

25+import Rel8.Expr ( Expr )

2326import Rel8.Query.Set ( unionAll )

2427import Rel8.Query.Opaleye ( fromOpaleye )

2528import Rel8.Query.Values ( values )

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

2630import Rel8.Table.Alternative

2731 ( AltTable, (<|>:)

2832 , AlternativeTable, emptyTable

2933 )

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

3035

3136-- semigroupoids

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

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

151156 )

152157

153158

159+instance Projectable Query where

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

161+

162+

154163instance Functor Query where

155164 fmap f (Query a) = Query (fmap (fmap (fmap f)) a)

156165

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

169178

170179

171180instance Monad Query where

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

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

173182 let

174− Opaleye.QueryArr qa = q dummies

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

183+ qa = q dummies

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

176185 Query q' = f a

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

178187 ( dummy : dummies

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

188+ , query <> Opaleye.aRebind bindings

180189 , Opaleye.next tag'

181190 )

182191 where

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

184193 where

185194 random = Opaleye.FunExpr "random" []

186195 name = Opaleye.extractAttr "dummy" tag'

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

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

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

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

189198 query'''

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

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

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

200+ | otherwise = query <> query''

192201 m'' = m <> m'

193202 in

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

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

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

203212instance AlternativeTable Query where

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

11{-# language FlexibleContexts #-}

22{-# language MonoLocalBinds #-}

3+{-# language ScopedTypeVariables #-}

4+{-# language TypeApplications #-}

46module Rel8.Query.Aggregate

57 ( aggregate

68 , countRows

9+ , mode

710 )

811where

912

1013-- base

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

1115import Data.Int ( Int64 )

1216import Prelude

1317

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

1822import Rel8.Aggregate ( Aggregates )

1923import Rel8.Expr ( Expr )

2024import Rel8.Expr.Aggregate ( countStar )

25+import Rel8.Expr.Order ( desc )

2126import Rel8.Query ( Query )

27+import Rel8.Query.Limit ( limit )

2228import Rel8.Query.Maybe ( optional )

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

2435import Rel8.Table.Opaleye ( aggregator )

2536import Rel8.Table.Maybe ( maybeTable )

2637

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

3546-- will return @0@.

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

3748countRows = 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−

31module Rel8.Query.Distinct

42 ( distinct

53 , distinctOn

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

86where

108-- base

11−import Prelude

9+import Prelude ()

1210

1311-- opaleye

1412import qualified Opaleye.Distinct as Opaleye

15−import qualified Opaleye.Internal.Order as Opaleye

16−import qualified Opaleye.Internal.QueryArr as Opaleye

13+import qualified Opaleye.Order as Opaleye

1714

1815-- rel8

1916import Rel8.Order ( Order( Order ) )

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

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

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

3532distinctOn :: 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)

3834

3935

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

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

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

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

44−distinctOnBy proj (Order order) =

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

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

src/Rel8/Query/Each.hs+3−3

@@ -17,7 +17,7 @@ import Rel8.Query ( Query )

1717import Rel8.Query.Opaleye ( fromOpaleye )

1818import Rel8.Schema.Name ( Selects )

1919import Rel8.Schema.Table ( TableSchema )

20−import Rel8.Table ( fromColumns, toColumns )

20+import Rel8.Table.Cols ( fromCols, toCols )

2121import Rel8.Table.Opaleye ( table, unpackspec )

2222

2323

@@ -25,8 +25,8 @@ import Rel8.Table.Opaleye ( table, unpackspec )

2525-- table@.

2626each :: Selects names exprs => TableSchema names -> Query exprs

2727each =

28− fmap fromColumns .

28+ fmap fromCols .

2929 fromOpaleye .

3030 Opaleye.selectTableExplicit unpackspec .

3131 table .

32− fmap toColumns

32+ fmap toCols

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

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

44module Rel8.Query.Evaluate

55 ( evaluate

6− , rebind

76 )

87where

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

1615

1716-- opaleye

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

2418

2519-- rel8

2620import Rel8.Expr ( Expr )

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

2822import Rel8.Expr.Opaleye ( fromPrimExpr )

2923import Rel8.Query ( Query( Query ) )

24+import Rel8.Query.Rebind ( rebind )

3025import Rel8.Table ( Table )

3126import Rel8.Table.Bool ( case_ )

32−import Rel8.Table.Opaleye ( unpackspec )

33−import Rel8.Table.Undefined

27+import Rel8.Table.Undefined ( undefined )

3428

3529

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

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

3832-- effects and can safely be reused.

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

40−evaluate = laterally >=> rebind

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

4135

4236

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

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

5145 go = fromPrimExpr . Opaleye.UnExpr Opaleye.OpIsNotNull

5246

5347

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−

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

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

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

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

1212

1313-- opaleye

1414import qualified Opaleye.Exists as Opaleye

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

15+import qualified Opaleye.Operators as Opaleye

1616

1717-- rel8

1818import Rel8.Expr ( Expr )

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

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

1+module Rel8.Query.Indexed

2+ ( indexed

3+ )

4+where

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+15−12

@@ -19,17 +19,18 @@ import Prelude

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

2020

2121-- rel8

22−import Rel8.Expr ( Col( E, unE ), Expr )

22+import Rel8.Expr ( Expr )

2323import Rel8.Expr.Aggregate ( listAggExpr, nonEmptyAggExpr )

2424import Rel8.Expr.Opaleye ( mapPrimExpr )

2525import Rel8.Query ( Query )

2626import Rel8.Query.Aggregate ( aggregate )

27−import Rel8.Query.Evaluate ( rebind )

2827import Rel8.Query.Maybe ( optional )

28+import Rel8.Query.Rebind ( rebind )

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

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

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

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

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

32+import Rel8.Table ( Table, fromColumns )

33+import Rel8.Table.Cols ( toCols )

3334import Rel8.Table.Aggregate ( listAgg, nonEmptyAgg )

3435import Rel8.Table.List ( ListTable( ListTable ) )

3536import Rel8.Table.Maybe ( maybeTable )

@@ -51,7 +52,7 @@ many =

5152 fmap (maybeTable mempty (\(ListTable a) -> ListTable a)) .

5253 optional .

5354 aggregate .

54− fmap (listAgg . toColumns)

55+ fmap (listAgg . toCols)

5556

5657

5758-- | Aggregate a 'Query' into a 'NonEmptyTable'. If the supplied query returns

@@ -66,7 +67,7 @@ some :: Table Expr a => Query a -> Query (NonEmptyTable Expr a)

6667some =

6768 fmap (\(NonEmptyTable a) -> NonEmptyTable a) .

6869 aggregate .

69− fmap (nonEmptyAgg . toColumns)

70+ fmap (nonEmptyAgg . toCols)

7071

7172

7273-- | A version of 'many' specialised to single expressions.

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

8485--

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

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

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

88− hunvectorize (\SSpec {info} -> pure . E . sunnest info . unE) as

88+catListTable (ListTable as) =

89+ rebind "unnest" $ fromColumns $ runIdentity $

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

8991

9092

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

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

9395--

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

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

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

97− hunvectorize (\SSpec {info} -> pure . E . sunnest info . unE) as

98+catNonEmptyTable (NonEmptyTable as) =

99+ rebind "unnest" $ fromColumns $ runIdentity $

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

98101

99102

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

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

102105--

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

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

105−catList = rebind . sunnest typeInformation

108+catList = rebind "unnest" . sunnest typeInformation

106109

107110

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

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

110113--

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

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

113−catNonEmpty = rebind . sunnest typeInformation

116+catNonEmpty = rebind "unnest" . sunnest typeInformation

114117

115118

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

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

@@ -1,4 +1,5 @@

11{-# language GADTs #-}

2+{-# language LambdaCase #-}

23{-# language NamedFieldPuns #-}

45module Rel8.Query.Maybe

@@ -18,7 +19,7 @@ import Control.Comonad ( extract )

1819import qualified Opaleye.Internal.MaybeFields as Opaleye

1920

2021-- rel8

21−import Rel8.Expr ( Col( E ), Expr )

22+import Rel8.Expr ( Expr )

2223import Rel8.Expr.Eq ( (==.) )

2324import Rel8.Expr.Opaleye ( fromColumn, fromPrimExpr )

2425import Rel8.Query ( Query )

@@ -34,7 +35,7 @@ import Rel8.Table.Maybe ( MaybeTable(..), isJustTable )

3435-- JOIN@s.

3536optional :: Query a -> Query (MaybeTable Expr a)

3637optional = mapOpaleye $ Opaleye.optionalInternal $ \tag a -> MaybeTable

37− { tag = E $ fromPrimExpr $ fromColumn tag

38+ { tag = fromPrimExpr $ fromColumn tag

3839 , just = pure a

3940 }

4041

@@ -54,13 +55,14 @@ catMaybeTable ma@(MaybeTable _ a) = do

5455-- to step through multiple @LEFT JOINs@.

5556--

5657-- Note that @traverseMaybeTable@ takes a @a -> Query b@ function, which means

57−-- you also have the ability to "expand" one row into multiple rows. If the

58+-- you also have the ability to "expand" one row into multiple rows. If the

5859-- @a -> Query b@ function returns no rows, then the resulting query will also

5960-- have no rows. However, regardless of the given @a -> Query b@ function, if

6061-- the input is @nothingTable@, you will always get exactly one @nothingTable@

6162-- back.

6263traverseMaybeTable :: (a -> Query b) -> MaybeTable Expr a -> Query (MaybeTable Expr b)

63−traverseMaybeTable query ma@(MaybeTable (E input) _) = do

64− MaybeTable (E output) b <- optional (query =<< catMaybeTable ma)

65− where_ $ output ==. input

66− pure $ MaybeTable (E input) b

64+traverseMaybeTable query ma@(MaybeTable input _) = do

65+ optional (query =<< catMaybeTable ma) >>= \case

66+ MaybeTable output b -> do

67+ where_ $ output ==. input

68+ pure $ MaybeTable input b

src/Rel8/Query/Null.hs+15

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

1+{-# language FlexibleContexts #-}

13module Rel8.Query.Null

24 ( catNull

5+ , catNullTable

36 )

47where

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

912-- rel8

1013import Rel8.Expr ( Expr )

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

15+import Rel8.Table ( Table )

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

1217import Rel8.Query ( Query )

1318import Rel8.Query.Filter ( where_ )

1419

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

2126catNull a = do

2227 where_ $ isNonNull a

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

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

55 , toOpaleye

66 , mapOpaleye

77 , zipOpaleyeWith

8+ , unsafePeekQuery

89 )

910where

1011

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

1415

1516-- opaleye

1617import qualified Opaleye.Internal.QueryArr as Opaleye

18+import qualified Opaleye.Internal.Tag as Opaleye

1719

1820-- rel8

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

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

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

3840

3941

42+unsafePeekQuery :: Query a -> a

43+unsafePeekQuery (Query q) = case q mempty of

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

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

46+

47+

4048mapping :: ()

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

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

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

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

4452 let

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

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

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

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

4755 in

48− qa' ((), tag)

56+ Opaleye.runStateQueryArr q' () tag

4957

5058

5159zipping :: Semigroup m

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

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

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

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

62+zipping f q q' =

63+ Opaleye.stateQueryArr $ \_ tag ->

5664 let

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

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

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

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

5967 m'' = m <> m'

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

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

6169 in

62− qa'' ((), tag)

70+ Opaleye.runStateQueryArr q'' () tag

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

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

1+{-# language FlexibleContexts #-}

3+module Rel8.Query.Rebind

4+ ( rebind

5+ )

6+where

8+-- base

9+import Prelude

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

11+

12+-- opaleye

13+import qualified Opaleye.Internal.Rebind as Opaleye

14+

15+-- rel8

16+import Rel8.Expr ( Expr )

17+import Rel8.Query ( Query )

18+import Rel8.Table ( Table )

19+import Rel8.Table.Opaleye ( unpackspec )

20+import Rel8.Query.Opaleye (fromOpaleye)

21+

22+

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

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

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

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

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

src/Rel8/Query/SQL.hs+6−59

@@ -1,74 +1,21 @@

11{-# language FlexibleContexts #-}

2−{-# language TypeFamilies #-}

3−{-# language ViewPatterns #-}

2+{-# language MonoLocalBinds #-}

54module Rel8.Query.SQL

65 ( showQuery

7− , sqlForQuery, sqlForQueryWithNames

86 )

97where

108

119-- base

12−import Data.Foldable ( fold )

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

14−import Data.Void ( Void )

1510import Prelude

1611

17−-- opaleye

18−import qualified Opaleye.Internal.HaskellDB.Sql as Opaleye

19−import qualified Opaleye.Internal.PrimQuery as Opaleye

20−import qualified Opaleye.Internal.Print as Opaleye

21−import qualified Opaleye.Internal.Optimize as Opaleye

22−import qualified Opaleye.Internal.QueryArr as Opaleye hiding ( Select )

23−import qualified Opaleye.Internal.Sql as Opaleye

24−

2512-- rel8

26−import Rel8.Expr ( Expr, Col( E ) )

27−import Rel8.Expr.Opaleye ( toPrimExpr )

13+import Rel8.Expr ( Expr )

2814import Rel8.Query ( Query )

29−import Rel8.Query.Opaleye ( toOpaleye )

30−import Rel8.Schema.Name ( Name( Name ), Selects, Col( N ) )

31−import Rel8.Schema.HTable ( htabulateA, hfield )

32−import Rel8.Table ( Table, toColumns )

33−import Rel8.Table.Name ( namesFromLabels )

34−import Rel8.Table.Opaleye ( castTable )

15+import Rel8.Statement.Select ( ppSelect )

16+import Rel8.Table ( Table )

3517

3618

37−-- | Convert a query to a 'String' containing the query as a @SELECT@

38−-- statement.

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

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

40−showQuery = fold . sqlForQuery

41−

42−

43−sqlForQuery :: Table Expr a

44− => Query a -> Maybe String

45−sqlForQuery = sqlForQueryWithNames namesFromLabels . fmap toColumns

46−

47−

48−sqlForQueryWithNames :: Selects names exprs

49− => names -> Query exprs -> Maybe String

50−sqlForQueryWithNames names query =

51− show . Opaleye.ppSql . selectFrom names exprs <$> optimize primQuery

52− where

53− (exprs, primQuery, _) =

54− Opaleye.runSimpleQueryArrStart (toOpaleye query) ()

55−

56−

57−optimize :: Opaleye.PrimQuery' a -> Maybe (Opaleye.PrimQuery' Void)

58−optimize = Opaleye.removeEmpty . Opaleye.optimize

59−

60−

61−selectFrom :: Selects names exprs

62− => names -> exprs -> Opaleye.PrimQuery' Void -> Opaleye.Select

63−selectFrom (toColumns -> names) (toColumns . castTable -> exprs) query =

64− Opaleye.SelectFrom $ Opaleye.newSelect

65− { Opaleye.attrs = Opaleye.SelectAttrs attributes

66− , Opaleye.tables = Opaleye.oneTable select

67− }

68− where

69− select = Opaleye.foldPrimQuery Opaleye.sqlQueryGenerator query

70− attributes = getConst $ htabulateA $ \field -> case hfield names field of

71− N (Name name) -> case hfield exprs field of

72− E (toPrimExpr -> expr) -> Const (pure (makeAttr name expr))

73− makeAttr label expr =

74− (Opaleye.sqlExpr expr, Just (Opaleye.SqlColumn label))

21+showQuery = show . ppSelect

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

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

2323

2424

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

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

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

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

2828union = zipOpaleyeWith (Opaleye.unionExplicit binaryspec)

2929

3030

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

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

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

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

3434unionAll = zipOpaleyeWith (Opaleye.unionAllExplicit binaryspec)

3535

3636

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

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

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

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

4040intersect = zipOpaleyeWith (Opaleye.intersectExplicit binaryspec)

4141

4242

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

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

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

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

4646intersectAll = zipOpaleyeWith (Opaleye.intersectAllExplicit binaryspec)

4747

4848

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

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

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

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

5252except = zipOpaleyeWith (Opaleye.exceptExplicit binaryspec)

5353

5454

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

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

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

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

5858exceptAll = zipOpaleyeWith (Opaleye.exceptAllExplicit binaryspec)

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

@@ -25,7 +25,7 @@ import qualified Opaleye.Internal.QueryArr as Opaleye

2525import qualified Opaleye.Internal.Tag as Opaleye

2626

2727-- rel8

28−import Rel8.Expr ( Col( E ), Expr )

28+import Rel8.Expr ( Expr )

2929import Rel8.Expr.Bool ( boolExpr, not_ )

3030import Rel8.Expr.Eq ( (==.) )

3131import Rel8.Expr.Opaleye ( toPrimExpr, traversePrimExpr )

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

4848alignBy :: ()

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

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

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

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

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

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

5353 where

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

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

56− MaybeTable (E hasHere) a = ma

57− MaybeTable (E hasThere) b = mb

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

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

56+ MaybeTable hasHere a = ma

57+ MaybeTable hasThere b = mb

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

5959 traversePrimExpr (Opaleye.extractAttr "hasHere" tag'') hasHere

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

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

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

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

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

6464 where

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

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

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

68− ma' = MaybeTable (E hasHere') a

69− mb' = MaybeTable (E hasThere') b

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

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

68+ ma' = MaybeTable hasHere' a

69+ mb' = MaybeTable hasThere' b

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

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

71+ join' = Opaleye.aProduct join

7272

7373

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

@@ -120,7 +120,7 @@ keepThoseTable t@(TheseTable (MaybeTable _ a) (MaybeTable _ b)) = do

120120loseThoseTable :: TheseTable Expr a b -> Query (EitherTable Expr a b)

121121loseThoseTable t@(TheseTable (MaybeTable _ a) (MaybeTable _ b)) = do

122122 where_ $ not_ $ isThoseTable t

123− pure $ EitherTable (E tag) a b

123+ pure $ EitherTable tag a b

124124 where

125125 tag = boolExpr (litExpr IsLeft) (litExpr IsRight) (isThatTable t)

126126

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

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

1+module Rel8.Query.Window

2+ ( window

3+ )

4+where

6+-- base

7+import Prelude ()

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

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

1−{-# language DataKinds #-}

2−{-# language StandaloneKindSignatures #-}

3−{-# language TypeFamilies #-}

4−

5−module Rel8.Schema.Context

6− ( Interpretation( Col )

7− , UnCol

8− )

9−where

10−

11−-- base

12−import Data.Kind ( Constraint )

13−import Prelude ()

14−

15−-- rel8

16−import Rel8.Schema.Kind ( Context, HContext )

17−

18−

19−type Interpretation :: Context -> Constraint

20−class Interpretation context where

21− data Col context :: HContext

22−

23−

24−type UnCol :: HContext -> Context

25−type family UnCol context where

26− UnCol (Col context) = context

src/Rel8/Schema/Context/Nullify.hs+38−44

@@ -16,28 +16,26 @@ where

1616

1717-- base

1818import Data.Bool ( bool )

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

1920import Data.Kind ( Constraint, Type )

20−import Data.Monoid ( getFirst )

2121import Prelude hiding ( null )

2222

2323-- opaleye

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

2525

2626-- rel8

27−import Rel8.Aggregate

28− ( Col( A ), Aggregate( Aggregate )

29− , foldInputs, mapInputs

30− )

31−import Rel8.Expr ( Col( E ), Expr )

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

28+import Rel8.Expr ( Expr )

3229import Rel8.Expr.Bool ( boolExpr )

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

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

31+import Rel8.Expr.Opaleye ( fromPrimExpr )

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

33+import Rel8.Schema.Field ( Field )

3634import qualified Rel8.Schema.Kind as K

37−import Rel8.Schema.Name ( Col( N ), Name( Name ) )

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

3836import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ) )

39−import Rel8.Schema.Result ( Col( R ), Result )

40−import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )

37+import Rel8.Schema.Result ( Result )

38+import Rel8.Schema.Spec ( Spec(..) )

4139

4240

4341type Nullifiability :: K.Context -> Type

@@ -66,7 +64,8 @@ instance Nullifiable Name where

6664

6765type NonNullifiability :: K.Context -> Type

6866data NonNullifiability context where

69− NNResult :: NonNullifiability Result

67+ NField :: NonNullifiability (Field table)

68+ NResult :: NonNullifiability Result

7069

7170

7271nullifiableOrNot :: ()

@@ -75,8 +74,9 @@ nullifiableOrNot :: ()

7574nullifiableOrNot = \case

7675 SAggregate -> Right NAggregate

7776 SExpr -> Right NExpr

77+ SField -> Left NField

7878 SName -> Right NName

79− SResult -> Left NNResult

79+ SResult -> Left NResult

8080

8181

8282absurd :: Nullifiability context -> NonNullifiability context -> a

@@ -88,48 +88,42 @@ absurd = \case

8888

8989guarder :: ()

9090 => SContext context

91− -> Col context ('Spec tag)

91+ -> context tag

9292 -> (tag -> Bool)

9393 -> (Expr tag -> Expr Bool)

94− -> Col context ('Spec (Maybe a))

95− -> Col context ('Spec (Maybe a))

96−guarder SAggregate (A tag) _ isNonNull (A (Aggregate a)) =

97− A $

98− mapInputs (toPrimExpr . run . fromPrimExpr) $

99− Aggregate $

100− run <$> a

101− where

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

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

104−guarder SExpr (E tag) _ isNonNull (E a) = E $ sguard condition a

105− where

106− condition = isNonNull tag

107−guarder SName _ _ _ name = name

108−guarder SResult (R tag) isNonNull _ (R a) = R (bool Nothing a condition)

109− where

110− condition = isNonNull tag

94+ -> context (Maybe a)

95+ -> context (Maybe a)

96+guarder = \case

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

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

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

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

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

102+ Identity (bool Nothing a (isNonNull tag))

111103

112104

113105nullifier :: ()

114106 => Nullifiability context

115− -> SSpec ('Spec a)

116− -> Col context ('Spec a)

117− -> Col context ('Spec (Nullify a))

118−nullifier NAggregate SSpec {nullity} (A (Aggregate a)) =

119− A $ Aggregate $ snullify nullity <$> a

120−nullifier NExpr SSpec {nullity} (E a) = E $ snullify nullity a

121−nullifier NName _ (N (Name a)) = N $ Name a

107+ -> Spec a

108+ -> context a

109+ -> context (Nullify a)

110+nullifier = \case

111+ NAggregate -> \Spec {nullity} (Aggregate a) ->

112+ Aggregate $ snullify nullity <$> a

113+ NExpr -> \Spec {nullity} a -> snullify nullity a

114+ NName -> \_ (Name a) -> Name a

122115

123116

124117unnullifier :: ()

125118 => Nullifiability context

126− -> SSpec ('Spec a)

127− -> Col context ('Spec (Nullify a))

128− -> Col context ('Spec a)

129−unnullifier NAggregate SSpec {nullity} (A (Aggregate a)) =

130− A $ Aggregate $ sunnullify nullity <$> a

131−unnullifier NExpr SSpec {nullity} (E a) = E $ sunnullify nullity a

132−unnullifier NName _ (N (Name a)) = N $ Name a

119+ -> Spec a

120+ -> context (Nullify a)

121+ -> context a

122+unnullifier = \case

123+ NAggregate -> \Spec {nullity} (Aggregate a) ->

124+ Aggregate $ sunnullify nullity <$> a

125+ NExpr -> \Spec {nullity} a -> sunnullify nullity a

126+ NName -> \_ (Name a) -> Name a

133127

134128

135129sguard :: Expr Bool -> Expr (Maybe a) -> Expr (Maybe a)

src/Rel8/Schema/Context/Virtual.hsdeleted−70

@@ -1,70 +0,0 @@

1−{-# language EmptyCase #-}

2−{-# language DataKinds #-}

3−{-# language GADTs #-}

4−{-# language LambdaCase #-}

5−{-# language StandaloneKindSignatures #-}

6−{-# language TypeFamilies #-}

7−

8−module Rel8.Schema.Context.Virtual

9− ( Virtual, virtual

10− , Abstract(..), Concrete(..), abstractOrConcrete, absurd

11− )

12−where

13−

14−-- base

15−import Data.Kind ( Constraint, Type )

16−import Prelude

17−

18−-- rel8

19−import Rel8.Aggregate ( Aggregate )

20−import Rel8.Expr ( Expr )

21−import Rel8.Kind.Context ( SContext(..) )

22−import qualified Rel8.Schema.Kind as K

23−import Rel8.Schema.Name ( Name )

24−import Rel8.Schema.Result ( Result )

25−

26−

27−type Virtual :: K.Context -> Constraint

28−class Virtual context where

29− virtual :: Abstract context

30−

31−

32−instance Virtual Aggregate where

33− virtual = VAggregate

34−

35−

36−instance Virtual Expr where

37− virtual = VExpr

38−

39−

40−instance Virtual Name where

41− virtual = VName

42−

43−

44−type Abstract :: K.Context -> Type

45−data Abstract context where

46− VAggregate :: Abstract Aggregate

47− VExpr :: Abstract Expr

48− VName :: Abstract Name

49−

50−

51−type Concrete :: K.Context -> Type

52−data Concrete context where

53− VResult :: Concrete Result

54−

55−

56−abstractOrConcrete :: ()

57− => SContext context

58− -> Either (Concrete context) (Abstract context)

59−abstractOrConcrete = \case

60− SAggregate -> Right VAggregate

61− SExpr -> Right VExpr

62− SName -> Right VName

63− SResult -> Left VResult

64−

65−

66−absurd :: Abstract context -> Concrete context -> a

67−absurd = \case

68− VAggregate -> \case

69− VExpr -> \case

70− VName -> \case

src/Rel8/Schema/Field.hsnew file+50

@@ -0,0 +1,50 @@

1+{-# language DataKinds #-}

2+{-# language FlexibleContexts #-}

3+{-# language MultiParamTypeClasses #-}

4+{-# language StandaloneKindSignatures #-}

5+{-# language TypeFamilies #-}

7+module Rel8.Schema.Field

8+ ( Field(..)

9+ , fields

10+ )

11+where

12+

13+-- base

14+import Data.Functor.Identity ( Identity( Identity ) )

15+import Data.Kind ( Type )

16+import Prelude

17+

18+-- rel8

19+import Rel8.Schema.HTable ( HField, htabulate )

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

21+import Rel8.Schema.Kind as K

22+import Rel8.Schema.Null ( Sql )

23+import Rel8.Table

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

25+ , FromExprs, fromResult, toResult

26+ , Transpose

27+ )

28+import Rel8.Table.Transpose ( Transposes )

29+import Rel8.Type ( DBType )

30+

31+

32+-- | A special context used in the construction of 'Rel8.Projection's.

33+type Field :: Type -> K.Context

34+newtype Field table a = Field (HField (Columns table) a)

35+

36+

37+instance Sql DBType a => Table (Field table) (Field table a) where

38+ type Columns (Field table a) = HIdentity a

39+ type Context (Field table a) = Field table

40+ type FromExprs (Field table a) = a

41+ type Transpose to (Field table a) = to a

42+

43+ toColumns = HIdentity

44+ fromColumns (HIdentity a) = a

45+ toResult a = HIdentity (Identity a)

46+ fromResult (HIdentity (Identity a)) = a

47+

48+

49+fields :: Transposes context (Field table) table fields => fields

50+fields = fromColumns $ htabulate Field

src/Rel8/Schema/HTable.hs+51−24

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

1616module Rel8.Schema.HTable

1717 ( HTable (HField, HConstrainTable)

1818 , hfield, htabulate, htraverse, hdicts, hspecs

19− , hmap, htabulateA

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

2020 )

2121where

2222

2323-- base

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

2425import Data.Kind ( Constraint, Type )

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

2627import Data.Proxy ( Proxy )

@@ -32,16 +33,21 @@ import GHC.Generics

3233 )

3334import Prelude

3435

36+-- profunctors

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

38+

39+-- product-profunctors

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

41+

3542-- rel8

3643import Rel8.Schema.Dict ( Dict )

37−import Rel8.Schema.Spec ( Spec, SSpec )

44+import Rel8.Schema.Spec ( Spec )

3845import Rel8.Schema.HTable.Product ( HProduct( HProduct ) )

3946import qualified Rel8.Schema.Kind as K

4047

4148-- semigroupoids

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

4350

44−

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

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

4753-- specified ('hspecs').

@@ -50,14 +56,14 @@ import Data.Functor.Apply ( Apply, (<.>) )

5056-- instances yourself or specify this constraint.

5157type HTable :: K.HTable -> Constraint

5258class HTable t where

53− type HField t = (field :: Spec -> Type) | field -> t

54− type HConstrainTable t (c :: Spec -> Constraint) :: Constraint

59+ type HField t = (field :: Type -> Type) | field -> t

60+ type HConstrainTable t (c :: Type -> Constraint) :: Constraint

5561

56− hfield :: t context -> HField t spec -> context spec

57− htabulate :: (forall spec. HField t spec -> context spec) -> t context

58− htraverse :: Apply m => (forall spec. f spec -> m (g spec)) -> t f -> m (t g)

62+ hfield :: t context -> HField t a -> context a

63+ htabulate :: (forall a. HField t a -> context a) -> t context

64+ htraverse :: Apply m => (forall a. f a -> m (g a)) -> t f -> m (t g)

5965 hdicts :: HConstrainTable t c => t (Dict c)

60− hspecs :: t SSpec

66+ hspecs :: t Spec

6167

6268 type HField t = GHField t

6369 type HConstrainTable t c = HConstrainTable (GHColumns (Rep (t Proxy))) c

@@ -68,7 +74,7 @@ class HTable t where

6874 , HField (GHColumns (Rep (t Proxy))) ~ HField (GHColumns (Rep (t context)))

6975 , GHTable context (Rep (t context))

7076 )

71− => t context -> HField t spec -> context spec

77+ => t context -> HField t a -> context a

7278 hfield table (GHField field) = hfield (toGHColumns (from table)) field

7379

7480 default htabulate ::

@@ -77,7 +83,7 @@ class HTable t where

7783 , HField (GHColumns (Rep (t Proxy))) ~ HField (GHColumns (Rep (t context)))

7884 , GHTable context (Rep (t context))

7985 )

80− => (forall spec. HField t spec -> context spec) -> t context

86+ => (forall a. HField t a -> context a) -> t context

8187 htabulate f = to $ fromGHColumns $ htabulate (f . GHField)

8288

8389 default htraverse

@@ -87,7 +93,7 @@ class HTable t where

8793 , Generic (t g), GHTable g (Rep (t g))

8894 , GHColumns (Rep (t f)) ~ GHColumns (Rep (t g))

8995 )

90− => (forall spec. f spec -> m (g spec)) -> t f -> m (t g)

96+ => (forall a. f a -> m (g a)) -> t f -> m (t g)

9197 htraverse f = fmap (to . fromGHColumns) . htraverse f . toGHColumns . from

9298

9399 default hdicts

@@ -101,10 +107,10 @@ class HTable t where

101107 hdicts = to $ fromGHColumns (hdicts @(GHColumns (Rep (t Proxy))) @c)

102108

103109 default hspecs ::

104− ( Generic (t SSpec)

105− , GHTable SSpec (Rep (t SSpec))

110+ ( Generic (t Spec)

111+ , GHTable Spec (Rep (t Spec))

106112 )

107− => t SSpec

113+ => t Spec

108114 hspecs = to $ fromGHColumns hspecs

109115

110116 {-# INLINABLE hfield #-}

@@ -114,22 +120,43 @@ class HTable t where

114120 {-# INLINABLE hspecs #-}

115121

116122

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+

117128hmap :: HTable t

118− => (forall spec. context spec -> context' spec) -> t context -> t context'

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

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

120131

121132

122133htabulateA :: (HTable t, Apply m)

123− => (forall spec. HField t spec -> m (context spec)) -> m (t context)

134+ => (forall a. HField t a -> m (context a)) -> m (t context)

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

125136{-# INLINABLE htabulateA #-}

126137

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)

127154

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

129−newtype GHField t spec = GHField (HField (GHColumns (Rep (t Proxy))) spec)

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

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

130157

131158

132−type GHTable :: K.HContext -> (Type -> Type) -> Constraint

159+type GHTable :: K.Context -> (Type -> Type) -> Constraint

133160class HTable (GHColumns rep) => GHTable context rep | rep -> context where

134161 type GHColumns rep :: K.HTable

135162 toGHColumns :: rep x -> GHColumns rep context

@@ -155,10 +182,10 @@ instance (GHTable context a, GHTable context b) => GHTable context (a :*: b) whe

155182

156183

157184-- | A HField type for indexing into HProduct.

158−type HProductField :: K.HTable -> K.HTable -> Spec -> Type

159−data HProductField x y spec

160− = HFst (HField x spec)

161− | HSnd (HField y spec)

185+type HProductField :: K.HTable -> K.HTable -> Type -> Type

186+data HProductField x y a

187+ = HFst (HField x a)

188+ | HSnd (HField y a)

162189

163190

164191instance (HTable x, HTable y) => HTable (HProduct x y) where

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

@@ -15,7 +15,7 @@ import Prelude ()

1515

1616-- rel8

1717import Rel8.Schema.HTable ( HTable )

18−import Rel8.Schema.HTable.Identity ( HType )

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

1919import Rel8.Schema.HTable.Label ( HLabel )

2020import Rel8.Schema.HTable.Nullify ( HNullify )

2121import qualified Rel8.Schema.Kind as K

@@ -24,7 +24,7 @@ import Rel8.Type.Tag ( EitherTag )

2424

2525type HEitherTable :: K.HTable -> K.HTable -> K.HTable

2626data HEitherTable left right context = HEitherTable

27− { htag :: HLabel "isRight" (HType EitherTag) context

27+ { htag :: HLabel "isRight" (HIdentity EitherTag) context

2828 , hleft :: HLabel "Left" (HNullify left) context

2929 , hright :: HLabel "Right" (HNullify right) context

3030 }

src/Rel8/Schema/HTable/Identity.hs+16−28

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

11{-# language DataKinds #-}

2−{-# language GADTs #-}

3−{-# language PatternSynonyms #-}

2+{-# language FlexibleContexts #-}

43{-# language StandaloneKindSignatures #-}

54{-# language TypeFamilies #-}

5+{-# language UndecidableInstances #-}

77module Rel8.Schema.HTable.Identity

8− ( HIdentity( HIdentity, HType, unHIdentity )

9− , HType

8+ ( HIdentity( HIdentity, unHIdentity )

109 )

1110where

1211

1312-- base

1413import Data.Kind ( Type )

14+import Data.Type.Equality ( (:~:)( Refl ) )

1515import Prelude

1616

1717-- rel8

@@ -21,35 +21,23 @@ import Rel8.Schema.HTable

2121 , hfield, htabulate, htraverse, hdicts, hspecs

2222 )

2323import qualified Rel8.Schema.Kind as K

24−import Rel8.Schema.Spec ( Spec( Spec ), KnownSpec, specSing )

24+import Rel8.Schema.Null ( Sql )

25+import Rel8.Schema.Spec ( specification )

26+import Rel8.Type ( DBType )

2527

2628

27−type HType :: Type -> K.HTable

28−type HType a = HIdentity ('Spec a)

29−

30−

31−pattern HType :: context ('Spec a) -> HType a context

32−pattern HType a = HIdentity a

33−{-# COMPLETE HType #-}

34−

35−

36−type HIdentity :: Spec -> K.HTable

37−newtype HIdentity spec context = HIdentity

38− { unHIdentity :: context spec

29+type HIdentity :: Type -> K.HTable

30+newtype HIdentity a context = HIdentity

31+ { unHIdentity :: context a

3932 }

4033

4134

42−type HIdentityField :: Spec -> Spec -> Type

43−data HIdentityField _spec spec where

44− HIdentityField :: HIdentityField spec spec

45−

46−

47−instance KnownSpec spec => HTable (HIdentity spec) where

48− type HConstrainTable (HIdentity spec) c = c spec

49− type HField (HIdentity spec) = HIdentityField spec

35+instance Sql DBType a => HTable (HIdentity a) where

36+ type HConstrainTable (HIdentity a) constraint = constraint a

37+ type HField (HIdentity a) = (:~:) a

5038

51− hfield (HIdentity a) HIdentityField = a

52− htabulate f = HIdentity $ f HIdentityField

39+ hfield (HIdentity a) Refl = a

40+ htabulate f = HIdentity $ f Refl

5341 htraverse f (HIdentity a) = HIdentity <$> f a

5442 hdicts = HIdentity Dict

55− hspecs = HIdentity specSing

43+ hspecs = HIdentity specification

src/Rel8/Schema/HTable/Label.hs+15−4

@@ -1,4 +1,5 @@

11{-# language DataKinds #-}

2+{-# language RankNTypes #-}

23{-# language RecordWildCards #-}

34{-# language ScopedTypeVariables #-}

45{-# language StandaloneKindSignatures #-}

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

89module Rel8.Schema.HTable.Label

910 ( HLabel, hlabel, hrelabel, hunlabel

11+ , hproject

1012 )

1113where

1214

@@ -18,16 +20,19 @@ import Prelude

1820

1921-- rel8

2022import Rel8.Schema.HTable

23+ ( HTable, HConstrainTable, HField

24+ , htabulate, hfield, htraverse, hdicts, hspecs

25+ )

2126import qualified Rel8.Schema.Kind as K

22−import Rel8.Schema.Spec ( Spec, SSpec(..) )

27+import Rel8.Schema.Spec ( Spec(..) )

2328

2429

2530type HLabel :: Symbol -> K.HTable -> K.HTable

2631newtype HLabel label table context = HLabel (table context)

2732

2833

29−type HLabelField :: Symbol -> K.HTable -> Spec -> Type

30−newtype HLabelField label table spec = HLabelField (HField table spec)

34+type HLabelField :: Symbol -> K.HTable -> Type -> Type

35+newtype HLabelField label table a = HLabelField (HField table a)

3136

3237

3338instance (HTable table, KnownSymbol label) => HTable (HLabel label table) where

@@ -40,7 +45,7 @@ instance (HTable table, KnownSymbol label) => HTable (HLabel label table) where

4045 htraverse f (HLabel a) = HLabel <$> htraverse f a

4146 hdicts = HLabel (hdicts @table)

4247 hspecs = HLabel $ htabulate $ \field -> case hfield (hspecs @table) field of

43− SSpec {..} -> SSpec {labels = symbolVal (Proxy @label) : labels, ..}

48+ Spec {..} -> Spec {labels = symbolVal (Proxy @label) : labels, ..}

4449 {-# INLINABLE hspecs #-}

4550

4651

@@ -57,3 +62,9 @@ hrelabel = hlabel . hunlabel

5762hunlabel :: forall label t context. HLabel label t context -> t context

5863hunlabel (HLabel a) = a

5964{-# INLINABLE hunlabel #-}

65+

66+

67+hproject :: ()

68+ => (forall ctx. t ctx -> t' ctx)

69+ -> HLabel label t context -> HLabel label t' context

70+hproject f (HLabel a) = HLabel (f a)

src/Rel8/Schema/HTable/MapTable.hs+22−12

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

66{-# language GADTs #-}

77{-# language InstanceSigs #-}

88{-# language MultiParamTypeClasses #-}

9−{-# language PolyKinds #-}

9+{-# language RankNTypes #-}

1010{-# language ScopedTypeVariables #-}

1111{-# language StandaloneKindSignatures #-}

1212{-# language TypeApplications #-}

@@ -19,34 +19,38 @@ module Rel8.Schema.HTable.MapTable

1919 , MapSpec(..)

2020 , Precompose(..)

2121 , HMapTableField(..)

22+ , hproject

2223 )

2324where

2425

2526-- base

2627import Data.Kind ( Constraint, Type )

27−import Prelude ( ($), (.), (<$>), fmap )

28+import Prelude

2829

2930-- rel8

30−import Rel8.FCF

31+import Rel8.FCF ( Exp, Eval )

3132import Rel8.Schema.HTable

32−import Rel8.Schema.Spec ( Spec, SSpec )

33+ ( HTable, HConstrainTable, HField

34+ , hfield, htabulate, htraverse, hdicts, hspecs

35+ )

36+import Rel8.Schema.Spec ( Spec )

3337import qualified Rel8.Schema.Kind as K

3438import Rel8.Schema.Dict ( Dict( Dict ) )

3539

3640

37−type HMapTable :: (a -> Exp b) -> ((a -> Type) -> Type) -> (b -> Type) -> Type

38−newtype HMapTable f t g = HMapTable

39− { unHMapTable :: t (Precompose f g)

41+type HMapTable :: (Type -> Exp Type) -> K.HTable -> K.HTable

42+newtype HMapTable f t context = HMapTable

43+ { unHMapTable :: t (Precompose f context)

4044 }

4145

4246

43−type Precompose :: (a -> Exp b) -> (b -> Type) -> a -> Type

47+type Precompose :: (Type -> Exp Type) -> K.Context -> K.Context

4448newtype Precompose f g x = Precompose

4549 { precomposed :: g (Eval (f x))

4650 }

4751

4852

49−type HMapTableField :: (Spec -> Exp a) -> K.HTable -> a -> Type

53+type HMapTableField :: (Type -> Exp Type) -> K.HTable -> K.Context

5054data HMapTableField f t x where

5155 HMapTableField :: HField t a -> HMapTableField f t (Eval (f a))

5256

@@ -79,11 +83,17 @@ instance (HTable t, MapSpec f) => HTable (HMapTable f t) where

7983 {-# INLINABLE hspecs #-}

8084

8185

82−type MapSpec :: (Spec -> Exp Spec) -> Constraint

86+type MapSpec :: (Type -> Exp Type) -> Constraint

8387class MapSpec f where

84− mapInfo :: SSpec x -> SSpec (Eval (f x))

88+ mapInfo :: Spec x -> Spec (Eval (f x))

8589

8690

87−type ComposeConstraint :: (a -> Exp b) -> (b -> Constraint) -> a -> Constraint

91+type ComposeConstraint :: (Type -> Exp Type) -> (Type -> Constraint) -> Type -> Constraint

8892class c (Eval (f a)) => ComposeConstraint f c a

8993instance c (Eval (f a)) => ComposeConstraint f c a

94+

95+

96+hproject :: ()

97+ => (forall ctx. t ctx -> t' ctx)

98+ -> HMapTable f t context -> HMapTable f t' context

99+hproject f (HMapTable a) = HMapTable (f a)

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

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

1515

1616-- rel8

1717import Rel8.Schema.HTable ( HTable )

18−import Rel8.Schema.HTable.Identity ( HType )

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

1919import Rel8.Schema.HTable.Label ( HLabel )

2020import Rel8.Schema.HTable.Nullify ( HNullify )

2121import qualified Rel8.Schema.Kind as K

@@ -24,7 +24,7 @@ import Rel8.Type.Tag ( MaybeTag )

2424

2525type HMaybeTable :: K.HTable -> K.HTable

2626data HMaybeTable table context = HMaybeTable

27− { htag :: HLabel "isJust" (HType (Maybe MaybeTag)) context

27+ { htag :: HLabel "isJust" (HIdentity (Maybe MaybeTag)) context

2828 , hjust :: HLabel "Just" (HNullify table) context

2929 }

3030 deriving stock Generic

src/Rel8/Schema/HTable/Nullify.hs+22−24

@@ -23,10 +23,12 @@ module Rel8.Schema.HTable.Nullify

2323 , hnulls

2424 , hnullify

2525 , hunnullify

26+ , hproject

2627 )

2728where

2829

2930-- base

31+import Data.Kind ( Type )

3032import GHC.Generics ( Generic )

3133import Prelude hiding ( null )

3234

@@ -37,10 +39,11 @@ import Rel8.Schema.HTable.MapTable

3739 ( HMapTable, HMapTableField( HMapTableField )

3840 , MapSpec, mapInfo

3941 )

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

4043import qualified Rel8.Schema.Kind as K

4144import Rel8.Schema.Null ( Nullity( Null, NotNull ) )

4245import qualified Rel8.Schema.Null as Type ( Nullify )

43−import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )

46+import Rel8.Schema.Spec ( Spec(..) )

4447

4548-- semigroupoids

4649import Data.Functor.Apply ( Apply )

@@ -52,17 +55,14 @@ newtype HNullify table context = HNullify (HMapTable Nullify table context)

5255 deriving anyclass HTable

5356

5457

55−-- | Transform a 'Spec' by allowing it to be @null@.

56−data Nullify :: Spec -> Exp Spec

57−

58−

59−type instance Eval (Nullify ('Spec a)) =

60− 'Spec (Type.Nullify a)

58+-- | Transform a 'Type' by allowing it to be @null@.

59+data Nullify :: Type -> Exp Type

60+type instance Eval (Nullify a) = Type.Nullify a

6161

6262

6363instance MapSpec Nullify where

6464 mapInfo = \case

65− SSpec {nullity, ..} -> SSpec

65+ Spec {nullity, ..} -> Spec

6666 { nullity = case nullity of

6767 Null -> Null

6868 NotNull -> Null

@@ -71,49 +71,47 @@ instance MapSpec Nullify where

7171

7272

7373hguard :: HTable t

74− => (forall a. context ('Spec (Maybe a)) -> context ('Spec (Maybe a)))

74+ => (forall a. context (Maybe a) -> context (Maybe a))

7575 -> HNullify t context -> HNullify t context

7676hguard guarder (HNullify as) = HNullify $ htabulate $ \(HMapTableField field) ->

7777 case hfield hspecs field of

78− SSpec {nullity} -> case hfield as (HMapTableField field) of

78+ Spec {nullity} -> case hfield as (HMapTableField field) of

7979 a -> case nullity of

8080 Null -> guarder a

8181 NotNull -> guarder a

8282

8383

8484hnulls :: HTable t

85− => (forall a. ()

86− => SSpec ('Spec a)

87− -> context ('Spec (Type.Nullify a)))

85+ => (forall a. Spec a -> context (Type.Nullify a))

8886 -> HNullify t context

8987hnulls null = HNullify $ htabulate $ \(HMapTableField field) ->

9088 case hfield hspecs field of

91− spec@SSpec {} -> null spec

89+ spec@Spec {} -> null spec

9290{-# INLINABLE hnulls #-}

9391

9492

9593hnullify :: HTable t

96− => (forall a. ()

97− => SSpec ('Spec a)

98− -> context ('Spec a)

99− -> context ('Spec (Type.Nullify a)))

94+ => (forall a. Spec a -> context a -> context (Type.Nullify a))

10095 -> t context

10196 -> HNullify t context

10297hnullify nullifier a = HNullify $ htabulate $ \(HMapTableField field) ->

10398 case hfield hspecs field of

104− spec@SSpec {} -> nullifier spec (hfield a field)

99+ spec@Spec {} -> nullifier spec (hfield a field)

105100{-# INLINABLE hnullify #-}

106101

107102

108103hunnullify :: (HTable t, Apply m)

109− => (forall a. ()

110− => SSpec ('Spec a)

111− -> context ('Spec (Type.Nullify a))

112− -> m (context ('Spec a)))

104+ => (forall a. Spec a -> context (Type.Nullify a) -> m (context a))

113105 -> HNullify t context

114106 -> m (t context)

115107hunnullify unnullifier (HNullify as) =

116108 htabulateA $ \field -> case hfield hspecs field of

117− spec@SSpec {} -> case hfield as (HMapTableField field) of

109+ spec@Spec {} -> case hfield as (HMapTableField field) of

118110 a -> unnullifier spec a

119111{-# INLINABLE hunnullify #-}

112+

113+

114+hproject :: ()

115+ => (forall ctx. t ctx -> t' ctx)

116+ -> HNullify t context -> HNullify t' context

117+hproject f (HNullify a) = HNullify (HMapTable.hproject f a)

src/Rel8/Schema/HTable/These.hs+3−3

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

1515

1616-- rel8

1717import Rel8.Schema.HTable ( HTable )

18−import Rel8.Schema.HTable.Identity ( HType )

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

1919import Rel8.Schema.HTable.Label ( HLabel )

2020import Rel8.Schema.HTable.Nullify ( HNullify )

2121import qualified Rel8.Schema.Kind as K

@@ -24,9 +24,9 @@ import Rel8.Type.Tag ( MaybeTag )

2424

2525type HTheseTable :: K.HTable -> K.HTable -> K.HTable

2626data HTheseTable here there context = HTheseTable

27− { hhereTag :: HLabel "hereTag" (HType (Maybe MaybeTag)) context

27+ { hhereTag :: HLabel "hereTag" (HIdentity (Maybe MaybeTag)) context

2828 , hhere :: HLabel "Here" (HNullify here) context

29− , hthereTag :: HLabel "thereTag" (HType (Maybe MaybeTag)) context

29+ , hthereTag :: HLabel "thereTag" (HIdentity (Maybe MaybeTag)) context

3030 , hthere :: HLabel "There" (HNullify there) context

3131 }

3232 deriving stock Generic

src/Rel8/Schema/HTable/Vectorize.hs+39−40

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

99{-# language GADTs #-}

1010{-# language LambdaCase #-}

1111{-# language MultiParamTypeClasses #-}

12−{-# language NamedFieldPuns #-}

1312{-# language RankNTypes #-}

1413{-# language RecordWildCards #-}

1514{-# language ScopedTypeVariables #-}

@@ -22,33 +21,39 @@ module Rel8.Schema.HTable.Vectorize

2221 ( HVectorize

2322 , hvectorize, hunvectorize

2423 , happend, hempty

24+ , hproject

25+ , hcolumn

2526 )

2627where

2728

2829-- base

29−import Data.Kind ( Type )

30+import Data.Kind ( Constraint, Type )

3031import Data.List.NonEmpty ( NonEmpty )

32+import GHC.Generics (Generic)

3133import Prelude

3234

3335-- rel8

36+import Rel8.FCF ( Eval, Exp )

3437import Rel8.Schema.Dict ( Dict( Dict ) )

3538import qualified Rel8.Schema.Kind as K

36−import Rel8.Schema.HTable

37− ( HTable

38− , hfield, htabulate, htabulateA, hspecs

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

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

41+import Rel8.Schema.HTable.MapTable

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

43+ , MapSpec, mapInfo

44+ , Precompose( Precompose )

3945 )

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

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

41−import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )

48+import Rel8.Schema.Spec ( Spec(..) )

4249import Rel8.Type.Array ( listTypeInformation, nonEmptyTypeInformation )

4350import Rel8.Type.Information ( TypeInformation )

4451

4552-- semialign

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

47−import Rel8.FCF

48−import Rel8.Schema.HTable.MapTable

49−import GHC.Generics (Generic)

5054

5155

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

5257class Vector list where

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

5459 vectorTypeInformation :: ()

@@ -73,16 +78,16 @@ newtype HVectorize list table context = HVectorize (HMapTable (Vectorize list) t

7378 deriving anyclass HTable

7479

7580

76−data Vectorize :: (Type -> Type) -> Spec -> Exp Spec

81+data Vectorize :: (Type -> Type) -> Type -> Exp Type

7782

7883

79−type instance Eval (Vectorize list ('Spec a)) = 'Spec (list a)

84+type instance Eval (Vectorize list a) = list a

8085

8186

8287instance Vector list => MapSpec (Vectorize list) where

8388 mapInfo = \case

84− SSpec {..} -> case listNotNull @list nullity of

85− Dict -> SSpec

89+ Spec {..} -> case listNotNull @list nullity of

90+ Dict -> Spec

8691 { nullity = NotNull

8792 , info = vectorTypeInformation nullity info

8893 , ..

@@ -90,55 +95,49 @@ instance Vector list => MapSpec (Vectorize list) where

9095

9196

9297hvectorize :: (HTable t, Unzip f, Vector list)

93− => (forall a. ()

94− => SSpec ('Spec a)

95− -> f (context ('Spec a))

96− -> context' ('Spec (list a)))

98+ => (forall a. Spec a -> f (context a) -> context' (list a))

9799 -> f (t context)

98100 -> HVectorize list t context'

99101hvectorize vectorizer as = HVectorize $ htabulate $ \(HMapTableField field) ->

100102 case hfield hspecs field of

101− spec@SSpec {} -> vectorizer spec (fmap (`hfield` field) as)

103+ spec -> vectorizer spec (fmap (`hfield` field) as)

102104{-# INLINABLE hvectorize #-}

103105

104106

105107hunvectorize :: (HTable t, Zip f, Vector list)

106− => (forall a. ()

107− => SSpec ('Spec a)

108− -> context ('Spec (list a))

109− -> f (context' ('Spec a)))

108+ => (forall a. Spec a -> context (list a) -> f (context' a))

110109 -> HVectorize list t context

111110 -> f (t context')

112111hunvectorize unvectorizer (HVectorize table) =

113112 getZippy $ htabulateA $ \field -> case hfield hspecs field of

114− spec@SSpec{} -> case hfield table (HMapTableField field) of

113+ spec -> case hfield table (HMapTableField field) of

115114 a -> Zippy (unvectorizer spec a)

116115{-# INLINABLE hunvectorize #-}

117116

118117

119−happend :: (HTable t, Vector list) =>

120− ( forall a. ()

121− => Nullity a

122− -> TypeInformation (Unnullify a)

123− -> context ('Spec (list a))

124− -> context ('Spec (list a))

125− -> context ('Spec (list a))

126− )

118+happend :: (HTable t, Vector list)

119+ => (forall a. Spec a -> context (list a) -> context (list a) -> context (list a))

127120 -> HVectorize list t context

128121 -> HVectorize list t context

129122 -> HVectorize list t context

130123happend append (HVectorize as) (HVectorize bs) = HVectorize $

131124 htabulate $ \field@(HMapTableField j) -> case (hfield as field, hfield bs field) of

132125 (a, b) -> case hfield hspecs j of

133− SSpec {nullity, info} -> append nullity info a b

126+ spec -> append spec a b

134127

135128

136−hempty :: HTable t =>

137− ( forall a. ()

138− => Nullity a

139− -> TypeInformation (Unnullify a)

140− -> context ('Spec [a])

141− )

129+hempty :: HTable t

130+ => (forall a. Spec a -> context [a])

142131 -> HVectorize [] t context

143−hempty empty = HVectorize $ htabulate $ \(HMapTableField field) -> case hfield hspecs field of

144− SSpec {nullity, info} -> empty nullity info

132+hempty empty = HVectorize $ htabulate $ \(HMapTableField field) ->

133+ empty (hfield hspecs field)

134+

135+

136+hproject :: ()

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

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

139+hproject 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/Kind.hs+6−15

@@ -1,8 +1,9 @@

11{-# language StandaloneKindSignatures #-}

33module Rel8.Schema.Kind

4− ( Context, Rel8able

5− , HContext, HTable

4+ ( Rel8able

5+ , Context

6+ , HTable

67 )

78where

@@ -10,23 +11,13 @@ where

1011import Data.Kind ( Type )

1112import Prelude ()

1213

13−-- rel8

14−import Rel8.Schema.Spec ( Spec )

1514

16−

17−type HContext :: Type

18−type HContext = Spec -> Type

15+type Context :: Type

16+type Context = Type -> Type

1917

2018

2119type HTable :: Type

22−type HTable = HContext -> Type

23−

24−

25−data X

26−

27−

28−type Context :: Type

29−type Context = X -> Type

20+type HTable = Context -> Type

3021

3122

3223type Rel8able :: Type

src/Rel8/Schema/Name.hs+31−41

@@ -3,39 +3,44 @@

33{-# language FlexibleContexts #-}

44{-# language FlexibleInstances #-}

55{-# language GADTs #-}

6+{-# language GeneralizedNewtypeDeriving #-}

67{-# language MultiParamTypeClasses #-}

7−{-# language PolyKinds #-}

88{-# language RankNTypes #-}

9−{-# language StandaloneDeriving #-}

109{-# language StandaloneKindSignatures #-}

1110{-# language TypeFamilies #-}

1211{-# language UndecidableInstances #-}

13−{-# language UndecidableSuperClasses #-}

1412

1513module Rel8.Schema.Name

1614 ( Name(..)

17− , Col( N, unN )

1815 , Selects

16+ , ppColumn

1917 )

2018where

2119

2220-- base

21+import Data.Functor.Identity ( Identity( Identity ) )

2322import Data.Kind ( Constraint, Type )

24−import Data.String ( IsString, fromString )

23+import Data.String ( IsString )

2524import Prelude

2625

26+-- opaleye

27+import qualified Opaleye.Internal.HaskellDB.Sql as Opaleye

28+import qualified Opaleye.Internal.HaskellDB.Sql.Print as Opaleye

29+

30+-- pretty

31+import Text.PrettyPrint ( Doc )

32+

2733-- rel8

2834import Rel8.Expr ( Expr )

29−import Rel8.Schema.Context ( Interpretation, Col )

30−import Rel8.Schema.HTable.Identity ( HIdentity( HType ), HType )

35+import qualified Rel8.Schema.Kind as K

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

3137import Rel8.Schema.Null ( Sql )

32−import Rel8.Schema.Result ( Col( R ) )

33−import Rel8.Schema.Spec ( Spec( Spec ) )

3438import Rel8.Table

3539 ( Table, Columns, Context, fromColumns, toColumns

3640 , FromExprs, fromResult, toResult

41+ , Transpose

3742 )

38−import Rel8.Table.Recontextualize ( Recontextualize )

43+import Rel8.Table.Transpose ( Transposes )

3944import Rel8.Type ( DBType )

4045

4146

@@ -43,45 +48,30 @@ import Rel8.Type ( DBType )

4348-- schema definition. You can construct names by using the @OverloadedStrings@

4449-- extension and writing string literals. This is typically done when providing

4550-- a 'TableSchema' value.

46−type Name :: k -> Type

47−data Name a where

48− Name :: k ~ Type => !String -> Name (a :: k)

49−

50−

51−deriving stock instance Show (Name a)

52−

53−

54−instance k ~ Type => IsString (Name (a :: k)) where

55− fromString = Name

51+type Name :: K.Context

52+newtype Name a = Name String

53+ deriving stock Show

54+ deriving newtype IsString

5655

5756

5857instance Sql DBType a => Table Name (Name a) where

59− type Columns (Name a) = HType a

58+ type Columns (Name a) = HIdentity a

6059 type Context (Name a) = Name

6160 type FromExprs (Name a) = a

61+ type Transpose to (Name a) = to a

6262

63− toColumns a = HType (N a)

64− fromColumns (HType (N a)) = a

65− toResult a = HType (R a)

66− fromResult (HType (R a)) = a

67−

68−

69−instance Sql DBType a => Recontextualize Expr Name (Expr a) (Name a)

70−

71−

72−instance Sql DBType a => Recontextualize Name Expr (Name a) (Expr a)

73−

74−

75−instance Sql DBType a => Recontextualize Name Name (Name a) (Name a)

76−

77−

78−instance Interpretation Name where

79− data Col Name _spec where

80− N :: {unN :: !(Name a)} -> Col Name ('Spec a)

63+ toColumns a = HIdentity a

64+ fromColumns (HIdentity a) = a

65+ toResult a = HIdentity (Identity a)

66+ fromResult (HIdentity (Identity a)) = a

8167

8268

8369-- | @Selects a b@ means that @a@ is a schema (i.e., a 'Table' of 'Name's) for

8470-- the 'Expr' columns in @b@.

8571type Selects :: Type -> Type -> Constraint

86−class Recontextualize Name Expr names exprs => Selects names exprs

87−instance Recontextualize Name Expr names exprs => Selects names exprs

72+class Transposes Name Expr names exprs => Selects names exprs

73+instance Transposes Name Expr names exprs => Selects names exprs

74+

75+

76+ppColumn :: String -> Doc

77+ppColumn = Opaleye.ppSqlExpr . Opaleye.ColumnSqlExpr . Opaleye.SqlColumn

src/Rel8/Schema/Result.hs+16−33

@@ -5,20 +5,20 @@

55{-# language TypeFamilies #-}

77module Rel8.Schema.Result

8− ( Col( R, unR ), Result

8+ ( Result

99 , null, nullifier, unnullifier

1010 , vectorizer, unvectorizer

1111 )

1212where

1313

1414-- base

15+import Data.Functor.Identity ( Identity( Identity), runIdentity )

1516import Prelude hiding ( null )

1617

1718-- rel8

18−import Rel8.Schema.Context ( Interpretation( Col ) )

1919import Rel8.Schema.Kind ( Context )

2020import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ) )

21−import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )

21+import Rel8.Schema.Spec ( Spec(..) )

2222

2323

2424-- | The @Result@ context is the context used for decoded query results.

@@ -26,46 +26,29 @@ import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )

2626-- When a query is executed against a PostgreSQL database, Rel8 parses the

2727-- returned rows, decoding each row into the @Result@ context.

2828type Result :: Context

29−data Result a

29+type Result = Identity

3030

3131

32−instance Interpretation Result where

33− data Col Result _spec where

34− R :: {unR :: !a} -> Col Result ('Spec a)

32+null :: Result (Maybe a)

33+null = Identity Nothing

3534

3635

37−null :: Col Result ('Spec (Maybe a))

38−null = R Nothing

39−

40−

41−nullifier :: ()

42− => SSpec ('Spec a)

43− -> Col Result ('Spec a)

44− -> Col Result ('Spec (Nullify a))

45−nullifier SSpec {nullity} (R a) = R $ case nullity of

36+nullifier :: Spec a -> Result a -> Result (Nullify a)

37+nullifier Spec {nullity} (Identity a) = Identity $ case nullity of

4638 Null -> a

4739 NotNull -> Just a

4840

4941

50−unnullifier :: ()

51− => SSpec ('Spec a)

52− -> Col Result ('Spec (Nullify a))

53− -> Maybe (Col Result ('Spec a))

54−unnullifier SSpec {nullity} (R a) =

42+unnullifier :: Spec a -> Result (Nullify a) -> Maybe (Result a)

43+unnullifier Spec {nullity} (Identity a) =

5544 case nullity of

56− Null -> pure $ R a

57− NotNull -> R <$> a

45+ Null -> pure $ Identity a

46+ NotNull -> Identity <$> a

5847

5948

60−vectorizer :: Functor f

61− => SSpec ('Spec a)

62− -> f (Col Result ('Spec a))

63− -> Col Result ('Spec (f a))

64−vectorizer _ = R . fmap unR

49+vectorizer :: Functor f => Spec a -> f (Result a) -> Result (f a)

50+vectorizer _ = Identity . fmap runIdentity

6551

6652

67−unvectorizer :: Functor f

68− => SSpec ('Spec a)

69− -> Col Result ('Spec (f a))

70− -> f (Col Result ('Spec a))

71−unvectorizer _ (R results) = R <$> results

53+unvectorizer :: Functor f => Spec a -> Result (f a) -> f (Result a)

54+unvectorizer _ (Identity results) = Identity <$> results

src/Rel8/Schema/Spec.hs+16−30

@@ -1,18 +1,15 @@

1−{-# language DataKinds #-}

21{-# language FlexibleContexts #-}

3−{-# language GADTs #-}

2+{-# language MonoLocalBinds #-}

43{-# language StandaloneKindSignatures #-}

5−{-# language UndecidableInstances #-}

75module Rel8.Schema.Spec

8− ( Spec( Spec )

9− , SSpec( SSpec, labels, info, nullity )

10− , KnownSpec( specSing )

6+ ( Spec( Spec, labels, info, nullity )

7+ , specification

118 )

129where

1310

1411-- base

15−import Data.Kind ( Constraint, Type )

12+import Data.Kind ( Type )

1613import Prelude

1714

1815-- rel8

@@ -21,28 +18,17 @@ import Rel8.Type ( DBType, typeInformation )

2118import Rel8.Type.Information ( TypeInformation )

2219

2320

24−type Spec :: Type

25−newtype Spec = Spec Type

21+type Spec :: Type -> Type

22+data Spec a = Spec

23+ { labels :: [String]

24+ , info :: TypeInformation (Unnullify a)

25+ , nullity :: Nullity a

26+ }

2627

2728

28−type SSpec :: Spec -> Type

29−data SSpec spec where

30− SSpec ::

31− { labels :: [String]

32− , info :: TypeInformation (Unnullify a)

33− , nullity :: Nullity a

34− }

35− -> SSpec ('Spec a)

36−

37−

38−type KnownSpec :: Spec -> Constraint

39−class KnownSpec spec where

40− specSing :: SSpec spec

41−

42−

43−instance Sql DBType a => KnownSpec ('Spec a) where

44− specSing = SSpec

45− { labels = []

46− , info = typeInformation

47− , nullity = nullable

48− }

29+specification :: Sql DBType a => Spec a

30+specification = Spec

31+ { labels = []

32+ , info = typeInformation

33+ , nullity = nullable

34+ }

src/Rel8/Schema/Spec/Constrain.hsdeleted−32

@@ -1,32 +0,0 @@

1−{-# language ConstraintKinds #-}

2−{-# language DataKinds #-}

3−{-# language FlexibleInstances #-}

4−{-# language MultiParamTypeClasses #-}

5−{-# language StandaloneKindSignatures #-}

6−{-# language TypeFamilies #-}

7−{-# language UndecidableInstances #-}

8−{-# language UndecidableSuperClasses #-}

9−

10−module Rel8.Schema.Spec.Constrain

11− ( ConstrainSpec

12− )

13−where

14−

15−-- base

16−import Data.Kind ( Constraint, Type )

17−import Prelude ()

18−

19−-- rel8

20−import Rel8.Schema.Spec ( Spec( Spec ) )

21−

22−

23−type Unspec :: Spec -> Type

24−type family Unspec spec where

25− Unspec ('Spec a) = a

26−

27−

28−type ConstrainSpec :: (Type -> Constraint) -> Spec -> Constraint

29−class (spec ~ 'Spec (Unspec spec), constraint (Unspec spec)) =>

30− ConstrainSpec constraint spec

31−instance (spec ~ 'Spec (Unspec spec), constraint (Unspec spec)) =>

32− ConstrainSpec constraint spec

src/Rel8/Schema/Table.hs+20

@@ -1,14 +1,26 @@

11{-# language DeriveFunctor #-}

22{-# language DerivingStrategies #-}

3+{-# language DisambiguateRecordFields #-}

4+{-# language NamedFieldPuns #-}

5+{-# language StandaloneKindSignatures #-}

47module Rel8.Schema.Table

58 ( TableSchema(..)

9+ , ppTable

610 )

711where

812

913-- base

14+import Data.Kind ( Type )

1015import Prelude

1116

17+-- opaleye

18+import qualified Opaleye.Internal.HaskellDB.Sql as Opaleye

19+import qualified Opaleye.Internal.HaskellDB.Sql.Print as Opaleye

20+

21+-- pretty

22+import Text.PrettyPrint ( Doc )

23+

1224

1325-- | The schema for a table. This is used to specify the name and schema that a

1426-- table belongs to (the @FROM@ part of a SQL query), along with the schema of

@@ -16,6 +28,7 @@ import Prelude

1628--

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

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

31+type TableSchema :: Type -> Type

1932data TableSchema names = TableSchema

2033 { name :: String

2134 -- ^ The name of the table.

@@ -27,3 +40,10 @@ data TableSchema names = TableSchema

2740 -- data type here, parameterized by the 'Rel8.ColumnSchema.ColumnSchema' functor.

2841 }

2942 deriving stock Functor

43+

44+

45+ppTable :: TableSchema a -> Doc

46+ppTable TableSchema {name, schema} = Opaleye.ppTable Opaleye.SqlTable

47+ { sqlTableSchemaName = schema

48+ , sqlTableName = name

49+ }

src/Rel8/Statement/Delete.hs+35−48

@@ -1,40 +1,37 @@

11{-# language DuplicateRecordFields #-}

22{-# language GADTs #-}

33{-# language NamedFieldPuns #-}

4−{-# language ScopedTypeVariables #-}

4+{-# language RankNTypes #-}

5+{-# language RecordWildCards #-}

56{-# language StandaloneKindSignatures #-}

6−{-# language TypeApplications #-}

7+{-# language StrictData #-}

89module Rel8.Statement.Delete

910 ( Delete(..)

1011 , delete

12+ , ppDelete

1113 )

1214where

1315

1416-- base

15−import Control.Exception ( throwIO )

1617import Data.Kind ( Type )

1718import Prelude

1819

1920-- hasql

20−import Hasql.Connection ( Connection )

21−import qualified Hasql.Decoders as Hasql

2221import qualified Hasql.Encoders as Hasql

23−import qualified Hasql.Session as Hasql

2422import qualified Hasql.Statement as Hasql

2523

26−-- opaleye

27−import qualified Opaleye.Internal.Manipulation as Opaleye

24+-- pretty

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

2826

2927-- rel8

3028import Rel8.Expr ( Expr )

31−import Rel8.Expr.Opaleye ( toColumn, toPrimExpr )

29+import Rel8.Query ( Query )

3230import Rel8.Schema.Name ( Selects )

33−import Rel8.Schema.Table ( TableSchema )

34−import Rel8.Statement.Returning ( Returning( NumberOfRowsAffected, Projection ) )

35−import Rel8.Table ( fromColumns, toColumns )

36−import Rel8.Table.Opaleye ( castTable, table, unpackspec )

37−import Rel8.Table.Serialize ( Serializable, parse )

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

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

33+import Rel8.Statement.Using ( ppUsing )

34+import Rel8.Statement.Where ( ppWhere )

3835

3936-- text

4037import qualified Data.Text as Text

@@ -47,7 +44,10 @@ data Delete a where

4744 Delete :: Selects names exprs =>

4845 { from :: TableSchema names

4946 -- ^ Which table to delete from.

50− , deleteWhere :: exprs -> Expr Bool

47+ , using :: Query using

48+ -- ^ @USING@ clause — this can be used to join against other tables,

49+ -- and its results can be referenced in the @WHERE@ clause

50+ , deleteWhere :: using -> exprs -> Expr Bool

5151 -- ^ Which rows should be selected for deletion.

5252 , returning :: Returning names a

5353 -- ^ What to return from the @DELETE@ statement.

@@ -55,38 +55,25 @@ data Delete a where

5555 -> Delete a

5656

5757

58−-- | Run a @DELETE@ statement.

59−delete :: Connection -> Delete a -> IO a

60−delete c Delete {from, deleteWhere, returning} =

61− case returning of

62− NumberOfRowsAffected -> Hasql.run session c >>= either throwIO pure

63− where

64− session = Hasql.statement () statement

65− statement = Hasql.Statement bytes params decode prepare

66− bytes = encodeUtf8 $ Text.pack sql

67− params = Hasql.noParams

68− decode = Hasql.rowsAffected

69− prepare = False

70− sql = Opaleye.arrangeDeleteSql from' where'

71− where

72− from' = table $ toColumns <$> from

73− where' = toColumn . toPrimExpr . deleteWhere . fromColumns

58+ppDelete :: Delete a -> Doc

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

60+ Nothing ->

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

62+ text "WHERE false"

63+ Just (usingDoc, i) ->

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

65+ usingDoc $$

66+ ppWhere from (deleteWhere i) $$

67+ ppReturning from returning

7468

75− Projection project -> Hasql.run session c >>= either throwIO pure

76− where

77− session = Hasql.statement () statement

78− statement = Hasql.Statement bytes params decode prepare

79− bytes = encodeUtf8 $ Text.pack sql

80− params = Hasql.noParams

81− decode = decoder project

82− prepare = False

83− sql =

84− Opaleye.arrangeDeleteReturningSql unpackspec from' where' project'

85− where

86− from' = table $ toColumns <$> from

87− where' = toColumn . toPrimExpr . deleteWhere . fromColumns

88− project' = castTable . toColumns . project . fromColumns

69+

70+-- | Run a 'Delete' statement.

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

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

8973 where

90− decoder :: forall exprs projection a. Serializable projection a

91− => (exprs -> projection) -> Hasql.Result [a]

92− decoder _ = Hasql.rowList (parse @projection @a)

74+ bytes = encodeUtf8 $ Text.pack sql

75+ params = Hasql.noParams

76+ decode = decodeReturning returning

77+ prepare = False

78+ sql = show doc

79+ doc = ppDelete d

src/Rel8/Statement/Insert.hs+43−72

@@ -1,64 +1,59 @@

11{-# language DuplicateRecordFields #-}

2+{-# language FlexibleContexts #-}

23{-# language GADTs #-}

34{-# language NamedFieldPuns #-}

4−{-# language ScopedTypeVariables #-}

5+{-# language RecordWildCards #-}

56{-# language StandaloneKindSignatures #-}

6−{-# language TypeApplications #-}

7+{-# language StrictData #-}

89module Rel8.Statement.Insert

910 ( Insert(..)

10− , OnConflict(..)

1111 , insert

12+ , ppInsert

13+ , ppInto

1214 )

1315where

1416

1517-- base

16−import Control.Exception ( throwIO )

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

18+import Data.Foldable ( toList )

1819import Data.Kind ( Type )

1920import Prelude

2021

2122-- hasql

22−import Hasql.Connection ( Connection )

23−import qualified Hasql.Decoders as Hasql

2423import qualified Hasql.Encoders as Hasql

25−import qualified Hasql.Session as Hasql

2624import qualified Hasql.Statement as Hasql

2725

2826-- opaleye

29−import qualified Opaleye.Internal.Manipulation as Opaleye

30−import qualified Opaleye.Manipulation as Opaleye

27+import qualified Opaleye.Internal.HaskellDB.Sql.Print as Opaleye

28+

29+-- pretty

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

3131

3232-- rel8

33−import Rel8.Schema.Name ( Selects )

34−import Rel8.Schema.Table ( TableSchema )

35−import Rel8.Statement.Returning ( Returning( Projection, NumberOfRowsAffected ) )

36−import Rel8.Table ( fromColumns, toColumns )

37−import Rel8.Table.Opaleye ( castTable, table, unpackspec )

38−import Rel8.Table.Serialize ( Serializable, parse )

33+import Rel8.Query ( Query )

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

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

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

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

38+import Rel8.Statement.Select ( ppRows )

39+import Rel8.Table ( Table )

40+import Rel8.Table.Name ( showNames )

3941

4042-- text

4143import qualified Data.Text as Text ( pack )

4244import Data.Text.Encoding ( encodeUtf8 )

4345

4446

45−-- | @OnConflict@ allows you to add an @ON CONFLICT@ clause to an @INSERT@

46−-- statement.

47−type OnConflict :: Type

48−data OnConflict

49− = Abort -- ^ @ON CONFLICT ABORT@

50− | DoNothing -- ^ @ON CONFLICT DO NOTHING@

51−

52−

5347-- | The constituent parts of a SQL @INSERT@ statement.

5448type Insert :: Type -> Type

5549data Insert a where

5650 Insert :: Selects names exprs =>

5751 { into :: TableSchema names

5852 -- ^ Which table to insert into.

59− , rows :: [exprs]

60− -- ^ The rows to insert.

61− , onConflict :: OnConflict

53+ , rows :: Query exprs

54+ -- ^ The rows to insert. This can be an arbitrary query — use

55+ -- 'Rel8.values' insert a static list of rows.

56+ , onConflict :: OnConflict names

6257 -- ^ What to do if the inserted rows conflict with data already in the

6358 -- table.

6459 , returning :: Returning names a

@@ -67,52 +62,28 @@ data Insert a where

6762 -> Insert a

6863

6964

70−-- | Run an @INSERT@ statement

71−insert :: Connection -> Insert a -> IO a

72−insert c Insert {into, rows, onConflict, returning} =

73− case (rows, returning) of

74− ([], NumberOfRowsAffected) -> pure 0

75− ([], Projection _) -> pure []

65+ppInsert :: Insert a -> Doc

66+ppInsert Insert {..} =

67+ text "INSERT INTO" <+>

68+ ppInto into $$

69+ ppRows rows $$

70+ ppOnConflict into onConflict $$

71+ ppReturning into returning

7672

77− (x:xs, NumberOfRowsAffected) -> Hasql.run session c >>= either throwIO pure

78− where

79− session = Hasql.statement () statement

80− statement = Hasql.Statement bytes params decode prepare

81− bytes = encodeUtf8 $ Text.pack sql

82− params = Hasql.noParams

83− decode = Hasql.rowsAffected

84− prepare = False

85− sql = Opaleye.arrangeInsertManySql into' rows' onConflict'

86− where

87− into' = table $ toColumns <$> into

88− rows' = toColumns <$> x :| xs

8973

90− (x:xs, Projection project) -> Hasql.run session c >>= either throwIO pure

91− where

92− session = Hasql.statement () statement

93− statement = Hasql.Statement bytes params decode prepare

94− bytes = encodeUtf8 $ Text.pack sql

95− params = Hasql.noParams

96− decode = decoder project

97− prepare = False

98− sql =

99− Opaleye.arrangeInsertManyReturningSql

100− unpackspec

101− into'

102− rows'

103− project'

104− onConflict'

105− where

106− into' = table $ toColumns <$> into

107− rows' = toColumns <$> x :| xs

108− project' = castTable . toColumns . project . fromColumns

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

75+ppInto table@TableSchema {columns} =

76+ ppTable table <+>

77+ parens (Opaleye.commaV ppColumn (toList (showNames columns)))

10978

110− where

111− onConflict' =

112− case onConflict of

113− DoNothing -> Just Opaleye.DoNothing

114− Abort -> Nothing

11579

116− decoder :: forall exprs projection a. Serializable projection a

117− => (exprs -> projection) -> Hasql.Result [a]

118− decoder _ = Hasql.rowList (parse @projection @a)

80+-- | Run an 'Insert' statement.

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

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

83+ where

84+ bytes = encodeUtf8 $ Text.pack sql

85+ params = Hasql.noParams

86+ decode = decodeReturning returning

87+ prepare = False

88+ sql = show doc

89+ doc = ppInsert i

src/Rel8/Statement/OnConflict.hsnew file+106

@@ -0,0 +1,106 @@

1+{-# language DuplicateRecordFields #-}

2+{-# language FlexibleContexts #-}

3+{-# language GADTs #-}

4+{-# language LambdaCase #-}

5+{-# language NamedFieldPuns #-}

6+{-# language RecordWildCards #-}

7+{-# language StandaloneKindSignatures #-}

8+{-# language StrictData #-}

10+module Rel8.Statement.OnConflict

11+ ( OnConflict(..)

12+ , Upsert(..)

13+ , ppOnConflict

14+ )

15+where

16+

17+-- base

18+import Data.Foldable ( toList )

19+import Data.Kind ( Type )

20+import Prelude

21+

22+-- opaleye

23+import qualified Opaleye.Internal.HaskellDB.Sql.Print as Opaleye

24+

25+-- pretty

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

27+

28+-- rel8

29+import Rel8.Expr ( Expr )

30+import Rel8.Schema.Name ( Name, Selects, ppColumn )

31+import Rel8.Schema.Table ( TableSchema(..) )

32+import Rel8.Statement.Set ( ppSet )

33+import Rel8.Statement.Where ( ppWhere )

34+import Rel8.Table ( Table, toColumns )

35+import Rel8.Table.Cols ( Cols( Cols ) )

36+import Rel8.Table.Name ( showNames )

37+import Rel8.Table.Opaleye ( attributes )

38+import Rel8.Table.Projection ( Projecting, Projection, apply )

39+

40+

41+-- | 'OnConflict' represents the @ON CONFLICT@ clause of an @INSERT@

42+-- statement. This specifies what ought to happen when one or more of the

43+-- rows proposed for insertion conflict with an existing row in the table.

44+type OnConflict :: Type -> Type

45+data OnConflict names

46+ = Abort

47+ -- ^ Abort the transaction if there are conflicting rows (Postgres' default)

48+ | DoNothing

49+ -- ^ @ON CONFLICT DO NOTHING@

50+ | DoUpdate (Upsert names)

51+ -- ^ @ON CONFLICT DO UPDATE@

52+

53+

54+-- | The @ON CONFLICT (...) DO UPDATE@ clause of an @INSERT@ statement, also

55+-- known as \"upsert\".

56+--

57+-- When an existing row conflicts with a row proposed for insertion,

58+-- @ON CONFLICT DO UPDATE@ allows you to instead update this existing row. The

59+-- conflicting row proposed for insertion is then \"excluded\", but its values

60+-- can still be referenced from the @SET@ and @WHERE@ clauses of the @UPDATE@

61+-- statement.

62+--

63+-- Upsert in Postgres requires an explicit set of \"conflict targets\" — the

64+-- set of columns comprising the @UNIQUE@ index from conflicts with which we

65+-- would like to recover.

66+type Upsert :: Type -> Type

67+data Upsert names where

68+ Upsert :: (Selects names exprs, Projecting names index, excluded ~ exprs) =>

69+ { index :: Projection names index

70+ -- ^ The set of conflict targets, projected from the set of columns for

71+ -- the whole table

72+ , set :: excluded -> exprs -> exprs

73+ -- ^ How to update each selected row.

74+ , updateWhere :: excluded -> exprs -> Expr Bool

75+ -- ^ Which rows to select for update.

76+ }

77+ -> Upsert names

78+

79+

80+ppOnConflict :: TableSchema names -> OnConflict names -> Doc

81+ppOnConflict schema = \case

82+ Abort -> mempty

83+ DoNothing -> text "ON CONFLICT DO NOTHING"

84+ DoUpdate upsert -> ppUpsert schema upsert

85+

86+

87+ppUpsert :: TableSchema names -> Upsert names -> Doc

88+ppUpsert schema@TableSchema {columns} Upsert {..} =

89+ text "ON CONFLICT" <+>

90+ ppIndex schema index <+>

91+ text "DO UPDATE" $$

92+ ppSet schema (set excluded) $$

93+ ppWhere schema (updateWhere excluded)

94+ where

95+ excluded = attributes TableSchema

96+ { schema = Nothing

97+ , name = "excluded"

98+ , columns

99+ }

100+

101+

102+ppIndex :: (Table Name names, Projecting names index)

103+ => TableSchema names -> Projection names index -> Doc

104+ppIndex TableSchema {columns} index =

105+ parens $ Opaleye.commaV ppColumn $ toList $

106+ showNames $ Cols $ apply index $ toColumns columns

src/Rel8/Statement/Returning.hs+114−10

@@ -1,29 +1,133 @@

11{-# language GADTs #-}

2+{-# language LambdaCase #-}

3+{-# language NamedFieldPuns #-}

4+{-# language RankNTypes #-}

5+{-# language ScopedTypeVariables #-}

26{-# language StandaloneKindSignatures #-}

7+{-# language StrictData #-}

8+{-# language TypeApplications #-}

410module Rel8.Statement.Returning

5− ( Returning(..)

11+ ( Returning( NumberOfRowsAffected, Projection )

12+ , decodeReturning

13+ , ppReturning

614 )

715where

816

917-- base

18+import Control.Applicative ( liftA2 )

19+import Data.Foldable ( toList )

1020import Data.Int ( Int64 )

1121import Data.Kind ( Type )

12−import Prelude ()

22+import Data.List.NonEmpty ( NonEmpty )

23+import Prelude

24+

25+-- hasql

26+import qualified Hasql.Decoders as Hasql

27+

28+-- opaleye

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

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

31+import qualified Opaleye.Internal.Sql as Opaleye

32+

33+-- pretty

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

1335

1436-- rel8

1537import Rel8.Schema.Name ( Selects )

16−import Rel8.Table.Serialize ( Serializable )

38+import Rel8.Schema.Table ( TableSchema(..) )

39+import Rel8.Table.Opaleye ( castTable, exprs, view )

40+import Rel8.Table.Serialize ( Serializable, parse )

1741

42+-- semigropuoids

43+import Data.Functor.Apply ( Apply, (<.>) )

1844

19−-- | @INSERT@, @UPDATE@ and @DELETE@ all support returning either the number of

20−-- rows affected, or the actual rows modified. 'Projection' allows you to

21−-- project out of these returned rows, which can be useful if you want to log

22−-- exactly which rows were deleted, or to view a generated id (for example, if

23−-- using a column with an autoincrementing counter as a default value).

45+

46+-- | 'Rel8.Insert', 'Rel8.Update' and 'Rel8.Delete' all support returning either

47+-- the number of rows affected, or the actual rows modified.

2448type Returning :: Type -> Type -> Type

2549data Returning names a where

50+ Pure :: a -> Returning names a

51+ Ap :: Returning names (a -> b) -> Returning names a -> Returning names b

52+

53+ -- | Return the number of rows affected.

2654 NumberOfRowsAffected :: Returning names Int64

27− Projection :: (Selects names exprs, Serializable projection a)

28− => (exprs -> projection)

55+

56+ -- | 'Projection' allows you to project out of the affected rows, which can

57+ -- be useful if you want to log exactly which rows were deleted, or to view

58+ -- a generated id (for example, if using a column with an autoincrementing

59+ -- counter via 'Rel8.nextval').

60+ Projection :: (Selects names exprs, Serializable returning a)

61+ => (exprs -> returning)

2962 -> Returning names [a]

63+

64+

65+instance Functor (Returning names) where

66+ fmap f = \case

67+ Pure a -> Pure (f a)

68+ Ap g a -> Ap (fmap (f .) g) a

69+ m -> Ap (Pure f) m

70+

71+

72+instance Apply (Returning names) where

73+ (<.>) = Ap

74+

75+

76+instance Applicative (Returning names) where

77+ pure = Pure

78+ (<*>) = Ap

79+

80+

81+projections :: ()

82+ => TableSchema names -> Returning names a -> Maybe (NonEmpty Opaleye.PrimExpr)

83+projections schema@TableSchema {columns} = \case

84+ Pure _ -> Nothing

85+ Ap f a -> projections schema f <> projections schema a

86+ NumberOfRowsAffected -> Nothing

87+ Projection f -> Just (exprs (castTable (f (view columns))))

88+

89+

90+runReturning :: ()

91+ => ((Int64 -> a) -> r)

92+ -> (forall x. Hasql.Row x -> ([x] -> a) -> r)

93+ -> Returning names a

94+ -> r

95+runReturning rowCount rowList = \case

96+ Pure a -> rowCount (const a)

97+ Ap fs as ->

98+ runReturning

99+ (\withCount ->

100+ runReturning

101+ (\withCount' -> rowCount (withCount <*> withCount'))

102+ (\decoder -> rowList decoder . liftA2 withCount length64)

103+ as)

104+ (\decoder withRows ->

105+ runReturning

106+ (\withCount -> rowList decoder $ withRows <*> withCount . length64)

107+ (\decoder' withRows' ->

108+ rowList (liftA2 (,) decoder decoder') $

109+ withRows <$> fmap fst <*> withRows' . fmap snd)

110+ as)

111+ fs

112+ NumberOfRowsAffected -> rowCount id

113+ Projection (_ :: exprs -> returning) -> rowList decoder' id

114+ where

115+ decoder' = parse @returning

116+ where

117+ length64 :: Foldable f => f x -> Int64

118+ length64 = fromIntegral . length

119+

120+

121+decodeReturning :: Returning names a -> Hasql.Result a

122+decodeReturning = runReturning

123+ (<$> Hasql.rowsAffected)

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

125+

126+

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

128+ppReturning schema returning = case projections schema returning of

129+ Nothing -> mempty

130+ Just columns ->

131+ text "RETURNING" <+> Opaleye.commaV Opaleye.ppSqlExpr (toList sqlExprs)

132+ where

133+ sqlExprs = Opaleye.sqlExpr <$> columns

src/Rel8/Statement/SQL.hsnew file+29

@@ -0,0 +1,29 @@

1+module Rel8.Statement.SQL

2+ ( showDelete

3+ , showInsert

4+ , showUpdate

5+ )

6+where

8+-- base

9+import Prelude

10+

11+-- rel8

12+import Rel8.Statement.Delete ( Delete, ppDelete )

13+import Rel8.Statement.Insert ( Insert, ppInsert )

14+import Rel8.Statement.Update ( Update, ppUpdate )

15+

16+

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

18+showDelete :: Delete a -> String

19+showDelete = show . ppDelete

20+

21+

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

23+showInsert :: Insert a -> String

24+showInsert = show . ppInsert

25+

26+

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

28+showUpdate :: Update a -> String

29+showUpdate = show . ppUpdate

src/Rel8/Statement/Select.hs+120−35

@@ -1,62 +1,147 @@

1+{-# language DeriveTraversable #-}

2+{-# language DerivingStrategies #-}

3+{-# language FlexibleContexts #-}

14{-# language MonoLocalBinds #-}

25{-# language ScopedTypeVariables #-}

6+{-# language StandaloneKindSignatures #-}

37{-# language TypeApplications #-}

59module Rel8.Statement.Select

610 ( select

7− , selectWithNames

11+ , ppSelect

12+

13+ , Optimized(..)

14+ , ppPrimSelect

15+ , ppRows

816 )

917where

1018

1119-- base

12−import Control.Exception ( throwIO )

13−import Prelude

20+import Data.Foldable ( toList )

21+import Data.Kind ( Type )

22+import Data.Void ( Void )

23+import Prelude hiding ( undefined )

1424

1525-- hasql

16−import Hasql.Connection ( Connection )

1726import qualified Hasql.Decoders as Hasql

1827import qualified Hasql.Encoders as Hasql

19−import qualified Hasql.Session as Hasql

2028import qualified Hasql.Statement as Hasql

2129

30+-- opaleye

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

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

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

34+import qualified Opaleye.Internal.PrimQuery as Opaleye

35+import qualified Opaleye.Internal.Print as Opaleye

36+import qualified Opaleye.Internal.Optimize as Opaleye

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

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

39+import qualified Opaleye.Internal.Tag as Opaleye

40+

41+-- pretty

42+import Text.PrettyPrint ( Doc )

43+

2244-- rel8

45+import Rel8.Expr ( Expr )

46+import Rel8.Expr.Bool ( false )

47+import Rel8.Expr.Opaleye ( toPrimExpr )

2348import Rel8.Query ( Query )

24−import Rel8.Query.SQL ( sqlForQuery, sqlForQueryWithNames )

49+import Rel8.Query.Opaleye ( toOpaleye )

2550import Rel8.Schema.Name ( Selects )

51+import Rel8.Table ( Table )

52+import Rel8.Table.Cols ( toCols )

53+import Rel8.Table.Name ( namesFromLabels )

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

55+import qualified Rel8.Table.Opaleye as T

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

57+import Rel8.Table.Undefined ( undefined )

2758

2859-- text

2960import qualified Data.Text as Text

3061import Data.Text.Encoding ( encodeUtf8 )

3162

3263

33−-- | Run a @SELECT@ query, returning all rows.

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

3465select :: forall exprs a. Serializable exprs a

35− => Connection -> Query exprs -> IO [a]

36−select c query = case sqlForQuery query of

37− Nothing -> pure []

38− Just sql -> Hasql.run session c >>= either throwIO pure

39− where

40− session = Hasql.statement () statement

41− statement = Hasql.Statement bytes params decode prepare

42− bytes = encodeUtf8 (Text.pack sql)

43− params = Hasql.noParams

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

45− prepare = False

46−

47−

48−selectWithNames :: forall exprs a names.

49− ( Selects names exprs

50− , Serializable exprs a

51− )

52− => Connection -> names -> Query exprs -> IO [a]

53−selectWithNames c names query = case sqlForQueryWithNames names query of

54− Nothing -> pure []

55− Just sql -> Hasql.run session c >>= either throwIO pure

56− where

57− session = Hasql.statement () statement

58− statement = Hasql.Statement bytes params decode prepare

59− bytes = encodeUtf8 (Text.pack sql)

60− params = Hasql.noParams

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

62− prepare = False

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

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

68+ where

69+ bytes = encodeUtf8 (Text.pack sql)

70+ params = Hasql.noParams

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

72+ prepare = False

73+ sql = show doc

74+ doc = ppSelect query

75+

76+

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

78+ppSelect query =

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

80+ where

81+ names = namesFromLabels

82+ (exprs, primQuery, _) =

83+ Opaleye.runSimpleQueryArrStart (toOpaleye query) ()

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

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

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

87+ Optimized pq -> (exprs, pq)

88+ never = pure (toPrimExpr false)

89+

90+

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

92+ppRows query = case optimize primQuery of

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

94+ Optimized (Opaleye.Values symbols rows)

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

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

97+ _ -> ppSelect query

98+ where

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

100+

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

102+ | eqSymbol symbol symbol' = eqSymbols symbols exprs

103+ | otherwise = False

104+ eqSymbols [] [] = True

105+ eqSymbols _ _ = False

106+

107+ eqSymbol

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

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

110+ = name == name' && tag == tag'

111+

112+

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

114+ppPrimSelect query =

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

116+ where

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

118+

119+

120+type Optimized :: Type -> Type

121+data Optimized a = Empty | Unit | Optimized a

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

123+

124+

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

126+optimize query = case Opaleye.removeEmpty (Opaleye.optimize query) of

127+ Nothing -> Empty

128+ Just Opaleye.Unit -> Unit

129+ Just query' -> Optimized query'

130+

131+

132+primSelect :: Opaleye.PrimQuery' Void -> Opaleye.Select

133+primSelect = Opaleye.foldPrimQuery Opaleye.sqlQueryGenerator

134+

135+

136+primSelectWith :: Selects names exprs

137+ => names -> exprs -> Opaleye.PrimQuery' Void -> Opaleye.Select

138+primSelectWith names exprs query =

139+ Opaleye.SelectFrom $ Opaleye.newSelect

140+ { Opaleye.attrs = Opaleye.SelectAttrs attrs

141+ , Opaleye.tables = Opaleye.oneTable (primSelect query)

142+ }

143+ where

144+ attrs = makeAttr <$> exprsWithNames names (castTable exprs)

145+ where

146+ makeAttr (label, expr) =

147+ (Opaleye.sqlExpr expr, Just (Opaleye.SqlColumn label))

src/Rel8/Statement/Set.hsnew file+33

@@ -0,0 +1,33 @@

1+{-# language MonoLocalBinds #-}

2+{-# language NamedFieldPuns #-}

4+module Rel8.Statement.Set

5+ ( ppSet

6+ )

7+where

9+-- base

10+import Data.Foldable ( toList )

11+import Prelude ()

12+

13+-- opaleye

14+import qualified Opaleye.Internal.HaskellDB.Sql.Print as Opaleye

15+import qualified Opaleye.Internal.Sql as Opaleye

16+

17+-- pretty

18+import Text.PrettyPrint ( Doc, (<+>), equals, text )

19+

20+-- rel8

21+import Rel8.Schema.Name ( Selects, ppColumn )

22+import Rel8.Schema.Table ( TableSchema(..) )

23+import Rel8.Table.Opaleye ( attributes, exprsWithNames )

24+

25+

26+ppSet :: Selects names exprs

27+ => TableSchema names -> (exprs -> exprs) -> Doc

28+ppSet schema@TableSchema {columns} f =

29+ text "SET" <+> Opaleye.commaV ppAssign (toList assigns)

30+ where

31+ assigns = exprsWithNames columns (f (attributes schema))

32+ ppAssign (column, expr) =

33+ ppColumn column <+> equals <+> Opaleye.ppSqlExpr (Opaleye.sqlExpr expr)

src/Rel8/Statement/Update.hs+38−56

@@ -1,39 +1,37 @@

1+{-# language DuplicateRecordFields #-}

12{-# language GADTs #-}

23{-# language NamedFieldPuns #-}

3−{-# language ScopedTypeVariables #-}

4+{-# language RecordWildCards #-}

45{-# language StandaloneKindSignatures #-}

5−{-# language TypeApplications #-}

6+{-# language StrictData #-}

78module Rel8.Statement.Update

89 ( Update(..)

910 , update

11+ , ppUpdate

1012 )

1113where

1214

1315-- base

14−import Control.Exception ( throwIO )

1516import Data.Kind ( Type )

1617import Prelude

1718

1819-- hasql

19−import Hasql.Connection ( Connection )

20−import qualified Hasql.Decoders as Hasql

2120import qualified Hasql.Encoders as Hasql

22−import qualified Hasql.Session as Hasql

2321import qualified Hasql.Statement as Hasql

2422

25−-- opaleye

26−import qualified Opaleye.Internal.Manipulation as Opaleye

23+-- pretty

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

2725

2826-- rel8

2927import Rel8.Expr ( Expr )

30−import Rel8.Expr.Opaleye ( toColumn, toPrimExpr )

28+import Rel8.Query ( Query )

3129import Rel8.Schema.Name ( Selects )

32−import Rel8.Schema.Table ( TableSchema )

33−import Rel8.Statement.Returning ( Returning( Projection, NumberOfRowsAffected ) )

34−import Rel8.Table ( fromColumns, toColumns )

35−import Rel8.Table.Opaleye ( castTable, table, unpackspec )

36−import Rel8.Table.Serialize ( Serializable, parse )

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

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

32+import Rel8.Statement.Set ( ppSet )

33+import Rel8.Statement.Using ( ppFrom )

34+import Rel8.Statement.Where ( ppWhere )

3735

3836-- text

3937import qualified Data.Text as Text

@@ -46,9 +44,12 @@ data Update a where

4644 Update :: Selects names exprs =>

4745 { target :: TableSchema names

4846 -- ^ Which table to update.

49− , set :: exprs -> exprs

47+ , from :: Query from

48+ -- ^ @FROM@ clause — this can be used to join against other tables,

49+ -- and its results can be referenced in the @SET@ and @WHERE@ clauses.

50+ , set :: from -> exprs -> exprs

5051 -- ^ How to update each selected row.

51− , updateWhere :: exprs -> Expr Bool

52+ , updateWhere :: from -> exprs -> Expr Bool

5253 -- ^ Which rows to select for update.

5354 , returning :: Returning names a

5455 -- ^ What to return from the @UPDATE@ statement.

@@ -56,46 +57,27 @@ data Update a where

5657 -> Update a

5758

5859

59−-- | Run an @UPDATE@ statement.

60−update :: Connection -> Update a -> IO a

61−update c Update {target, set, updateWhere, returning} =

62− case returning of

63− NumberOfRowsAffected -> Hasql.run session c >>= either throwIO pure

64− where

65− session = Hasql.statement () statement

66− statement = Hasql.Statement bytes params decode prepare

67− bytes = encodeUtf8 $ Text.pack sql

68− params = Hasql.noParams

69− decode = Hasql.rowsAffected

70− prepare = False

71− sql = Opaleye.arrangeUpdateSql target' set' where'

72− where

73− target' = table $ toColumns <$> target

74− set' = toColumns . set . fromColumns

75− where' = toColumn . toPrimExpr . updateWhere . fromColumns

60+ppUpdate :: Update a -> Doc

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

62+ Nothing ->

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

64+ ppSet target id $$

65+ text "WHERE false"

66+ Just (fromDoc, i) ->

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

68+ ppSet target (set i) $$

69+ fromDoc $$

70+ ppWhere target (updateWhere i) $$

71+ ppReturning target returning

7672

77− Projection project -> Hasql.run session c >>= either throwIO pure

78− where

79− session = Hasql.statement () statement

80− statement = Hasql.Statement bytes params decode prepare

81− bytes = encodeUtf8 $ Text.pack sql

82− params = Hasql.noParams

83− decode = decoder project

84− prepare = False

85− sql =

86− Opaleye.arrangeUpdateReturningSql

87− unpackspec

88− target'

89− set'

90− where'

91− project'

92− where

93− target' = table $ toColumns <$> target

94− set' = toColumns . set . fromColumns

95− where' = toColumn . toPrimExpr . updateWhere . fromColumns

96− project' = castTable . toColumns . project . fromColumns

9773

74+-- | Run an @UPDATE@ statement.

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

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

9877 where

99− decoder :: forall exprs projection a. Serializable projection a

100− => (exprs -> projection) -> Hasql.Result [a]

101− decoder _ = Hasql.rowList (parse @projection @a)

78+ bytes = encodeUtf8 $ Text.pack sql

79+ params = Hasql.noParams

80+ decode = decodeReturning returning

81+ prepare = False

82+ sql = show doc

83+ doc = ppUpdate u

src/Rel8/Statement/Using.hsnew file+36

@@ -0,0 +1,36 @@

1+module Rel8.Statement.Using

2+ ( ppFrom

3+ , ppUsing

4+ )

5+where

7+-- base

8+import Prelude

10+-- pretty

11+import Text.PrettyPrint ( Doc, (<+>), parens, text )

12+

13+-- rel8

14+import Rel8.Query ( Query )

15+import Rel8.Schema.Table ( TableSchema(..), ppTable )

16+import Rel8.Statement.Select ( Optimized(..), ppPrimSelect )

17+

18+

19+ppFrom :: Query a -> Maybe (Doc, a)

20+ppFrom = ppJoin "FROM"

21+

22+

23+ppUsing :: Query a -> Maybe (Doc, a)

24+ppUsing = ppJoin "USING"

25+

26+

27+ppJoin :: String -> Query a -> Maybe (Doc, a)

28+ppJoin clause join = do

29+ doc <- case ofrom of

30+ Empty -> Nothing

31+ Unit -> Just mempty

32+ Optimized doc -> Just $ text clause <+> parens doc <+> ppTable alias

33+ pure (doc, a)

34+ where

35+ alias = TableSchema {name = "T1", schema = Nothing, columns = ()}

36+ (ofrom, a) = ppPrimSelect join

src/Rel8/Statement/View.hs+43−28

@@ -3,61 +3,76 @@

44module Rel8.Statement.View

55 ( createView

6+ , createOrReplaceView

67 )

78where

910-- base

10−import Control.Exception ( throwIO )

11−import Control.Monad ( (>=>) )

12−import Data.Foldable ( fold )

13−import Data.Maybe ( fromMaybe )

1411import Prelude

1512

1613-- hasql

17−import Hasql.Connection ( Connection )

1814import qualified Hasql.Decoders as Hasql

1915import qualified Hasql.Encoders as Hasql

20−import qualified Hasql.Session as Hasql

2116import qualified Hasql.Statement as Hasql

2217

2318-- rel8

2419import Rel8.Query ( Query )

25−import Rel8.Query.SQL ( sqlForQueryWithNames )

2620import Rel8.Schema.Name ( Selects )

27−import Rel8.Schema.Table ( TableSchema( TableSchema ) )

28−import Rel8.Table.Alternative ( emptyTable )

21+import Rel8.Schema.Table ( TableSchema )

22+import Rel8.Statement.Insert ( ppInto )

23+import Rel8.Statement.Select ( ppSelect )

24+

25+-- pretty

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

2927

3028-- text

3129import qualified Data.Text as Text

3230import Data.Text.Encoding ( encodeUtf8 )

3331

3432

33+data CreateView = Create | CreateOrReplace

34+

35+

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

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

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

3839createView :: Selects names exprs

39− => TableSchema names -> Query exprs -> Connection -> IO ()

40−createView (TableSchema name mschema names) query =

41− Hasql.run session >=> either throwIO pure

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

41+createView =

42+ createViewGeneric Create

43+

44+

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

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

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

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

49+-- PostgreSQL.

50+createOrReplaceView :: Selects names exprs

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

52+createOrReplaceView =

53+ createViewGeneric CreateOrReplace

54+

55+

56+createViewGeneric :: Selects names exprs

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

58+createViewGeneric replace schema query =

59+ Hasql.Statement bytes params decode prepare

4260 where

43− session = Hasql.statement () statement

44− statement = Hasql.Statement bytes params decode prepare

4561 bytes = encodeUtf8 (Text.pack sql)

4662 params = Hasql.noParams

4763 decode = Hasql.noResult

4864 prepare = False

49− sql = "CREATE VIEW " <> title <> " AS " <> select

50− where

51− title = case mschema of

52− Nothing -> quote name

53− Just schema -> quote schema <> "." <> quote name

54− select = fromMaybe fallback $ sqlForQueryWithNames names query

55− where

56− fallback = fold $ sqlForQueryWithNames names emptyTable

57−

58−

59−quote :: String -> String

60−quote string = "\"" <> concatMap go string <> "\""

65+ sql = show doc

66+ doc = ppCreateView schema query replace

67+

68+

69+ppCreateView :: Selects names exprs

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

71+ppCreateView schema query replace =

72+ createOrReplace replace <+>

73+ ppInto schema $$

74+ text "AS" <+>

75+ ppSelect query

6176 where

62− go '"' = "\"\""

63− go c = [c]

77+ createOrReplace Create = text "CREATE VIEW"

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

src/Rel8/Statement/Where.hsnew file+31

@@ -0,0 +1,31 @@

1+{-# language MonoLocalBinds #-}

3+module Rel8.Statement.Where

4+ ( ppWhere

5+ )

6+where

8+-- base

9+import Prelude

10+

11+-- opaleye

12+import qualified Opaleye.Internal.HaskellDB.Sql.Print as Opaleye

13+import qualified Opaleye.Internal.Sql as Opaleye

14+

15+-- pretty

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

17+

18+-- rel8

19+import Rel8.Expr ( Expr )

20+import Rel8.Expr.Opaleye ( toPrimExpr )

21+import Rel8.Schema.Name ( Selects )

22+import Rel8.Schema.Table ( TableSchema )

23+import Rel8.Table.Opaleye ( attributes )

24+

25+

26+ppWhere :: Selects names exprs

27+ => TableSchema names -> (exprs -> Expr Bool) -> Doc

28+ppWhere schema where_ = text "WHERE" <+> ppExpr condition

29+ where

30+ ppExpr = Opaleye.ppSqlExpr . Opaleye.sqlExpr . toPrimExpr

31+ condition = where_ (attributes schema)

src/Rel8/Table.hs+57−74

@@ -14,31 +14,34 @@ module Rel8.Table

1414 ( Table

1515 ( Columns, Context, fromColumns, toColumns

1616 , FromExprs, fromResult, toResult

17+ , Transpose

1718 )

1819 , Congruent

19− , TTable, TColumns, TContext, TFromExprs

20+ , TTable, TColumns, TContext, TFromExprs, TTranspose

21+ , TSerialize

2022 )

2123where

2224

2325-- base

26+import Data.Functor.Identity ( Identity( Identity ) )

2427import Data.Kind ( Constraint, Type )

2528import GHC.Generics ( Generic, Rep, from, to )

2629import Prelude hiding ( null )

2730

2831-- rel8

2932import Rel8.FCF ( Eval, Exp )

30−import Rel8.Generic.Map ( GMap )

33+import Rel8.Generic.Map ( Map )

3134import Rel8.Generic.Table.Record

32− ( GTable, GColumns, GContext

33− , gfromColumns, gtoColumns, gfromResult, gtoResult

35+ ( GTable, GColumns, GContext, gfromColumns, gtoColumns

36+ , GSerialize, gfromResult, gtoResult

3437 )

3538import Rel8.Generic.Record ( Record(..) )

36−import Rel8.Schema.Context ( Col, UnCol )

3739import Rel8.Schema.HTable ( HTable )

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

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

3941import qualified Rel8.Schema.Kind as K

42+import Rel8.Schema.Null ( Sql )

4043import Rel8.Schema.Result ( Result )

41−import Rel8.Schema.Spec ( KnownSpec )

44+import Rel8.Type ( DBType )

4245

4346

4447-- | @Table@s are one of the foundational elements of Rel8, and describe data

@@ -53,7 +56,13 @@ import Rel8.Schema.Spec ( KnownSpec )

5356-- yourself, as anything that's an instance of 'Rel8.Rel8able' is always a

5457-- 'Table'.

5558type Table :: K.Context -> Type -> Constraint

56−class (HTable (Columns a), context ~ Context a) => Table context a | a -> context where

59+class

60+ ( HTable (Columns a)

61+ , context ~ Context a

62+ , a ~ Transpose context a

63+ )

64+ => Table context a | a -> context

65+ where

5766 -- | The 'HTable' functor that describes the schema of this table.

5867 type Columns a :: K.HTable

5968

@@ -64,96 +73,85 @@ class (HTable (Columns a), context ~ Context a) => Table context a | a -> contex

6473 -- corresponding Haskell type.

6574 type FromExprs a :: Type

6675

67− toColumns :: a -> Columns a (Col context)

68− fromColumns :: Columns a (Col context) -> a

76+ type Transpose (context' :: K.Context) a :: Type

77+

78+

79+ toColumns :: a -> Columns a context

80+ fromColumns :: Columns a context -> a

6981

70− fromResult :: Columns a (Col Result) -> FromExprs a

71− toResult :: FromExprs a -> Columns a (Col Result)

82+ fromResult :: Columns a Result -> FromExprs a

83+ toResult :: FromExprs a -> Columns a Result

7284

7385 type Columns a = GColumns TColumns (Rep (Record a))

7486 type Context a = GContext TContext (Rep (Record a))

75− type FromExprs a = DefaultFromExprs a

87+ type FromExprs a = Map TFromExprs a

88+ type Transpose context a = Map (TTranspose context) a

7689

7790 default toColumns ::

7891 ( Generic (Record a)

79− , GTable (TTable context) TColumns TFromExprs (Rep (Record a))

92+ , GTable (TTable context) TColumns (Rep (Record a))

8093 , Columns a ~ GColumns TColumns (Rep (Record a))

8194 )

82− => a -> Columns a (Col context)

95+ => a -> Columns a context

8396 toColumns =

84− gtoColumns

85− @(TTable context)

86− @TColumns

87− @TFromExprs

88− toColumns .

97+ gtoColumns @(TTable context) @TColumns toColumns .

8998 from .

9099 Record

91100

92101 default fromColumns ::

93102 ( Generic (Record a)

94− , GTable (TTable context) TColumns TFromExprs (Rep (Record a))

103+ , GTable (TTable context) TColumns (Rep (Record a))

95104 , Columns a ~ GColumns TColumns (Rep (Record a))

96105 )

97− => Columns a (Col context) -> a

106+ => Columns a context -> a

98107 fromColumns =

99108 unrecord .

100109 to .

101− gfromColumns

102− @(TTable context)

103− @TColumns

104− @TFromExprs

105− fromColumns

110+ gfromColumns @(TTable context) @TColumns fromColumns

106111

107112 default toResult ::

108113 ( Generic (Record (FromExprs a))

109− , GTable (TTable context) TColumns TFromExprs (Rep (Record a))

114+ , GSerialize TSerialize TColumns (Rep (Record a)) (Rep (Record (FromExprs a)))

110115 , Columns a ~ GColumns TColumns (Rep (Record a))

111− , Rep (Record (FromExprs a)) ~ GMap TFromExprs (Rep (Record a))

112116 )

113− => FromExprs a -> Columns a (Col Result)

117+ => FromExprs a -> Columns a Result

114118 toResult =

115119 gtoResult

116− @(TTable context)

120+ @TSerialize

117121 @TColumns

118− @TFromExprs

119122 @(Rep (Record a))

123+ @(Rep (Record (FromExprs a)))

120124 (\(_ :: proxy x) -> toResult @(Context x) @x) .

121125 from .

122126 Record

123127

124128 default fromResult ::

125129 ( Generic (Record (FromExprs a))

126− , GTable (TTable context) TColumns TFromExprs (Rep (Record a))

130+ , GSerialize TSerialize TColumns (Rep (Record a)) (Rep (Record (FromExprs a)))

127131 , Columns a ~ GColumns TColumns (Rep (Record a))

128− , Rep (Record (FromExprs a)) ~ GMap TFromExprs (Rep (Record a))

129132 )

130− => Columns a (Col Result) -> FromExprs a

133+ => Columns a Result -> FromExprs a

131134 fromResult =

132135 unrecord .

133136 to .

134137 gfromResult

135− @(TTable context)

138+ @TSerialize

136139 @TColumns

137− @TFromExprs

138140 @(Rep (Record a))

141+ @(Rep (Record (FromExprs a)))

139142 (\(_ :: proxy x) -> fromResult @(Context x) @x)

140143

141144

142−type DefaultFromExprs :: Type -> Type

143−type family DefaultFromExprs a where

144− DefaultFromExprs (t a b c d e f g) =

145− t (FromExprs a) (FromExprs b) (FromExprs c) (FromExprs d) (FromExprs e)

146− (FromExprs f) (FromExprs g)

147− DefaultFromExprs (t a b c d e f) =

148− t (FromExprs a) (FromExprs b) (FromExprs c) (FromExprs d) (FromExprs e)

149− (FromExprs f)

150− DefaultFromExprs (t a b c d e) =

151− t (FromExprs a) (FromExprs b) (FromExprs c) (FromExprs d) (FromExprs e)

152− DefaultFromExprs (t a b c d) =

153− t (FromExprs a) (FromExprs b) (FromExprs c) (FromExprs d)

154− DefaultFromExprs (t a b c) = t (FromExprs a) (FromExprs b) (FromExprs c)

155− DefaultFromExprs (t a b) = t (FromExprs a) (FromExprs b)

156− DefaultFromExprs (t a) = t (FromExprs a)

145+instance Sql DBType a => Table Result (Identity a) where

146+ type Columns (Identity a) = HIdentity a

147+ type Context (Identity a) = Result

148+ type FromExprs (Identity a) = a

149+ type Transpose to (Identity a) = to a

150+

151+ toColumns = HIdentity

152+ fromColumns (HIdentity a) = a

153+ toResult a = HIdentity (Identity a)

154+ fromResult (HIdentity (Identity a)) = a

157155

158156

159157data TTable :: K.Context -> Type -> Exp Constraint

@@ -172,30 +170,15 @@ data TFromExprs :: Type -> Exp Type

172170type instance Eval (TFromExprs a) = FromExprs a

173171

174172

175−-- | Any 'HTable' is also a 'Table'.

176−instance (context ~ UnCol hcontext, hcontext ~ Col context, HTable t) =>

177− Table context (t hcontext)

178− where

179− type Columns (t hcontext) = t

180− type Context (t hcontext) = UnCol hcontext

181− type FromExprs (t hcontext) = t (Col Result)

182−

183− toColumns = id

184− fromColumns = id

185− toResult = id

186− fromResult = id

187−

173+data TTranspose :: K.Context -> Type -> Exp Type

174+type instance Eval (TTranspose context a) = Transpose context a

188175

189−-- | Any context is trivially a table.

190−instance KnownSpec spec => Table context (Col context spec) where

191− type Columns (Col context spec) = HIdentity spec

192− type Context (Col context spec) = context

193− type FromExprs (Col context spec) = Col Result spec

194176

195− toColumns = HIdentity

196− fromColumns = unHIdentity

197− toResult = HIdentity

198− fromResult = unHIdentity

177+data TSerialize :: Type -> Type -> Exp Constraint

178+type instance Eval (TSerialize expr a) =

179+ ( Table (Context expr) expr

180+ , a ~ FromExprs expr

181+ )

199182

200183

201184instance (Table context a, Table context b) => Table context (a, b)

src/Rel8/Table/ADT.hs+13−19

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

77{-# language ScopedTypeVariables #-}

88{-# language StandaloneKindSignatures #-}

99{-# language TypeApplications #-}

10−{-# language TypeFamilies #-}

10+{-# language TypeFamilyDependencies #-}

1111{-# language UndecidableInstances #-}

1212{-# language UndecidableSuperClasses #-}

1313

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

2727

2828-- base

2929import Data.Kind ( Constraint, Type )

30−import GHC.Generics ( Generic, Rep, from, to )

30+import GHC.Generics ( Generic, from, to )

3131import GHC.TypeLits ( Symbol )

3232import Prelude

3333

@@ -44,28 +44,24 @@ import Rel8.Generic.Construction

4444 , GGName, ggname

4545 , GGAggregate, ggaggregate

4646 )

47−import Rel8.Generic.Map ( GMap )

4847import Rel8.Generic.Record ( Record( Record ), unrecord )

4948import Rel8.Generic.Rel8able

5049 ( Rel8able

5150 , GRep, GColumns, gfromColumns, gtoColumns

5251 , GFromExprs, gfromResult, gtoResult

52+ , TSerialize, deserialize, serialize

5353 )

5454import qualified Rel8.Generic.Table.ADT as G

5555import qualified Rel8.Kind.Algebra as K

56−import Rel8.Schema.Context ( Col )

5756import Rel8.Schema.HTable ( HTable )

5857import qualified Rel8.Schema.Kind as K

5958import Rel8.Schema.Name ( Name )

6059import Rel8.Schema.Result ( Result )

61−import Rel8.Table

62− ( Table, fromResult, toResult

63− , TTable, TColumns, TFromExprs

64− )

60+import Rel8.Table ( Table, TColumns )

6561

6662

6763type ADT :: K.Rel8able -> K.Rel8able

68−newtype ADT t context = ADT (GColumnsADT t (Col context))

64+newtype ADT t context = ADT (GColumnsADT t context)

6965

7066

7167instance ADTable t => Rel8able (ADT t) where

@@ -79,19 +75,19 @@ instance ADTable t => Rel8able (ADT t) where

7975 unrecord .

8076 to .

8177 G.gfromResultADT

82− @(TTable Expr)

78+ @TSerialize

8379 @TColumns

84− @TFromExprs

8580 @(Eval (ADTRep t Expr))

86− (\(_ :: proxy x) -> fromResult @_ @x)

81+ @(Eval (ADTRep t Result))

82+ (\(_ :: proxy x) -> deserialize @_ @x)

8783

8884 gtoResult =

8985 G.gtoResultADT

90− @(TTable Expr)

86+ @TSerialize

9187 @TColumns

92− @TFromExprs

9388 @(Eval (ADTRep t Expr))

94− (\(_ :: proxy x) -> toResult @_ @x) .

89+ @(Eval (ADTRep t Result))

90+ (\(_ :: proxy x) -> serialize @_ @x) .

9591 from .

9692 Record

9793

@@ -100,15 +96,13 @@ type ADTable :: K.Rel8able -> Constraint

10096class

10197 ( Generic (Record (t Result))

10298 , HTable (GColumnsADT t)

103− , G.GTableADT (TTable Expr) TColumns TFromExprs (Eval (ADTRep t Expr))

104− , GMap TFromExprs (Rep (Record (t Expr))) ~ Rep (Record (t Result))

99+ , G.GSerializeADT TSerialize TColumns (Eval (ADTRep t Expr)) (Eval (ADTRep t Result))

105100 )

106101 => ADTable t

107102instance

108103 ( Generic (Record (t Result))

109104 , HTable (GColumnsADT t)

110− , G.GTableADT (TTable Expr) TColumns TFromExprs (Eval (ADTRep t Expr))

111− , GMap TFromExprs (Rep (Record (t Expr))) ~ Rep (Record (t Result))

105+ , G.GSerializeADT TSerialize TColumns (Eval (ADTRep t Expr)) (Eval (ADTRep t Result))

112106 )

113107 => ADTable t

114108

src/Rel8/Table/Aggregate.hs+20−10

@@ -16,8 +16,8 @@ import Data.Functor.Identity ( Identity( Identity ) )

1616import Prelude

1717

1818-- rel8

19−import Rel8.Aggregate ( Aggregate, Aggregates, Col( A ) )

20−import Rel8.Expr ( Expr, Col( E ) )

19+import Rel8.Aggregate ( Aggregate, Aggregates )

20+import Rel8.Expr ( Expr )

2121import Rel8.Expr.Aggregate

2222 ( groupByExpr

2323 , slistAggExpr

@@ -27,8 +27,7 @@ import Rel8.Schema.Dict ( Dict( Dict ) )

2727import Rel8.Schema.HTable ( HTable, hfield, htabulate )

2828import Rel8.Schema.HTable.Vectorize ( hvectorize )

2929import Rel8.Schema.Null ( Sql )

30−import Rel8.Schema.Spec ( SSpec( SSpec, info ) )

31−import Rel8.Schema.Spec.Constrain ( ConstrainSpec )

30+import Rel8.Schema.Spec ( Spec( Spec, info ) )

3231import Rel8.Table ( toColumns, fromColumns )

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

3433import Rel8.Table.List ( ListTable )

@@ -38,17 +37,28 @@ import Rel8.Type.Eq ( DBEq )

3837

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

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

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

4253 => exprs -> aggregates

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

4455

4556

46−hgroupBy :: HTable t

47− => t (Dict (ConstrainSpec (Sql DBEq))) -> t (Col Expr) -> t (Col Aggregate)

48−hgroupBy eqs exprs = fromColumns $ htabulate $ \field ->

57+hgroupBy :: HTable t => t (Dict (Sql DBEq)) -> t Expr -> t Aggregate

58+hgroupBy eqs exprs = htabulate $ \field ->

4959 case hfield eqs field of

5060 Dict -> case hfield exprs field of

51− E expr -> A $ groupByExpr expr

61+ expr -> groupByExpr expr

5262

5363

5464-- | Aggregate rows into a single row containing an array of all aggregated

@@ -70,7 +80,7 @@ hgroupBy eqs exprs = fromColumns $ htabulate $ \field ->

7080listAgg :: Aggregates aggregates exprs => exprs -> ListTable Aggregate aggregates

7181listAgg (toColumns -> exprs) = fromColumns $

7282 hvectorize

73− (\SSpec {info} (Identity (E a)) -> A $ slistAggExpr info a)

83+ (\Spec {info} (Identity a) -> slistAggExpr info a)

7484 (pure exprs)

7585

7686

@@ -78,5 +88,5 @@ listAgg (toColumns -> exprs) = fromColumns $

7888nonEmptyAgg :: Aggregates aggregates exprs => exprs -> NonEmptyTable Aggregate aggregates

7989nonEmptyAgg (toColumns -> exprs) = fromColumns $

8090 hvectorize

81− (\SSpec {info} (Identity (E a)) -> A $ snonEmptyAggExpr info a)

91+ (\Spec {info} (Identity a) -> snonEmptyAggExpr info a)

8292 (pure exprs)

src/Rel8/Table/Bool.hs+5−6

@@ -13,7 +13,7 @@ where

1313import Prelude

1414

1515-- rel8

16−import Rel8.Expr ( Expr, Col( E, unE ) )

16+import Rel8.Expr ( Expr )

1717import Rel8.Expr.Bool ( boolExpr, caseExpr )

1818import Rel8.Expr.Null ( isNull, unsafeUnnullify )

1919import Rel8.Schema.HTable ( htabulate, hfield )

@@ -28,8 +28,7 @@ bool :: Table Expr a => a -> a -> Expr Bool -> a

2828bool (toColumns -> false) (toColumns -> true) condition =

2929 fromColumns $ htabulate $ \field ->

3030 case (hfield false field, hfield true field) of

31− (E falseExpr, E trueExpr) ->

32− E (boolExpr falseExpr trueExpr condition)

31+ (falseExpr, trueExpr) -> boolExpr falseExpr trueExpr condition

3332{-# INLINABLE bool #-}

3433

3534

@@ -39,9 +38,9 @@ bool (toColumns -> false) (toColumns -> true) condition =

3938case_ :: Table Expr a => [(Expr Bool, a)] -> a -> a

4039case_ (map (fmap toColumns) -> branches) (toColumns -> fallback) =

4140 fromColumns $ htabulate $ \field -> case hfield fallback field of

42− E fallbackExpr ->

43− case map (fmap (unE . (`hfield` field))) branches of

44− branchExprs -> E (caseExpr branchExprs fallbackExpr)

41+ fallbackExpr ->

42+ case map (fmap (`hfield` field)) branches of

43+ branchExprs -> caseExpr branchExprs fallbackExpr

4544

4645

4746-- | Like 'maybe', but to eliminate @null@.

src/Rel8/Table/Cols.hsnew file+50

@@ -0,0 +1,50 @@

1+{-# language DataKinds #-}

2+{-# language FlexibleInstances #-}

3+{-# language MultiParamTypeClasses #-}

4+{-# language StandaloneKindSignatures #-}

5+{-# language TypeFamilies #-}

6+{-# language UndecidableInstances #-}

8+module Rel8.Table.Cols

9+ ( Cols( Cols )

10+ , fromCols

11+ , toCols

12+ )

13+where

14+

15+-- base

16+import Data.Kind ( Type )

17+import Prelude

18+

19+-- rel8

20+import qualified Rel8.Schema.Kind as K

21+import Rel8.Schema.HTable ( HTable )

22+import Rel8.Schema.Result ( Result )

23+import Rel8.Table ( Table(..) )

24+

25+

26+type Cols :: K.Context -> K.HTable -> Type

27+newtype Cols context columns = Cols (columns context)

28+

29+

30+instance (HTable columns, context ~ context') =>

31+ Table context' (Cols context columns)

32+ where

33+ type Columns (Cols context columns) = columns

34+ type Context (Cols context columns) = context

35+ type FromExprs (Cols context columns) = Cols Result columns

36+ type Transpose to (Cols context columns) = Cols to columns

37+

38+ toColumns (Cols a) = a

39+ fromColumns = Cols

40+

41+ toResult (Cols a) = a

42+ fromResult = Cols

43+

44+

45+fromCols :: Table context a => Cols context (Columns a) -> a

46+fromCols (Cols a) = fromColumns a

47+

48+

49+toCols :: Table context a => a -> Cols context (Columns a)

50+toCols = Cols . toColumns

src/Rel8/Table/Either.hs+37−35

@@ -25,6 +25,7 @@ where

2525

2626-- base

2727import Data.Bifunctor ( Bifunctor, bimap )

28+import Data.Functor.Identity ( Identity( Identity ) )

2829import Data.Kind ( Type )

2930import Prelude hiding ( undefined )

3031

@@ -32,8 +33,8 @@ import Prelude hiding ( undefined )

3233import Control.Comonad ( extract )

3334

3435-- rel8

35−import Rel8.Aggregate ( Col( A ), Aggregate )

36−import Rel8.Expr ( Col( E ), Expr )

36+import Rel8.Aggregate ( Aggregate )

37+import Rel8.Expr ( Expr )

3738import Rel8.Expr.Aggregate ( groupByExpr )

3839import Rel8.Expr.Serialize ( litExpr )

3940import Rel8.Kind.Context ( Reifiable )

@@ -43,18 +44,17 @@ import Rel8.Schema.HTable.Either ( HEitherTable(..) )

4344import Rel8.Schema.HTable.Identity ( HIdentity(..) )

4445import Rel8.Schema.HTable.Label ( hlabel, hunlabel )

4546import qualified Rel8.Schema.Kind as K

46−import Rel8.Schema.Name ( Col( N ), Name )

47−import Rel8.Schema.Result ( Col( R ) )

48−import Rel8.Schema.Spec ( Spec( Spec ) )

47+import Rel8.Schema.Name ( Name )

4948import Rel8.Table

5049 ( Table, Columns, Context, fromColumns, toColumns

5150 , FromExprs, fromResult, toResult

51+ , Transpose

5252 )

5353import Rel8.Table.Bool ( bool )

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

5555import Rel8.Table.Nullify ( Nullify, aggregateNullify, guard )

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

57−import Rel8.Table.Recontextualize ( Recontextualize )

57+import Rel8.Table.Projection ( Biprojectable, Projectable, biproject, project )

5858import Rel8.Table.Serialize ( ToExprs )

5959import Rel8.Table.Undefined ( undefined )

6060import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ), isLeft, isRight )

@@ -72,20 +72,29 @@ import Data.Functor.Bind ( Bind, (>>-) )

7272-- adapted to work with Rel8.

7373type EitherTable :: K.Context -> Type -> Type -> Type

7474data EitherTable context a b = EitherTable

75− { tag :: Col context ('Spec EitherTag)

75+ { tag :: context EitherTag

7676 , left :: Nullify context a

7777 , right :: Nullify context b

7878 }

7979 deriving stock Functor

8080

8181

82+instance Biprojectable (EitherTable context) where

83+ biproject f g (EitherTable tag a b) =

84+ EitherTable tag (project f a) (project g b)

85+

86+

8287instance Nullifiable context => Bifunctor (EitherTable context) where

8388 bimap f g (EitherTable tag a b) = EitherTable tag (fmap f a) (fmap g b)

8489

8590

91+instance Projectable (EitherTable context a) where

92+ project f (EitherTable tag a b) = EitherTable tag a (project f b)

93+

94+

8695instance (context ~ Expr, Table Expr a) => Apply (EitherTable context a) where

87− EitherTable (E tag) l1 f <.> EitherTable (E tag') l2 a =

88− EitherTable (E (tag <> tag')) (bool l1 l2 (isLeft tag)) (f <.> a)

96+ EitherTable tag l1 f <.> EitherTable tag' l2 a =

97+ EitherTable (tag <> tag') (bool l1 l2 (isLeft tag)) (f <.> a)

8998

9099

91100instance (context ~ Expr, Table Expr a) => Applicative (EitherTable context a) where

@@ -94,9 +103,9 @@ instance (context ~ Expr, Table Expr a) => Applicative (EitherTable context a) w

94103

95104

96105instance (context ~ Expr, Table Expr a) => Bind (EitherTable context a) where

97− EitherTable (E tag) l1 a >>- f = case f (extract a) of

98− EitherTable (E tag') l2 b ->

99− EitherTable (E (tag <> tag')) (bool l1 l2 (isRight tag)) b

106+ EitherTable tag l1 a >>- f = case f (extract a) of

107+ EitherTable tag' l2 b ->

108+ EitherTable (tag <> tag') (bool l1 l2 (isRight tag)) b

100109

101110

102111instance (context ~ Expr, Table Expr a) => Monad (EitherTable context a) where

@@ -118,9 +127,11 @@ instance

118127 type Columns (EitherTable context a b) = HEitherTable (Columns a) (Columns b)

119128 type Context (EitherTable context a b) = Context a

120129 type FromExprs (EitherTable context a b) = Either (FromExprs a) (FromExprs b)

130+ type Transpose to (EitherTable context a b) =

131+ EitherTable to (Transpose to a) (Transpose to b)

121132

122133 toColumns EitherTable {tag, left, right} = HEitherTable

123− { htag = hlabel $ HType tag

134+ { htag = hlabel $ HIdentity tag

124135 , hleft = hlabel $ guard tag (== IsLeft) isLeft $ toColumns left

125136 , hright = hlabel $ guard tag (== IsRight) isRight $ toColumns right

126137 }

@@ -133,38 +144,29 @@ instance

133144

134145 toResult = \case

135146 Left table -> HEitherTable

136− { htag = hlabel (HType (R IsLeft))

147+ { htag = hlabel (HIdentity (Identity IsLeft))

137148 , hleft = hlabel (toResult @_ @(Nullify context a) (Just table))

138149 , hright = hlabel (toResult @_ @(Nullify context b) Nothing)

139150 }

140151 Right table -> HEitherTable

141− { htag = hlabel (HType (R IsRight))

152+ { htag = hlabel (HIdentity (Identity IsRight))

142153 , hleft = hlabel (toResult @_ @(Nullify context a) Nothing)

143154 , hright = hlabel (toResult @_ @(Nullify context b) (Just table))

144155 }

145156

146157 fromResult HEitherTable {htag, hleft, hright} = case hunlabel htag of

147− HType (R tag) -> case tag of

158+ HIdentity (Identity tag) -> case tag of

148159 IsLeft -> maybe err Left $ fromResult @_ @(Nullify context a) (hunlabel hleft)

149160 IsRight -> maybe err Right $ fromResult @_ @(Nullify context b) (hunlabel hright)

150161 where

151162 err = error "Either.fromColumns: mismatch between tag and data"

152163

153164

154−instance

155− ( Reifiable from, from ~ from'

156− , Reifiable to, to ~ to'

157− , Recontextualize from to a1 b1

158− , Recontextualize from to a2 b2

159− )

160− => Recontextualize from to (EitherTable from' a1 a2) (EitherTable to' b1 b2)

161−

162−

163165instance (EqTable a, EqTable b, context ~ Expr) =>

164166 EqTable (EitherTable context a b)

165167 where

166168 eqTable = HEitherTable

167− { htag = hlabel (HType Dict)

169+ { htag = hlabel (HIdentity Dict)

168170 , hleft = hlabel (eqTable @(Nullify context a))

169171 , hright = hlabel (eqTable @(Nullify context b))

170172 }

@@ -174,7 +176,7 @@ instance (OrdTable a, OrdTable b, context ~ Expr) =>

174176 OrdTable (EitherTable context a b)

175177 where

176178 ordTable = HEitherTable

177− { htag = hlabel (HType Dict)

179+ { htag = hlabel (HIdentity Dict)

178180 , hleft = hlabel (ordTable @(Nullify context a))

179181 , hright = hlabel (ordTable @(Nullify context b))

180182 }

@@ -186,30 +188,30 @@ instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ EitherTable Expr exprs1 exprs2

186188

187189-- | Test if an 'EitherTable' is a 'leftTable'.

188190isLeftTable :: EitherTable Expr a b -> Expr Bool

189−isLeftTable EitherTable {tag = E tag} = isLeft tag

191+isLeftTable EitherTable {tag} = isLeft tag

190192

191193

192194-- | Test if an 'EitherTable' is a 'rightTable'.

193195isRightTable :: EitherTable Expr a b -> Expr Bool

194−isRightTable EitherTable {tag = E tag} = isRight tag

196+isRightTable EitherTable {tag} = isRight tag

195197

196198

197199-- | Pattern match/eliminate an 'EitherTable', by providing mappings from a

198200-- 'leftTable' and 'rightTable'.

199201eitherTable :: Table Expr c

200202 => (a -> c) -> (b -> c) -> EitherTable Expr a b -> c

201−eitherTable f g EitherTable {tag = E tag, left, right} =

203+eitherTable f g EitherTable {tag, left, right} =

202204 bool (f (extract left)) (g (extract right)) (isRight tag)

203205

204206

205207-- | Construct a left 'EitherTable'. Like 'Left'.

206208leftTable :: Table Expr b => a -> EitherTable Expr a b

207−leftTable a = EitherTable (E (litExpr IsLeft)) (pure a) undefined

209+leftTable a = EitherTable (litExpr IsLeft) (pure a) undefined

208210

209211

210212-- | Construct a right 'EitherTable'. Like 'Right'.

211213rightTable :: Table Expr a => b -> EitherTable Expr a b

212−rightTable = EitherTable (E (litExpr IsRight)) undefined . pure

214+rightTable = EitherTable (litExpr IsRight) undefined . pure

213215

214216

215217-- | Lift a pair of aggregating functions to operate on an 'EitherTable'.

@@ -219,8 +221,8 @@ aggregateEitherTable :: ()

219221 -> (exprs' -> aggregates')

220222 -> EitherTable Expr exprs exprs'

221223 -> EitherTable Aggregate aggregates aggregates'

222−aggregateEitherTable f g (EitherTable (E tag) a b) = EitherTable

223− { tag = A (groupByExpr tag)

224+aggregateEitherTable f g (EitherTable tag a b) = EitherTable

225+ { tag = groupByExpr tag

224226 , left = aggregateNullify f a

225227 , right = aggregateNullify g b

226228 }

@@ -238,4 +240,4 @@ nameEitherTable

238240 -> b

239241 -- ^ Names of the columns in the @b@ table.

240242 -> EitherTable Name a b

241−nameEitherTable tag left right = EitherTable (N tag) (pure left) (pure right)

243+nameEitherTable tag left right = EitherTable tag (pure left) (pure right)

src/Rel8/Table/Eq.hs+11−32

@@ -11,7 +11,6 @@

1111{-# language TypeFamilies #-}

1212{-# language TypeOperators #-}

1313{-# language UndecidableInstances #-}

14−{-# language UndecidableSuperClasses #-}

1514{-# language ViewPatterns #-}

1615

1716module Rel8.Table.Eq

@@ -28,21 +27,17 @@ import GHC.Generics ( Rep )

2827import Prelude

2928

3029-- rel8

31−import Rel8.Expr ( Expr, Col( E ) )

30+import Rel8.Expr ( Expr )

3231import Rel8.Expr.Bool ( (||.), (&&.) )

3332import Rel8.Expr.Eq ( (==.), (/=.) )

3433import Rel8.FCF ( Eval, Exp )

3534import Rel8.Generic.Record ( Record )

3635import Rel8.Generic.Table.Record ( GTable, GColumns, gtable )

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

38−import Rel8.Schema.HTable

39− ( HTable, HConstrainTable

40− , htabulateA, hfield, hdicts

41− )

42−import Rel8.Schema.HTable.Identity ( HIdentity( HType ) )

37+import Rel8.Schema.HTable ( htabulateA, hfield )

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

4339import Rel8.Schema.Null ( Sql )

44−import Rel8.Schema.Spec.Constrain ( ConstrainSpec )

45−import Rel8.Table ( Table, Columns, toColumns, TColumns, TFromExprs )

40+import Rel8.Table ( Table, Columns, toColumns, TColumns )

4641import Rel8.Type.Eq ( DBEq )

4742

4843

@@ -51,20 +46,14 @@ import Rel8.Type.Eq ( DBEq )

5146-- means "all columns in a 'Table' have an instance of 'DBEq'".

5247type EqTable :: Type -> Constraint

5348class Table Expr a => EqTable a where

54− eqTable :: Columns a (Dict (ConstrainSpec (Sql DBEq)))

49+ eqTable :: Columns a (Dict (Sql DBEq))

5550

5651 default eqTable ::

57− ( GTable TEqTable TColumns TFromExprs (Rep (Record a))

52+ ( GTable TEqTable TColumns (Rep (Record a))

5853 , Columns a ~ GColumns TColumns (Rep (Record a))

5954 )

60− => Columns a (Dict (ConstrainSpec (Sql DBEq)))

61− eqTable =

62− gtable

63− @TEqTable

64− @TColumns

65− @TFromExprs

66− @(Rep (Record a))

67− table

55+ => Columns a (Dict (Sql DBEq))

56+ eqTable = gtable @TEqTable @TColumns @(Rep (Record a)) table

6857 where

6958 table (_ :: proxy x) = eqTable @x

7059

@@ -73,18 +62,8 @@ data TEqTable :: Type -> Exp Constraint

7362type instance Eval (TEqTable a) = EqTable a

7463

7564

76−instance

77− ( HTable t

78− , f ~ Col Expr

79− , HConstrainTable t (ConstrainSpec (Sql DBEq))

80− )

81− => EqTable (t f)

82− where

83− eqTable = hdicts @(Columns (t f)) @(ConstrainSpec (Sql DBEq))

84−

85−

8665instance Sql DBEq a => EqTable (Expr a) where

87− eqTable = HType Dict

66+ eqTable = HIdentity Dict

8867

8968

9069instance (EqTable a, EqTable b) => EqTable (a, b)

@@ -118,7 +97,7 @@ instance

11897(toColumns -> as) ==: (toColumns -> bs) =

11998 foldl1' (&&.) $ getConst $ htabulateA $ \field ->

12099 case (hfield as field, hfield bs field) of

121− (E a, E b) -> case hfield (eqTable @a) field of

100+ (a, b) -> case hfield (eqTable @a) field of

122101 Dict -> Const (pure (a ==. b))

123102infix 4 ==:

124103

@@ -130,7 +109,7 @@ infix 4 ==:

130109(toColumns -> as) /=: (toColumns -> bs) =

131110 foldl1' (||.) $ getConst $ htabulateA $ \field ->

132111 case (hfield as field, hfield bs field) of

133− (E a, E b) -> case hfield (eqTable @a) field of

112+ (a, b) -> case hfield (eqTable @a) field of

134113 Dict -> Const (pure (a /=. b))

135114infix 4 /=:

136115

src/Rel8/Table/HKD.hs+15−15

@@ -57,17 +57,18 @@ import Rel8.Generic.Rel8able

5757 , GFromExprs, gfromResult, gtoResult

5858 )

5959import Rel8.Generic.Table

60− ( GGTable, GGColumns, GAlgebra, ggfromResult, ggtoResult

60+ ( GGSerialize, GGColumns, GAlgebra, ggfromResult, ggtoResult

6161 )

6262import Rel8.Generic.Table.Record ( GTable, GContext )

6363import qualified Rel8.Generic.Table.Record as G

64−import Rel8.Schema.Context ( Col )

6564import qualified Rel8.Schema.Kind as K

6665import Rel8.Schema.HTable ( HTable )

6766import Rel8.Schema.Name ( Name )

67+import Rel8.Schema.Result ( Result )

6868import Rel8.Table

6969 ( Table, fromColumns, toColumns, fromResult, toResult

70− , TTable, TColumns, TContext, TFromExprs

70+ , TTable, TColumns, TContext

71+ , TSerialize

7172 )

7273

7374

@@ -77,7 +78,7 @@ type GColumnsHKD a =

7778

7879

7980type HKD :: Type -> K.Rel8able

80−newtype HKD a f = HKD (GColumnsHKD a (Col f))

81+newtype HKD a f = HKD (GColumnsHKD a f)

8182

8283

8384instance HKDable a => Rel8able (HKD a) where

@@ -92,26 +93,26 @@ instance HKDable a => Rel8able (HKD a) where

9293 to .

9394 ggfromResult

9495 @(GAlgebra (Rep a))

95− @(TTable Expr)

96+ @TSerialize

9697 @TColumns

97− @TFromExprs

9898 @(Eval (HKDRep a Expr))

99+ @(Eval (HKDRep a Result))

99100 (\(_ :: proxy x) -> fromResult @_ @x)

100101

101102 gtoResult =

102103 ggtoResult

103104 @(GAlgebra (Rep a))

104− @(TTable Expr)

105+ @TSerialize

105106 @TColumns

106− @TFromExprs

107107 @(Eval (HKDRep a Expr))

108+ @(Eval (HKDRep a Result))

108109 (\(_ :: proxy x) -> toResult @_ @x) .

109110 from .

110111 Record

111112

112113

113114instance

114− ( GTable (TTable f) TColumns TFromExprs (GRecord (GMap (TColumn f) (Rep a)))

115+ ( GTable (TTable f) TColumns (GRecord (GMap (TColumn f) (Rep a)))

115116 , G.GColumns TColumns (GRecord (GMap (TColumn f) (Rep a))) ~ GColumnsHKD a

116117 , GContext TContext (GRecord (GMap (TColumn f) (Rep a))) ~ f

117118 , GRecordable (GMap (TColumn f) (Rep a))

@@ -125,7 +126,6 @@ instance

125126 G.gfromColumns

126127 @(TTable f)

127128 @TColumns

128− @TFromExprs

129129 fromColumns .

130130 (\(HKD a) -> a)

131131

@@ -134,7 +134,6 @@ instance

134134 G.gtoColumns

135135 @(TTable f)

136136 @TColumns

137− @TFromExprs

138137 toColumns .

139138 grecord @(GMap (TColumn f) (Rep a))

140139

@@ -144,20 +143,21 @@ class

144143 ( Generic (Record a)

145144 , HTable (GColumns (HKD a))

146145 , KnownAlgebra (GAlgebra (Rep a))

147− , Eval (GGTable (GAlgebra (Rep a)) (TTable Expr) TColumns TFromExprs (Eval (HKDRep a Expr)))

148− , GMap TFromExprs (GRecord (GMap (TColumn Expr) (Rep a))) ~ Rep (Record a)

146+ , Eval (GGSerialize (GAlgebra (Rep a)) TSerialize TColumns (Eval (HKDRep a Expr)) (Eval (HKDRep a Result)))

147+ , GRecord (GMap (TColumn Result) (Rep a)) ~ Rep (Record a)

149148 )

150149 => HKDable a

151150instance

152151 ( Generic (Record a)

153152 , HTable (GColumns (HKD a))

154153 , KnownAlgebra (GAlgebra (Rep a))

155− , Eval (GGTable (GAlgebra (Rep a)) (TTable Expr) TColumns TFromExprs (Eval (HKDRep a Expr)))

156− , GMap TFromExprs (GRecord (GMap (TColumn Expr) (Rep a))) ~ Rep (Record a)

154+ , Eval (GGSerialize (GAlgebra (Rep a)) TSerialize TColumns (Eval (HKDRep a Expr)) (Eval (HKDRep a Result)))

155+ , GRecord (GMap (TColumn Result) (Rep a)) ~ Rep (Record a)

157156 )

158157 => HKDable a

159158

160159

160+type Top_ :: Constraint

161161class Top_

162162instance Top_

163163

src/Rel8/Table/List.hs+35−20

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

1111

1212module Rel8.Table.List

1313 ( ListTable(..)

14− , listTable, nameListTable

14+ , ($*)

15+ , listTable

16+ , nameListTable

1517 )

1618where

1719

@@ -21,19 +23,24 @@ import Data.Kind ( Type )

2123import Prelude

2224

2325-- rel8

24−import Rel8.Expr ( Expr, Col( E, unE ) )

26+import Rel8.Expr ( Expr )

2527import Rel8.Expr.Array ( sappend, sempty, slistOf )

2628import Rel8.Schema.Dict ( Dict( Dict ) )

2729import Rel8.Schema.HTable.List ( HListTable )

28−import Rel8.Schema.HTable.Vectorize ( happend, hempty, hvectorize, hunvectorize )

30+import Rel8.Schema.HTable.Vectorize

31+ ( hvectorize, hunvectorize

32+ , happend, hempty

33+ , hproject, hcolumn

34+ )

2935import qualified Rel8.Schema.Kind as K

30−import Rel8.Schema.Name ( Col( N ), Name( Name ) )

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

3137import Rel8.Schema.Null ( Nullity( Null, NotNull ) )

3238import Rel8.Schema.Result ( vectorizer, unvectorizer )

33−import Rel8.Schema.Spec ( SSpec(..) )

39+import Rel8.Schema.Spec ( Spec(..) )

3440import Rel8.Table

3541 ( Table, Context, Columns, fromColumns, toColumns

3642 , FromExprs, fromResult, toResult

43+ , Transpose

3744 )

3845import Rel8.Table.Alternative

3946 ( AltTable, (<|>:)

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

4148 )

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

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

44−import Rel8.Table.Recontextualize ( Recontextualize )

51+import Rel8.Table.Projection

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

53+ )

4554import Rel8.Table.Serialize ( ToExprs )

4655

4756

@@ -49,7 +58,11 @@ import Rel8.Table.Serialize ( ToExprs )

4958-- @ListTable@s with 'Rel8.many' or 'Rel8.listAgg'.

5059type ListTable :: K.Context -> Type -> Type

5160newtype ListTable context a =

52− ListTable (HListTable (Columns a) (Col (Context a)))

61+ ListTable (HListTable (Columns a) (Context a))

62+

63+

64+instance Projectable (ListTable context) where

65+ project f (ListTable a) = ListTable (hproject (apply f) a)

5366

5467

5568instance (Table context a, context ~ context') =>

@@ -58,6 +71,7 @@ instance (Table context a, context ~ context') =>

5871 type Columns (ListTable context a) = HListTable (Columns a)

5972 type Context (ListTable context a) = Context a

6073 type FromExprs (ListTable context a) = [FromExprs a]

74+ type Transpose to (ListTable context a) = ListTable to (Transpose to a)

6175

6276 fromColumns = ListTable

6377 toColumns (ListTable a) = a

@@ -65,14 +79,10 @@ instance (Table context a, context ~ context') =>

6579 toResult = hvectorize vectorizer . fmap (toResult @_ @a)

6680

6781

68−instance (Recontextualize from to a b, from ~ from', to ~ to') =>

69− Recontextualize from to (ListTable from' a) (ListTable to' b)

70−

71−

7282instance (EqTable a, context ~ Expr) => EqTable (ListTable context a) where

7383 eqTable =

7484 hvectorize

75− (\SSpec {nullity} (Identity Dict) -> case nullity of

85+ (\Spec {nullity} (Identity Dict) -> case nullity of

7686 Null -> Dict

7787 NotNull -> Dict)

7888 (Identity (eqTable @a))

@@ -81,7 +91,7 @@ instance (EqTable a, context ~ Expr) => EqTable (ListTable context a) where

8191instance (OrdTable a, context ~ Expr) => OrdTable (ListTable context a) where

8292 ordTable =

8393 hvectorize

84− (\SSpec {nullity} (Identity Dict) -> case nullity of

94+ (\Spec {nullity} (Identity Dict) -> case nullity of

8595 Null -> Dict

8696 NotNull -> Dict)

8797 (Identity (ordTable @a))

@@ -99,24 +109,29 @@ instance context ~ Expr => AlternativeTable (ListTable context) where

99109 emptyTable = mempty

100110

101111

102−instance (context ~ Expr, Table Expr a) =>

103− Semigroup (ListTable context a)

112+instance (context ~ Expr, Table Expr a) => Semigroup (ListTable context a)

104113 where

105− ListTable as <> ListTable bs = ListTable $

106− happend (\_ _ (E a) (E b) -> E (sappend a b)) as bs

114+ ListTable as <> ListTable bs = ListTable $ happend (const sappend) as bs

107115

108116

109117instance (context ~ Expr, Table Expr a) =>

110118 Monoid (ListTable context a)

111119 where

112− mempty = ListTable $ hempty $ \_ -> E . sempty

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

121+

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

113128

114129

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

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

117132listTable =

118133 ListTable .

119− hvectorize (\SSpec {info} -> E . slistOf info . fmap unE) .

134+ hvectorize (\Spec {info} -> slistOf info) .

120135 fmap toColumns

121136

122137

@@ -129,6 +144,6 @@ nameListTable

129144 -> ListTable Name a

130145nameListTable =

131146 ListTable .

132− hvectorize (\_ (Identity (N (Name a))) -> N (Name a)) .

147+ hvectorize (\_ (Identity (Name a)) -> Name a) .

133148 pure .

134149 toColumns

src/Rel8/Table/Maybe.hs+32−30

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

1515 ( MaybeTable(..)

1616 , maybeTable, nothingTable, justTable

1717 , isNothingTable, isJustTable

18+ , fromMaybeTable

1819 , ($?)

1920 , aggregateMaybeTable

2021 , nameMaybeTable

@@ -23,6 +24,7 @@ where

2324

2425-- base

2526import Data.Functor ( ($>) )

27+import Data.Functor.Identity ( Identity( Identity ) )

2628import Data.Kind ( Type )

2729import Data.Maybe ( fromMaybe, isJust )

2830import Prelude hiding ( null, undefined )

@@ -31,8 +33,8 @@ import Prelude hiding ( null, undefined )

3133import Control.Comonad ( extract )

3234

3335-- rel8

34−import Rel8.Aggregate ( Col( A ), Aggregate )

35−import Rel8.Expr ( Col( E ), Expr )

36+import Rel8.Aggregate ( Aggregate )

37+import Rel8.Expr ( Expr )

3638import Rel8.Expr.Aggregate ( groupByExpr )

3739import Rel8.Expr.Bool ( boolExpr )

3840import Rel8.Expr.Null ( isNull, isNonNull, null, nullify )

@@ -42,14 +44,13 @@ import qualified Rel8.Schema.Kind as K

4244import Rel8.Schema.HTable.Identity ( HIdentity(..) )

4345import Rel8.Schema.HTable.Label ( hlabel, hunlabel )

4446import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )

45−import Rel8.Schema.Name ( Col( N ), Name )

47+import Rel8.Schema.Name ( Name )

4648import Rel8.Schema.Null ( Nullity( Null, NotNull ), Sql, nullable )

4749import qualified Rel8.Schema.Null as N

48−import Rel8.Schema.Result ( Col( R ) )

49−import Rel8.Schema.Spec ( Spec( Spec ) )

5050import Rel8.Table

5151 ( Table, Columns, Context, fromColumns, toColumns

5252 , FromExprs, fromResult, toResult

53+ , Transpose

5354 )

5455import Rel8.Table.Alternative

5556 ( AltTable, (<|>:)

@@ -58,8 +59,8 @@ import Rel8.Table.Alternative

5859import Rel8.Table.Bool ( bool )

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

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

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

6163import Rel8.Table.Nullify ( Nullify, aggregateNullify, guard )

62−import Rel8.Table.Recontextualize ( Recontextualize )

6364import Rel8.Table.Serialize ( ToExprs )

6465import Rel8.Table.Undefined ( undefined )

6566import Rel8.Type ( DBType )

@@ -80,15 +81,18 @@ import Data.Functor.Bind ( Bind, (>>-) )

8081-- a "nullTag" - to track whether or not the outer join produced any rows.

8182type MaybeTable :: K.Context -> Type -> Type

8283data MaybeTable context a = MaybeTable

83− { tag :: Col context ('Spec (Maybe MaybeTag))

84+ { tag :: context (Maybe MaybeTag)

8485 , just :: Nullify context a

8586 }

8687 deriving stock Functor

8788

8889

90+instance Projectable (MaybeTable context) where

91+ project f (MaybeTable tag a) = MaybeTable tag (project f a)

92+

93+

8994instance context ~ Expr => Apply (MaybeTable context) where

90− MaybeTable (E tag) f <.> MaybeTable (E tag') a =

91− MaybeTable (E (tag <> tag')) (f <.> a)

95+ MaybeTable tag f <.> MaybeTable tag' a = MaybeTable (tag <> tag') (f <.> a)

9296

9397

9498-- | Has the same behavior as the @Applicative@ instance for @Maybe@. See also:

@@ -99,8 +103,8 @@ instance context ~ Expr => Applicative (MaybeTable context) where

99103

100104

101105instance context ~ Expr => Bind (MaybeTable context) where

102− MaybeTable (E tag) a >>- f = case f (extract a) of

103− MaybeTable (E tag') b -> MaybeTable (E (tag <> tag')) b

106+ MaybeTable tag a >>- f = case f (extract a) of

107+ MaybeTable tag' b -> MaybeTable (tag <> tag') b

104108

105109

106110-- | Has the same behavior as the @Monad@ instance for @Maybe@.

@@ -134,6 +138,7 @@ instance (Table context a, Reifiable context, context ~ context') =>

134138 type Columns (MaybeTable context a) = HMaybeTable (Columns a)

135139 type Context (MaybeTable context a) = Context a

136140 type FromExprs (MaybeTable context a) = Maybe (FromExprs a)

141+ type Transpose to (MaybeTable context a) = MaybeTable to (Transpose to a)

137142

138143 toColumns MaybeTable {tag, just} = HMaybeTable

139144 { htag = hlabel $ HIdentity tag

@@ -146,35 +151,27 @@ instance (Table context a, Reifiable context, context ~ context') =>

146151 }

147152

148153 toResult ma = HMaybeTable

149− { htag = hlabel (HIdentity (R (IsJust <$ ma)))

154+ { htag = hlabel (HIdentity (Identity (IsJust <$ ma)))

150155 , hjust = hlabel (toResult @_ @(Nullify context a) ma)

151156 }

152157

153158 fromResult HMaybeTable {htag, hjust} = case hunlabel htag of

154− HType (R tag) -> tag $>

159+ HIdentity (Identity tag) -> tag $>

155160 fromMaybe err (fromResult @_ @(Nullify context a) (hunlabel hjust))

156161 where

157162 err = error "Maybe.fromColumns: mismatch between tag and data"

158163

159164

160−instance

161− ( Recontextualize from to a b

162− , Reifiable from, from ~ from'

163− , Reifiable to, to ~ to'

164− )

165− => Recontextualize from to (MaybeTable from' a) (MaybeTable to' b)

166−

167−

168165instance (EqTable a, context ~ Expr) => EqTable (MaybeTable context a) where

169166 eqTable = HMaybeTable

170− { htag = hlabel (HType Dict)

167+ { htag = hlabel (HIdentity Dict)

171168 , hjust = hlabel (eqTable @(Nullify context a))

172169 }

173170

174171

175172instance (OrdTable a, context ~ Expr) => OrdTable (MaybeTable context a) where

176173 ordTable = HMaybeTable

177− { htag = hlabel (HType Dict)

174+ { htag = hlabel (HIdentity Dict)

178175 , hjust = hlabel (ordTable @(Nullify context a))

179176 }

180177

@@ -185,12 +182,12 @@ instance (ToExprs exprs a, context ~ Expr) =>

185182

186183-- | Check if a @MaybeTable@ is absent of any row. Like 'Data.Maybe.isNothing'.

187184isNothingTable :: MaybeTable Expr a -> Expr Bool

188−isNothingTable (MaybeTable (E tag) _) = isNull tag

185+isNothingTable (MaybeTable tag _) = isNull tag

189186

190187

191188-- | Check if a @MaybeTable@ contains a row. Like 'Data.Maybe.isJust'.

192189isJustTable :: MaybeTable Expr a -> Expr Bool

193−isJustTable (MaybeTable (E tag) _) = isNonNull tag

190+isJustTable (MaybeTable tag _) = isNonNull tag

194191

195192

196193-- | Perform case analysis on a 'MaybeTable'. Like 'maybe'.

@@ -201,13 +198,18 @@ maybeTable b f ma@(MaybeTable _ a) = bool (f (extract a)) b (isNothingTable ma)

201198

202199-- | The null table. Like 'Nothing'.

203200nothingTable :: Table Expr a => MaybeTable Expr a

204−nothingTable = MaybeTable (E null) (pure undefined)

201+nothingTable = MaybeTable null (pure undefined)

205202

206203

207204-- | Lift any table into 'MaybeTable'. Like 'Just'. Note you can also use

208205-- 'pure'.

209206justTable :: a -> MaybeTable Expr a

210−justTable = MaybeTable (E mempty) . pure

207+justTable = MaybeTable mempty . pure

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

211213

212214

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

@@ -227,8 +229,8 @@ aggregateMaybeTable :: ()

227229 => (exprs -> aggregates)

228230 -> MaybeTable Expr exprs

229231 -> MaybeTable Aggregate aggregates

230−aggregateMaybeTable f (MaybeTable (E tag) a) =

231− MaybeTable (A (groupByExpr tag)) (aggregateNullify f a)

232+aggregateMaybeTable f (MaybeTable tag a) =

233+ MaybeTable (groupByExpr tag) (aggregateNullify f a)

232234

233235

234236-- | Construct a 'MaybeTable' in the 'Name' context. This can be useful if you

@@ -241,4 +243,4 @@ nameMaybeTable

241243 -> a

242244 -- ^ Names of the columns in @a@.

243245 -> MaybeTable Name a

244−nameMaybeTable tag = MaybeTable (N tag) . pure

246+nameMaybeTable tag = MaybeTable tag . pure

src/Rel8/Table/Name.hs+11−20

@@ -1,14 +1,17 @@

1+{-# language DataKinds #-}

12{-# language FlexibleContexts #-}

3+{-# language FlexibleInstances #-}

4+{-# language MultiParamTypeClasses #-}

25{-# language NamedFieldPuns #-}

36{-# language ScopedTypeVariables #-}

47{-# language TypeApplications #-}

58{-# language TypeFamilies #-}

9+{-# language UndecidableInstances #-}

610{-# language ViewPatterns #-}

711

812module Rel8.Table.Name

913 ( namesFromLabels

1014 , namesFromLabelsWith

11− , showExprs

1215 , showLabels

1316 , showNames

1417 )

@@ -21,16 +24,11 @@ import Data.List.NonEmpty ( NonEmpty, intersperse, nonEmpty )

2124import Data.Maybe ( fromMaybe )

2225import Prelude

2326

24−-- opaleye

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

26−

2727-- rel8

28−import Rel8.Expr ( Expr, Col( E ) )

29−import Rel8.Expr.Opaleye ( toPrimExpr )

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

31−import Rel8.Schema.Name ( Name( Name ), Col( N ) )

32−import Rel8.Schema.Spec ( SSpec(..) )

33−import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )

29+import Rel8.Schema.Name ( Name( Name ) )

30+import Rel8.Schema.Spec ( Spec(..) )

31+import Rel8.Table ( Table(..) )

3432

3533

3634-- | Construct a table in the 'Name' context containing the names of all

@@ -62,26 +60,19 @@ namesFromLabelsWith :: Table Name a

6260 => (NonEmpty String -> String) -> a

6361namesFromLabelsWith f = fromColumns $ htabulate $ \field ->

6462 case hfield hspecs field of

65− SSpec {labels} -> N (Name (f (renderLabels labels)))

66−

67−

68−showExprs :: Table Expr a => a -> [(String, Opaleye.PrimExpr)]

69−showExprs as = case (namesFromLabels, toColumns as) of

70− (names, exprs) -> getConst $ htabulateA $ \field ->

71− case (hfield names field, hfield exprs field) of

72− (N (Name name), E expr) -> Const [(name, toPrimExpr expr)]

63+ Spec {labels} -> Name (f (renderLabels labels))

7364

7465

7566showLabels :: forall a. Table (Context a) a => a -> [NonEmpty String]

7667showLabels _ = getConst $

7768 htabulateA @(Columns a) $ \field -> case hfield hspecs field of

78− SSpec {labels} -> Const [renderLabels labels]

69+ Spec {labels} -> Const (pure (renderLabels labels))

7970

8071

81−showNames :: forall a. Table Name a => a -> [String]

72+showNames :: forall a. Table Name a => a -> NonEmpty String

8273showNames (toColumns -> names) = getConst $

8374 htabulateA @(Columns a) $ \field -> case hfield names field of

84− N (Name name) -> Const [name]

75+ Name name -> Const (pure name)

8576

8677

8778renderLabels :: [String] -> NonEmpty String

src/Rel8/Table/NonEmpty.hs+35−18

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

1111

1212module Rel8.Table.NonEmpty

1313 ( NonEmptyTable(..)

14− , nonEmptyTable, nameNonEmptyTable

14+ , ($+)

15+ , nonEmptyTable

16+ , nameNonEmptyTable

1517 )

1618where

1719

@@ -22,24 +24,31 @@ import Data.List.NonEmpty ( NonEmpty )

2224import Prelude hiding ( id )

2325

2426-- rel8

25−import Rel8.Expr ( Expr, Col( E, unE ) )

27+import Rel8.Expr ( Expr )

2628import Rel8.Expr.Array ( sappend1, snonEmptyOf )

2729import Rel8.Schema.Dict ( Dict( Dict ) )

2830import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable )

29−import Rel8.Schema.HTable.Vectorize ( happend, hvectorize, hunvectorize )

31+import Rel8.Schema.HTable.Vectorize

32+ ( hvectorize, hunvectorize

33+ , happend

34+ , hproject, hcolumn

35+ )

3036import qualified Rel8.Schema.Kind as K

31−import Rel8.Schema.Name ( Col( N ), Name( Name ) )

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

3238import Rel8.Schema.Null ( Nullity( Null, NotNull ) )

3339import Rel8.Schema.Result ( vectorizer, unvectorizer )

34−import Rel8.Schema.Spec ( SSpec(..) )

40+import Rel8.Schema.Spec ( Spec(..) )

3541import Rel8.Table

3642 ( Table, Context, Columns, fromColumns, toColumns

3743 , FromExprs, fromResult, toResult

44+ , Transpose

3845 )

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

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

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

42−import Rel8.Table.Recontextualize ( Recontextualize )

49+import Rel8.Table.Projection

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

51+ )

4352import Rel8.Table.Serialize ( ToExprs )

4453

4554

@@ -47,7 +56,11 @@ import Rel8.Table.Serialize ( ToExprs )

4756-- construct @NonEmptyTable@s with 'Rel8.some' or 'nonEmptyAgg'.

4857type NonEmptyTable :: K.Context -> Type -> Type

4958newtype NonEmptyTable context a =

50− NonEmptyTable (HNonEmptyTable (Columns a) (Col (Context a)))

59+ NonEmptyTable (HNonEmptyTable (Columns a) (Context a))

60+

61+

62+instance Projectable (NonEmptyTable context) where

63+ project f (NonEmptyTable a) = NonEmptyTable (hproject (apply f) a)

5164

5265

5366instance (Table context a, context ~ context') =>

@@ -56,6 +69,8 @@ instance (Table context a, context ~ context') =>

5669 type Columns (NonEmptyTable context a) = HNonEmptyTable (Columns a)

5770 type Context (NonEmptyTable context a) = Context a

5871 type FromExprs (NonEmptyTable context a) = NonEmpty (FromExprs a)

72+ type Transpose to (NonEmptyTable context a) =

73+ NonEmptyTable to (Transpose to a)

5974

6075 fromColumns = NonEmptyTable

6176 toColumns (NonEmptyTable a) = a

@@ -63,16 +78,12 @@ instance (Table context a, context ~ context') =>

6378 toResult = hvectorize vectorizer . fmap (toResult @_ @a)

6479

6580

66−instance (Recontextualize from to a b, from ~ from', to ~ to') =>

67− Recontextualize from to (NonEmptyTable from' a) (NonEmptyTable to' b)

68−

69−

7081instance (EqTable a, context ~ Expr) =>

7182 EqTable (NonEmptyTable context a)

7283 where

7384 eqTable =

7485 hvectorize

75− (\SSpec {nullity} (Identity Dict) -> case nullity of

86+ (\Spec {nullity} (Identity Dict) -> case nullity of

7687 Null -> Dict

7788 NotNull -> Dict)

7889 (Identity (eqTable @a))

@@ -83,7 +94,7 @@ instance (OrdTable a, context ~ Expr) =>

8394 where

8495 ordTable =

8596 hvectorize

86− (\SSpec {nullity} (Identity Dict) -> case nullity of

97+ (\Spec {nullity} (Identity Dict) -> case nullity of

8798 Null -> Dict

8899 NotNull -> Dict)

89100 (Identity (ordTable @a))

@@ -97,18 +108,24 @@ instance context ~ Expr => AltTable (NonEmptyTable context) where

97108 (<|>:) = (<>)

98109

99110

100−instance (Table Expr a, context ~ Expr) =>

101− Semigroup (NonEmptyTable context a)

111+instance (Table Expr a, context ~ Expr) => Semigroup (NonEmptyTable context a)

102112 where

103113 NonEmptyTable as <> NonEmptyTable bs = NonEmptyTable $

104− happend (\_ _ (E a) (E b) -> E (sappend1 a b)) as bs

114+ happend (const sappend1) as bs

115+

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

105122

106123

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

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

109126nonEmptyTable =

110127 NonEmptyTable .

111− hvectorize (\SSpec {info} -> E . snonEmptyOf info . fmap unE) .

128+ hvectorize (\Spec {info} -> snonEmptyOf info) .

112129 fmap toColumns

113130

114131

@@ -121,6 +138,6 @@ nameNonEmptyTable

121138 -> NonEmptyTable Name a

122139nameNonEmptyTable =

123140 NonEmptyTable .

124− hvectorize (\_ (Identity (N (Name a))) -> N (Name a)) .

141+ hvectorize (\_ (Identity (Name a)) -> Name a) .

125142 pure .

126143 toColumns

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+45−16

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

11{-# language DataKinds #-}

2+{-# language FlexibleContexts #-}

23{-# language FlexibleInstances #-}

34{-# language LambdaCase #-}

45{-# language MultiParamTypeClasses #-}

6+{-# language NamedFieldPuns #-}

57{-# language ScopedTypeVariables #-}

68{-# language StandaloneKindSignatures #-}

79{-# language TypeApplications #-}

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

1214 ( Nullify

1315 , aggregateNullify

1416 , guard

17+ , isNull

1518 )

1619where

1720

1821-- base

1922import Control.Applicative ( liftA2 )

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

2024import Data.Functor.Identity ( runIdentity )

2125import Data.Kind ( Type )

2226import Prelude

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

2731-- rel8

2832import Rel8.Aggregate ( Aggregate )

2933import Rel8.Expr ( Expr )

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

35+import qualified Rel8.Expr.Null as Expr

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

31−import Rel8.Schema.Context ( Col )

3237import Rel8.Schema.Context.Nullify

3338 ( Nullifiability( NAggregate, NExpr )

3439 , NonNullifiability

@@ -40,17 +45,23 @@ import Rel8.Schema.Context.Nullify

4045 )

4146import Rel8.Schema.Dict ( Dict( Dict ) )

4247import Rel8.Schema.HTable ( HTable )

43−import Rel8.Schema.HTable.Nullify ( HNullify, hnulls, hnullify, hunnullify, hguard )

48+import Rel8.Schema.HTable.Nullify

49+ ( HNullify, hnulls, hnullify, hunnullify

50+ , hguard

51+ , hproject

52+ )

4453import qualified Rel8.Schema.Kind as K

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

4555import qualified Rel8.Schema.Result as R

46−import Rel8.Schema.Spec ( Spec( Spec ) )

4756import Rel8.Table

4857 ( Table, Columns, Context, toColumns, fromColumns

4958 , FromExprs, fromResult, toResult

59+ , Transpose

5060 )

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

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

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

53−import Rel8.Table.Recontextualize ( Recontextualize )

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

5465

5566-- semigroupoids

5667import Data.Functor.Apply ( Apply, (<.>), liftF2 )

@@ -61,7 +72,13 @@ import Data.Functor.Extend ( Extend, duplicated )

6172type Nullify :: K.Context -> Type -> Type

6273data Nullify context a

6374 = Table (Nullifiability context) a

64− | Fields (NonNullifiability context) (HNullify (Columns a) (Col (Context a)))

75+ | Fields (NonNullifiability context) (HNullify (Columns a) (Context a))

76+

77+

78+instance Projectable (Nullify context) where

79+ project f = \case

80+ Table nullifiable a -> Table nullifiable (fromColumns (apply f (toColumns a)))

81+ Fields nonNullifiable a -> Fields nonNullifiable (hproject (apply f) a)

6582

6683

6784instance Nullifiable context => Functor (Nullify context) where

@@ -127,6 +144,7 @@ instance (Table context a, Reifiable context, context ~ context') =>

127144 type Columns (Nullify context a) = HNullify (Columns a)

128145 type Context (Nullify context a) = Context a

129146 type FromExprs (Nullify context a) = Maybe (FromExprs a)

147+ type Transpose to (Nullify context a) = Nullify to (Transpose to a)

130148

131149 fromColumns = case nullifiableOrNot contextSing of

132150 Left notNullifiable -> Fields notNullifiable

@@ -147,14 +165,6 @@ instance (Table context a, Reifiable context, context ~ context') =>

147165 fmap (toResult @_ @a)

148166

149167

150−instance

151− ( Recontextualize from to a b

152− , Reifiable from, from ~ from'

153− , Reifiable to, to ~ to'

154− )

155− => Recontextualize from' to' (Nullify from a) (Nullify to b)

156−

157−

158168instance (EqTable a, context ~ Expr) => EqTable (Nullify context a) where

159169 eqTable = hnullify (\_ Dict -> Dict) (eqTable @a)

160170

@@ -173,10 +183,29 @@ aggregateNullify f = \case

173183

174184

175185guard :: (Reifiable context, HTable t)

176− => Col context ('Spec tag)

186+ => context tag

177187 -> (tag -> Bool)

178188 -> (Expr tag -> Expr Bool)

179− -> HNullify t (Col context)

180− -> HNullify t (Col context)

189+ -> HNullify t context

190+ -> HNullify t context

181191guard tag isNonNull isNonNullExpr =

182192 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+78−64

@@ -1,136 +1,150 @@

11{-# language BlockArguments #-}

2+{-# language DataKinds #-}

23{-# language DisambiguateRecordFields #-}

34{-# language FlexibleContexts #-}

4−{-# language LambdaCase #-}

55{-# language NamedFieldPuns #-}

6+{-# language RankNTypes #-}

67{-# language TypeFamilies #-}

78{-# language ViewPatterns #-}

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

11+

912module Rel8.Table.Opaleye

1013 ( aggregator

14+ , attributes

1115 , binaryspec

1216 , distinctspec

17+ , exprs

18+ , exprsWithNames

1319 , table

1420 , tableFields

1521 , unpackspec

1622 , valuesspec

23+ , view

1724 , castTable

1825 )

1926where

2027

2128-- base

22−import Prelude hiding ( undefined )

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

30+import Data.List.NonEmpty ( NonEmpty )

31+import Prelude

2332

2433-- opaleye

34+import qualified Opaleye.Adaptors as Opaleye

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

2536import qualified Opaleye.Internal.Aggregate as Opaleye

26−import qualified Opaleye.Internal.Binary as Opaleye

27−import qualified Opaleye.Internal.Distinct as Opaleye

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

29−import qualified Opaleye.Internal.PackMap as Opaleye

30−import qualified Opaleye.Internal.Unpackspec as Opaleye

3138import qualified Opaleye.Internal.Values as Opaleye

32−import qualified Opaleye.Internal.Table as Opaleye

39+import qualified Opaleye.Table as Opaleye

3340

3441-- profunctors

3542import Data.Profunctor ( dimap, lmap )

3643

3744-- rel8

38−import Rel8.Aggregate ( Col( A ), Aggregate( Aggregate ), Aggregates )

39−import Rel8.Expr ( Expr, Col(..) )

45+import Rel8.Aggregate ( Aggregate( Aggregate ), Aggregates )

46+import Rel8.Expr ( Expr )

4047import Rel8.Expr.Opaleye

4148 ( fromPrimExpr, toPrimExpr

42− , traversePrimExpr

43− , fromColumn, toColumn

44− , scastExpr

49+ , scastExpr, traverseFieldP

4550 )

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

47−import Rel8.Schema.Name ( Col( N ), Name( Name ), Selects )

48−import Rel8.Schema.Spec ( SSpec(..) )

49−import Rel8.Schema.Table ( TableSchema(..) )

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

52+ htraverseP, htraversePWithField )

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

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

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

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

51−import Rel8.Table.Undefined ( undefined )

57+import Rel8.Type.Information ( typeName )

5258

5359-- semigroupoids

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

61+import Data.Profunctor.Product ( ProductProfunctor )

5562

5663

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

58−aggregator = Opaleye.Aggregator $ Opaleye.PackMap $ \f aggregates ->

59− fmap fromColumns $ unwrapApplicative $ htabulateA $ \field ->

60− WrapApplicative $ case hfield (toColumns aggregates) field of

61− A (Aggregate (Opaleye.Aggregator (Opaleye.PackMap inner))) ->

62− E <$> inner f ()

65+aggregator = dimap toColumns fromColumns $

66+ htraverseP $

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

68+

69+

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

71+attributes schema@TableSchema {columns} = fromColumns $ htabulate $ \field ->

72+ case hfield (toColumns columns) field of

73+ Name column -> fromPrimExpr $ Opaleye.ConstExpr $

74+ Opaleye.OtherLit $

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

76+

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

6383

6484

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

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

67− fmap fromColumns $ unwrapApplicative $ htabulateA $ \field ->

68− WrapApplicative $

69− case (hfield (toColumns as) field, hfield (toColumns bs) field) of

70− (E a, E b) -> E . fromPrimExpr <$> f (toPrimExpr a, toPrimExpr b)

86+binaryspec = fromOpaleyespec Opaleye.binaryspecField

7187

7288

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

74−distinctspec =

75− Opaleye.Distinctspec $ Opaleye.Aggregator $ Opaleye.PackMap $ \f ->

76− fmap fromColumns .

77− unwrapApplicative .

78− htraverse

79− (\(E a) ->

80− WrapApplicative $ E . fromPrimExpr <$> f (Nothing, toPrimExpr a)) .

81− toColumns

90+distinctspec = fromOpaleyespec Opaleye.distinctspecField

91+

92+

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

94+exprs (toColumns -> as) = getConst $ htabulateA $ \field ->

95+ case hfield as field of

96+ expr -> Const (pure (toPrimExpr expr))

97+

98+

99+exprsWithNames :: Selects names exprs

100+ => names -> exprs -> NonEmpty (String, Opaleye.PrimExpr)

101+exprsWithNames names as = getConst $ htabulateA $ \field ->

102+ case (hfield (toColumns names) field, hfield (toColumns as) field) of

103+ (Name name, expr) -> Const (pure (name, toPrimExpr expr))

82104

83105

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

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

85107table (TableSchema name schema columns) =

86108 case schema of

87− Nothing -> Opaleye.Table name (tableFields columns)

88− Just schemaName -> Opaleye.TableWithSchema schemaName name (tableFields columns)

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

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

89111

90112

91−tableFields ::Selects names exprs

113+tableFields :: Selects names exprs

92114 => names -> Opaleye.TableFields exprs exprs

93115tableFields (toColumns -> names) = dimap toColumns fromColumns $

94116 unwrapApplicative $ htabulateA $ \field -> WrapApplicative $

95117 case hfield names field of

96118 name -> lmap (`hfield` field) (go name)

97119 where

98− go :: Col Name spec -> Opaleye.TableFields (Col Expr spec) (Col Expr spec)

99− go (N (Name name)) =

100− lmap (\(E a) -> toColumn $ toPrimExpr a) $

101− E . fromPrimExpr . fromColumn <$>

102− Opaleye.requiredTableField name

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

121+ go (Name name) =

122+ traverseFieldP $

123+ Opaleye.requiredTableField name

103124

104125

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

106−unpackspec = Opaleye.Unpackspec $ Opaleye.PackMap $ \f ->

107− fmap fromColumns .

108− unwrapApplicative .

109− htraverse (\(E a) -> WrapApplicative $ E <$> traversePrimExpr f a) .

110− toColumns

127+unpackspec = fromOpaleyespec Opaleye.unpackspecField

111128{-# INLINABLE unpackspec #-}

112129

113130

114−valuesspec :: Table Expr a => Opaleye.ValuesspecSafe a a

115−valuesspec = Opaleye.ValuesspecSafe (toPackMap undefined) unpackspec

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

132+valuesspec = dimap toColumns fromColumns $

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

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

116135

117136

118−toPackMap :: Table Expr a

119− => a -> Opaleye.PackMap Opaleye.PrimExpr Opaleye.PrimExpr () a

120−toPackMap as = Opaleye.PackMap $ \f () ->

121− fmap fromColumns $

122− unwrapApplicative .

123− htraverse (\(E a) -> WrapApplicative $ E <$> traversePrimExpr f a) $

124− toColumns as

137+view :: Selects names exprs => names -> exprs

138+view columns = fromColumns $ htabulate $ \field ->

139+ case hfield (toColumns columns) field of

140+ Name column -> fromPrimExpr $ Opaleye.BaseTableAttrExpr column

125141

126142

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

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

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

130146castTable :: Table Expr a => a -> a

131−castTable (toColumns -> as) = fromColumns $ htabulate \i ->

132− case hfield hspecs i of

133− SSpec{info} ->

134− case hfield as i of

135− E expr ->

136− E (scastExpr info expr)

147+castTable (toColumns -> as) = fromColumns $ htabulate \field ->

148+ case hfield hspecs field of

149+ Spec {info} -> case hfield as field of

150+ expr -> scastExpr info expr

src/Rel8/Table/Ord.hs+15−38

@@ -10,7 +10,6 @@

1010{-# language TypeFamilies #-}

1111{-# language TypeOperators #-}

1212{-# language UndecidableInstances #-}

13−{-# language UndecidableSuperClasses #-}

1413{-# language ViewPatterns #-}

1514

1615module Rel8.Table.Ord

@@ -25,7 +24,7 @@ import GHC.Generics ( Rep )

2524import Prelude hiding ( seq )

2625

2726-- rel8

28−import Rel8.Expr ( Expr, Col( E ) )

27+import Rel8.Expr ( Expr )

2928import Rel8.Expr.Bool ( (||.), (&&.), false, true )

3029import Rel8.Expr.Eq ( (==.) )

3130import Rel8.Expr.Ord ( (<.), (>.) )

@@ -33,17 +32,12 @@ import Rel8.FCF ( Eval, Exp )

3332import Rel8.Generic.Record ( Record )

3433import Rel8.Generic.Table.Record ( GTable, GColumns, gtable )

3534import Rel8.Schema.Dict ( Dict( Dict ) )

36−import Rel8.Schema.HTable

37− ( HTable, HConstrainTable

38− , htabulateA, hfield, hdicts

39− )

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

35+import Rel8.Schema.HTable ( htabulateA, hfield )

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

4137import Rel8.Schema.Null (Sql)

42−import Rel8.Schema.Spec.Constrain ( ConstrainSpec )

43−import Rel8.Table ( Columns, toColumns, TColumns, TFromExprs )

38+import Rel8.Table ( Columns, toColumns, TColumns )

4439import Rel8.Table.Bool ( bool )

4540import Rel8.Table.Eq ( EqTable )

46−import Rel8.Type.Eq ( DBEq )

4741import Rel8.Type.Ord ( DBOrd )

4842

4943

@@ -52,20 +46,14 @@ import Rel8.Type.Ord ( DBOrd )

5246-- columns in a 'Table' have an instance of 'DBOrd'".

5347type OrdTable :: Type -> Constraint

5448class EqTable a => OrdTable a where

55− ordTable :: Columns a (Dict (ConstrainSpec (Sql DBOrd)))

49+ ordTable :: Columns a (Dict (Sql DBOrd))

5650

5751 default ordTable ::

58− ( GTable TOrdTable TColumns TFromExprs (Rep (Record a))

52+ ( GTable TOrdTable TColumns (Rep (Record a))

5953 , Columns a ~ GColumns TColumns (Rep (Record a))

6054 )

61− => Columns a (Dict (ConstrainSpec (Sql DBOrd)))

62− ordTable =

63− gtable

64− @TOrdTable

65− @TColumns

66− @TFromExprs

67− @(Rep (Record a))

68− table

55+ => Columns a (Dict (Sql DBOrd))

56+ ordTable = gtable @TOrdTable @TColumns @(Rep (Record a)) table

6957 where

7058 table (_ :: proxy x) = ordTable @x

7159

@@ -74,19 +62,8 @@ data TOrdTable :: Type -> Exp Constraint

7462type instance Eval (TOrdTable a) = OrdTable a

7563

7664

77−instance

78− ( HTable t

79− , f ~ Col Expr

80− , HConstrainTable t (ConstrainSpec (Sql DBEq))

81− , HConstrainTable t (ConstrainSpec (Sql DBOrd))

82− )

83− => OrdTable (t f)

84− where

85− ordTable = hdicts @(Columns (t f)) @(ConstrainSpec (Sql DBOrd))

86−

87−

8865instance Sql DBOrd a => OrdTable (Expr a) where

89− ordTable = HType Dict

66+ ordTable = HIdentity Dict

9067

9168

9269instance (OrdTable a, OrdTable b) => OrdTable (a, b)

@@ -121,7 +98,7 @@ instance

12198(toColumns -> as) <: (toColumns -> bs) =

12299 foldr @[] go false $ getConst $ htabulateA $ \field ->

123100 case (hfield as field, hfield bs field) of

124− (E a, E b) -> case hfield (ordTable @a) field of

101+ (a, b) -> case hfield (ordTable @a) field of

125102 Dict -> Const [(a <. b, a ==. b)]

126103 where

127104 go (lt, eq) a = lt ||. (eq &&. a)

@@ -134,7 +111,7 @@ infix 4 <:

134111(toColumns -> as) <=: (toColumns -> bs) =

135112 foldr @[] go true $ getConst $ htabulateA $ \field ->

136113 case (hfield as field, hfield bs field) of

137− (E a, E b) -> case hfield (ordTable @a) field of

114+ (a, b) -> case hfield (ordTable @a) field of

138115 Dict -> Const [(a <. b, a ==. b)]

139116 where

140117 go (lt, eq) a = lt ||. (eq &&. a)

@@ -147,7 +124,7 @@ infix 4 <=:

147124(toColumns -> as) >: (toColumns -> bs) =

148125 foldr @[] go false $ getConst $ htabulateA $ \field ->

149126 case (hfield as field, hfield bs field) of

150− (E a, E b) -> case hfield (ordTable @a) field of

127+ (a, b) -> case hfield (ordTable @a) field of

151128 Dict -> Const [(a >. b, a ==. b)]

152129 where

153130 go (gt, eq) a = gt ||. (eq &&. a)

@@ -160,7 +137,7 @@ infix 4 >:

160137(toColumns -> as) >=: (toColumns -> bs) =

161138 foldr @[] go true $ getConst $ htabulateA $ \field ->

162139 case (hfield as field, hfield bs field) of

163− (E a, E b) -> case hfield (ordTable @a) field of

140+ (a, b) -> case hfield (ordTable @a) field of

164141 Dict -> Const [(a >. b, a ==. b)]

165142 where

166143 go (gt, eq) a = gt ||. (eq &&. a)

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

169146

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

171148least :: OrdTable a => a -> a -> a

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

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

173150

174151

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

176153greatest :: OrdTable a => a -> a -> a

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

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

src/Rel8/Table/Order.hs+5−6

@@ -16,13 +16,12 @@ import Data.Functor.Contravariant ( (>$<), contramap )

1616import Prelude

1717

1818-- rel8

19−import Rel8.Expr ( unE )

2019import Rel8.Expr.Order ( asc, desc, nullsFirst, nullsLast )

2120import Rel8.Order ( Order )

2221import Rel8.Schema.Dict ( Dict( Dict ) )

2322import Rel8.Schema.HTable (htabulateA, hfield, hspecs)

2423import Rel8.Schema.Null ( Nullity( Null, NotNull ) )

25−import Rel8.Schema.Spec ( SSpec( SSpec, nullity ) )

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

2625import Rel8.Table ( Columns, toColumns )

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

2827

@@ -32,8 +31,8 @@ import Rel8.Table.Ord ( OrdTable, ordTable )

3231ascTable :: forall a. OrdTable a => Order a

3332ascTable = contramap toColumns $ getConst $

3433 htabulateA @(Columns a) $ \field -> case hfield hspecs field of

35− SSpec {nullity} -> case hfield (ordTable @a) field of

36− Dict -> Const $ unE . (`hfield` field) >$<

34+ Spec {nullity} -> case hfield (ordTable @a) field of

35+ Dict -> Const $ (`hfield` field) >$<

3736 case nullity of

3837 Null -> nullsFirst asc

3938 NotNull -> asc

@@ -44,8 +43,8 @@ ascTable = contramap toColumns $ getConst $

4443descTable :: forall a. OrdTable a => Order a

4544descTable = contramap toColumns $ getConst $

4645 htabulateA @(Columns a) $ \field -> case hfield hspecs field of

47− SSpec {nullity} -> case hfield (ordTable @a) field of

48− Dict -> Const $ unE . (`hfield` field) >$<

46+ Spec {nullity} -> case hfield (ordTable @a) field of

47+ Dict -> Const $ (`hfield` field) >$<

4948 case nullity of

5049 Null -> nullsLast desc

5150 NotNull -> desc

src/Rel8/Table/Projection.hsnew file+73

@@ -0,0 +1,73 @@

1+{-# language FlexibleContexts #-}

2+{-# language FlexibleInstances #-}

3+{-# language MonoLocalBinds #-}

4+{-# language MultiParamTypeClasses #-}

5+{-# language StandaloneKindSignatures #-}

6+{-# language UndecidableInstances #-}

8+module Rel8.Table.Projection

9+ ( Projection

10+ , Projectable( project )

11+ , Biprojectable( biproject )

12+ , Projecting

13+ , apply

14+ )

15+where

16+

17+-- base

18+import Data.Kind ( Constraint, Type )

19+import Prelude

20+

21+-- rel8

22+import Rel8.Schema.Field ( Field( Field ), fields )

23+import Rel8.Schema.HTable ( hfield, htabulate )

24+import Rel8.Table ( Columns, Context, Transpose, toColumns )

25+import Rel8.Table.Transpose ( Transposes )

26+

27+

28+-- | The constraint @'Projecting' a b@ ensures that @'Projection' a b@ is a

29+-- usable 'Projection'.

30+type Projecting :: Type -> Type -> Constraint

31+class

32+ ( Transposes (Context a) (Field a) a (Transpose (Field a) a)

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

34+ )

35+ => Projecting a b

36+instance

37+ ( Transposes (Context a) (Field a) a (Transpose (Field a) a)

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

39+ )

40+ => Projecting a b

41+

42+

43+-- | A @'Projection' a b@s is a special type of function @a -> b@ whereby the

44+-- resulting @b@ is guaranteed to be composed only from columns contained in

45+-- @a@.

46+type Projection :: Type -> Type -> Type

47+type Projection a b = Transpose (Field a) a -> Transpose (Field a) b

48+

49+

50+-- | @'Projectable' f@ means that @f@ is a kind of functor on 'Rel8.Table's

51+-- that allows the mapping of a 'Projection' over its underlying columns.

52+type Projectable :: (Type -> Type) -> Constraint

53+class Projectable f where

54+ -- | Map a 'Projection' over @f@.

55+ project :: Projecting a b

56+ => Projection a b -> f a -> f b

57+

58+

59+-- | @'Biprojectable' p@ means that @p@ is a kind of bifunctor on

60+-- 'Rel8.Table's that allows the mapping of a pair of 'Projection's over its

61+-- underlying columns.

62+type Biprojectable :: (Type -> Type -> Type) -> Constraint

63+class Biprojectable p where

64+ -- | Map a pair of 'Projection's over @p@.

65+ biproject :: (Projecting a b, Projecting c d)

66+ => Projection a b -> Projection c d -> p a c -> p b d

67+

68+

69+apply :: Projecting a b

70+ => Projection a b -> Columns a context -> Columns b context

71+apply f a = case toColumns (f fields) of

72+ bs -> htabulate $ \field -> case hfield bs field of

73+ Field field' -> hfield a field'

src/Rel8/Table/Recontextualize.hsdeleted−104

@@ -1,104 +0,0 @@

1−{-# language DataKinds #-}

2−{-# language FlexibleInstances #-}

3−{-# language FunctionalDependencies #-}

4−{-# language StandaloneKindSignatures #-}

5−{-# language TypeFamilies #-}

6−{-# language UndecidableInstances #-}

7−{-# language UndecidableSuperClasses #-}

8−

9−module Rel8.Table.Recontextualize

10− ( Recontextualize

11− )

12−where

13−

14−-- base

15−import Data.Kind ( Constraint, Type )

16−import Prelude ()

17−

18−-- rel8

19−import Rel8.Schema.Context ( Col )

20−import Rel8.Schema.HTable ( HTable )

21−import qualified Rel8.Schema.Kind as K

22−import Rel8.Schema.Spec ( KnownSpec )

23−import Rel8.Table ( Table, Congruent )

24−

25−

26−-- | @Recontextualize from to a b@ is evidence that the types @a@ and @b@ are

27−-- related, and that @b@ is the same type as @a@, but after changing the

28−-- context from the initial context @from@, to the new context @to@.

29−type Recontextualize :: K.Context -> K.Context -> Type -> Type -> Constraint

30−class

31− ( Table from a

32− , Table to b

33− , Congruent a b

34− , Recontextualize from from a a

35− , Recontextualize to to b b

36− , Recontextualize to from b a

37− ) => Recontextualize from to a b

38− | a -> from

39− , b -> to

40− , a to -> b

41− , b from -> a

42−

43−

44−instance KnownSpec spec => Recontextualize from to (Col from spec) (Col to spec)

45−

46−

47−instance HTable t => Recontextualize from to (t (Col from)) (t (Col to))

48−

49−

50−instance

51− ( Recontextualize from to a1 b1

52− , Recontextualize from to a2 b2

53− )

54− => Recontextualize from to (a1, a2) (b1, b2)

55−

56−

57−instance

58− ( Recontextualize from to a1 b1

59− , Recontextualize from to a2 b2

60− , Recontextualize from to a3 b3

61− )

62− => Recontextualize from to (a1, a2, a3) (b1, b2, b3)

63−

64−

65−instance

66− ( Recontextualize from to a1 b1

67− , Recontextualize from to a2 b2

68− , Recontextualize from to a3 b3

69− , Recontextualize from to a4 b4

70− )

71− => Recontextualize from to (a1, a2, a3, a4) (b1, b2, b3, b4)

72−

73−

74−instance

75− ( Recontextualize from to a1 b1

76− , Recontextualize from to a2 b2

77− , Recontextualize from to a3 b3

78− , Recontextualize from to a4 b4

79− , Recontextualize from to a5 b5

80− )

81− => Recontextualize from to (a1, a2, a3, a4, a5) (b1, b2, b3, b4, b5)

82−

83−

84−instance

85− ( Recontextualize from to a1 b1

86− , Recontextualize from to a2 b2

87− , Recontextualize from to a3 b3

88− , Recontextualize from to a4 b4

89− , Recontextualize from to a5 b5

90− , Recontextualize from to a6 b6

91− )

92− => Recontextualize from to (a1, a2, a3, a4, a5, a6) (b1, b2, b3, b4, b5, b6)

93−

94−

95−instance

96− ( Recontextualize from to a1 b1

97− , Recontextualize from to a2 b2

98− , Recontextualize from to a3 b3

99− , Recontextualize from to a4 b4

100− , Recontextualize from to a5 b5

101− , Recontextualize from to a6 b6

102− , Recontextualize from to a7 b7

103− )

104− => Recontextualize from to (a1, a2, a3, a4, a5, a6, a7) (b1, b2, b3, b4, b5, b6, b7)

src/Rel8/Table/Rel8able.hs+14−21

@@ -20,69 +20,62 @@ import Prelude ()

2020-- rel8

2121import Rel8.Expr ( Expr )

2222import qualified Rel8.Kind.Algebra as K

23+import Rel8.Kind.Context ( Reifiable, contextSing )

2324import Rel8.Generic.Rel8able

2425 ( Rel8able, Algebra

2526 , GColumns, gfromColumns, gtoColumns

2627 , GFromExprs, gfromResult, gtoResult

2728 )

28−import Rel8.Schema.Context.Virtual ( Virtual, virtual )

2929import qualified Rel8.Schema.Kind as K

3030import Rel8.Schema.HTable ( HConstrainTable, hdicts )

3131import Rel8.Schema.Null ( Sql )

3232import Rel8.Schema.Result ( Result )

3333import Rel8.Table

34− ( Table, Columns, Context, Congruent, fromColumns, toColumns

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

3535 , FromExprs, fromResult, toResult

36+ , Transpose

3637 )

37−import Rel8.Schema.Spec.Constrain ( ConstrainSpec )

3838import Rel8.Table.ADT ( ADT )

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

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

41−import Rel8.Table.Recontextualize ( Recontextualize )

4241import Rel8.Table.Serialize ( ToExprs )

4342import Rel8.Type.Eq ( DBEq )

4443import Rel8.Type.Ord ( DBOrd )

4544

4645

47−instance (Rel8able t, Virtual context) => Table context (t context) where

46+instance (Rel8able t, Reifiable context, context ~ context') =>

47+ Table context' (t context)

48+ where

4849 type Columns (t context) = GColumns t

4950 type Context (t context) = context

5051 type FromExprs (t context) = GFromExprs t

52+ type Transpose to (t context) = t to

5153

52− fromColumns = gfromColumns virtual

53− toColumns = gtoColumns virtual

54+ fromColumns = gfromColumns contextSing

55+ toColumns = gtoColumns contextSing

5456 fromResult = gfromResult @t

5557 toResult = gtoResult @t

5658

5759

58−instance

59− ( Rel8able t

60− , Virtual from

61− , Virtual to

62− , Congruent (t from) (t to)

63− )

64− => Recontextualize from to (t from) (t to)

65−

66−

6760instance

6861 ( context ~ Expr

6962 , Rel8able t

70− , HConstrainTable (Columns (t context)) (ConstrainSpec (Sql DBEq))

63+ , HConstrainTable (Columns (t context)) (Sql DBEq)

7164 )

7265 => EqTable (t context)

7366 where

74− eqTable = hdicts @(Columns (t context)) @(ConstrainSpec (Sql DBEq))

67+ eqTable = hdicts @(Columns (t context)) @(Sql DBEq)

7568

7669

7770instance

7871 ( context ~ Expr

7972 , Rel8able t

80− , HConstrainTable (Columns (t context)) (ConstrainSpec (Sql DBEq))

81− , HConstrainTable (Columns (t context)) (ConstrainSpec (Sql DBOrd))

73+ , HConstrainTable (Columns (t context)) (Sql DBEq)

74+ , HConstrainTable (Columns (t context)) (Sql DBOrd)

8275 )

8376 => OrdTable (t context)

8477 where

85− ordTable = hdicts @(Columns (t context)) @(ConstrainSpec (Sql DBOrd))

78+ ordTable = hdicts @(Columns (t context)) @(Sql DBOrd)

8679

8780

8881instance

src/Rel8/Table/Serialize.hs+10−17

@@ -10,12 +10,13 @@

1010{-# language UndecidableInstances #-}

1111

1212module Rel8.Table.Serialize

13− ( Serializable, lit, parse

13+ ( Serializable, lit, litHTable, parse

1414 , ToExprs

1515 )

1616where

1717

1818-- base

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

1920import Data.Kind ( Constraint, Type )

2021import Data.List.NonEmpty ( NonEmpty )

2122import Prelude

@@ -24,12 +25,12 @@ import Prelude

2425import qualified Hasql.Decoders as Hasql

2526

2627-- rel8

27−import Rel8.Expr ( Expr, Col( E ) )

28+import Rel8.Expr ( Expr )

2829import Rel8.Expr.Serialize ( slitExpr, sparseValue )

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

3031import Rel8.Schema.Null ( NotNull, Sql )

31−import Rel8.Schema.Result ( Col( R ), Result )

32−import Rel8.Schema.Spec ( SSpec(..), KnownSpec )

32+import Rel8.Schema.Result ( Result )

33+import Rel8.Schema.Spec ( Spec(..) )

3334import Rel8.Table ( Table, fromColumns, FromExprs, fromResult, toResult )

3435import Rel8.Type ( DBType )

3536

@@ -115,14 +116,6 @@ instance

115116 => ToExprs x (a, b, c, d, e, f, g)

116117

117118

118−instance (HTable t, result ~ Col Result, x ~ t (Col Expr)) =>

119− ToExprs x (t result)

120−

121−

122−instance (KnownSpec spec, x ~ Col Expr spec) =>

123− ToExprs x (Col Result spec)

124−

125−

126119-- | @Serializable@ witnesses the one-to-one correspondence between the type

127120-- @sql@, which contains SQL expressions, and the type @haskell@, which

128121-- contains the Haskell decoding of rows containing @sql@ SQL expressions.

@@ -142,14 +135,14 @@ parse :: forall exprs a. Serializable exprs a => Hasql.Row a

142135parse = fromResult @_ @exprs <$> parseHTable

143136

144137

145−litHTable :: HTable t => t (Col Result) -> t (Col Expr)

138+litHTable :: HTable t => t Result -> t Expr

146139litHTable as = htabulate $ \field ->

147140 case hfield hspecs field of

148− SSpec {nullity, info} -> case hfield as field of

149− R value -> E (slitExpr nullity info value)

141+ Spec {nullity, info} -> case hfield as field of

142+ Identity value -> slitExpr nullity info value

150143

151144

152−parseHTable :: HTable t => Hasql.Row (t (Col Result))

145+parseHTable :: HTable t => Hasql.Row (t Result)

153146parseHTable = unwrapApplicative $ htabulateA $ \field ->

154147 WrapApplicative $ case hfield hspecs field of

155− SSpec {nullity, info} -> R <$> sparseValue nullity info

148+ Spec {nullity, info} -> Identity <$> sparseValue nullity info

src/Rel8/Table/These.hs+30−17

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

2020 , isThisTable, isThatTable, isThoseTable

2121 , hasHereTable, hasThereTable

2222 , justHereTable, justThereTable

23+ , alignMaybeTable

2324 , aggregateTheseTable

2425 , nameTheseTable

2526 )

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

2930import Data.Bifunctor ( Bifunctor, bimap )

3031import Data.Kind ( Type )

3132import Data.Maybe ( isJust )

32−import Prelude hiding ( undefined )

33+import Prelude hiding ( null, undefined )

3334

3435-- rel8

3536import Rel8.Aggregate ( Aggregate )

3637import Rel8.Expr ( Expr )

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

38−import Rel8.Expr.Null ( isNonNull )

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

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

3940import Rel8.Kind.Context ( Reifiable )

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

4142import Rel8.Schema.Dict ( Dict( Dict ) )

@@ -48,6 +49,7 @@ import Rel8.Schema.Name ( Name )

4849import Rel8.Table

4950 ( Table, Columns, Context, fromColumns, toColumns

5051 , FromExprs, fromResult, toResult

52+ , Transpose

5153 )

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

5355import Rel8.Table.Maybe

@@ -59,7 +61,7 @@ import Rel8.Table.Maybe

5961 )

6062import Rel8.Table.Nullify ( Nullify, guard )

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

62−import Rel8.Table.Recontextualize ( Recontextualize )

64+import Rel8.Table.Projection ( Biprojectable, Projectable, biproject, project )

6365import Rel8.Table.Serialize ( ToExprs )

6466import Rel8.Table.Undefined ( undefined )

6567import Rel8.Type.Tag ( MaybeTag )

@@ -88,10 +90,18 @@ data TheseTable context a b = TheseTable

8890 deriving stock Functor

8991

9092

93+instance Biprojectable (TheseTable context) where

94+ biproject f g (TheseTable a b) = TheseTable (project f a) (project g b)

95+

96+

9197instance Nullifiable context => Bifunctor (TheseTable context) where

9298 bimap f g (TheseTable a b) = TheseTable (fmap f a) (fmap g b)

9399

94100

101+instance Projectable (TheseTable context a) where

102+ project f (TheseTable a b) = TheseTable a (project f b)

103+

104+

95105instance (context ~ Expr, Table Expr a, Semigroup a) =>

96106 Apply (TheseTable context a)

97107 where

@@ -146,6 +156,8 @@ instance

146156 type Context (TheseTable context a b) = Context a

147157 type FromExprs (TheseTable context a b) =

148158 These (FromExprs a) (FromExprs b)

159+ type Transpose to (TheseTable context a b) =

160+ TheseTable to (Transpose to a) (Transpose to b)

149161

150162 toColumns TheseTable {here, there} = HTheseTable

151163 { hhereTag = hlabel $ HIdentity $ tag here

@@ -202,22 +214,13 @@ instance

202214 }

203215

204216

205−instance

206− ( Recontextualize from to a1 b1

207− , Recontextualize from to a2 b2

208− , Reifiable from, from ~ from'

209− , Reifiable to, to ~ to'

210− )

211− => Recontextualize from to (TheseTable from' a1 a2) (TheseTable to' b1 b2)

212−

213−

214217instance (EqTable a, EqTable b, context ~ Expr) =>

215218 EqTable (TheseTable context a b)

216219 where

217220 eqTable = HTheseTable

218− { hhereTag = hlabel (HType Dict)

221+ { hhereTag = hlabel (HIdentity Dict)

219222 , hhere = hlabel (eqTable @(Nullify context a))

220− , hthereTag = hlabel (HType Dict)

223+ , hthereTag = hlabel (HIdentity Dict)

221224 , hthere = hlabel (eqTable @(Nullify context b))

222225 }

223226

@@ -226,9 +229,9 @@ instance (OrdTable a, OrdTable b, context ~ Expr) =>

226229 OrdTable (TheseTable context a b)

227230 where

228231 ordTable = HTheseTable

229− { hhereTag = hlabel (HType Dict)

232+ { hhereTag = hlabel (HIdentity Dict)

230233 , hhere = hlabel (ordTable @(Nullify context a))

231− , hthereTag = hlabel (HType Dict)

234+ , hthereTag = hlabel (HIdentity Dict)

232235 , hthere = hlabel (ordTable @(Nullify context b))

233236 }

234237

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

286289justThereTable = there

287290

288291

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+

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

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

291304thisTable a = TheseTable (justTable a) nothingTable

src/Rel8/Table/Transpose.hsnew file+46

@@ -0,0 +1,46 @@

1+{-# language DataKinds #-}

2+{-# language FlexibleInstances #-}

3+{-# language FunctionalDependencies #-}

4+{-# language StandaloneKindSignatures #-}

5+{-# language TypeFamilies #-}

6+{-# language UndecidableInstances #-}

8+module Rel8.Table.Transpose

9+ ( Transposes

10+ )

11+where

12+

13+-- base

14+import Data.Kind ( Constraint, Type )

15+import Prelude ()

16+

17+-- rel8

18+import qualified Rel8.Schema.Kind as K

19+import Rel8.Table ( Table, Transpose, Congruent )

20+

21+

22+-- | @'Transposes' from to a b@ means that @a@ and @b@ are 'Table's, in the

23+-- @from@ and @to@ contexts respectively, which share the same underlying

24+-- structure. In other words, @b@ is a version of @a@ transposed from the

25+-- @from@ context to the @to@ context (and vice versa).

26+type Transposes :: K.Context -> K.Context -> Type -> Type -> Constraint

27+class

28+ ( Table from a

29+ , Table to b

30+ , Congruent a b

31+ , b ~ Transpose to a

32+ , a ~ Transpose from b

33+ )

34+ => Transposes from to a b

35+ | a -> from

36+ , b -> to

37+ , a to -> b

38+ , b from -> a

39+instance

40+ ( Table from a

41+ , Table to b

42+ , Congruent a b

43+ , b ~ Transpose to a

44+ , a ~ Transpose from b

45+ )

46+ => Transposes from to a b

src/Rel8/Table/Undefined.hs+5−5

@@ -11,16 +11,16 @@ where

1111import Prelude hiding ( undefined )

1212

1313-- rel8

14−import Rel8.Expr ( Expr, Col( E ) )

14+import Rel8.Expr ( Expr )

1515import Rel8.Expr.Null ( snull, unsafeUnnullify )

1616import Rel8.Schema.HTable ( htabulate, hfield, hspecs )

1717import Rel8.Schema.Null ( Nullity( Null, NotNull ) )

18−import Rel8.Schema.Spec ( SSpec(..) )

18+import Rel8.Schema.Spec ( Spec(..) )

1919import Rel8.Table ( Table, fromColumns )

2020

2121

2222undefined :: Table Expr a => a

2323undefined = fromColumns $ htabulate $ \field -> case hfield hspecs field of

24− SSpec {nullity, info} -> case nullity of

25− Null -> E (snull info)

26− NotNull -> E (unsafeUnnullify (snull info))

24+ Spec {nullity, info} -> case nullity of

25+ Null -> snull info

26+ NotNull -> unsafeUnnullify (snull info)

src/Rel8/Table/Window.hsnew file+43

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

1+{-# language MonoLocalBinds #-}

3+module Rel8.Table.Window

4+ ( cumulative

5+ , cumulative_

6+ , currentRow

7+ )

8+where

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.hsnew file+640

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

1+{-# language FlexibleContexts #-}

2+{-# language MonoLocalBinds #-}

3+{-# language ScopedTypeVariables #-}

4+{-# language StandaloneKindSignatures #-}

5+{-# language TypeApplications #-}

6+{-# language TupleSections #-}

7+{-# language UndecidableInstances #-}

9+-- | "Rel8.Tabulate" provides an alternative API ('Tabulation') for writing

10+-- queries that complements the main "Rel8" API ('Query').

11+

12+module Rel8.Tabulate

13+ (

14+ Tabulation

15+

16+ -- * Interfacing with 'Query's

17+ , fromQuery

18+ , toQuery

19+ , liftQuery

20+ , through

21+ , lookup

22+

23+ -- * Aggregation and Ordering

24+ , aggregate

25+ , distinct

26+ , order

27+

28+ -- ** Magic 'Tabulation's

29+ -- $magic

30+ , count

31+ , optional

32+ , many

33+ , some

34+ , exists

35+ , present

36+ , absent

37+

38+ -- * Natural joins

39+ , align

40+ , alignWith

41+ , leftAlign

42+ , leftAlignWith

43+ , rightAlign

44+ , rightAlignWith

45+ , zip

46+ , zipWith

47+ , similarity

48+ , difference

49+ )

50+where

51+

52+-- base

53+import Control.Applicative ( (<|>), empty, liftA2 )

54+import Control.Monad ( liftM2 )

55+import Data.Bifunctor ( Bifunctor, bimap, first, second )

56+import Data.Foldable ( traverse_ )

57+import Data.Function ( on )

58+import Data.Functor.Contravariant ( Contravariant, (>$<), contramap )

59+import Data.Int ( Int64 )

60+import Data.Kind ( Type )

61+import Data.Maybe ( fromJust, fromMaybe )

62+import Prelude hiding ( lookup, zip, zipWith )

63+

64+-- bifunctors

65+import Data.Bifunctor.Clown ( Clown( Clown ), runClown )

66+

67+-- comonad

68+import Control.Comonad ( extract )

69+

70+-- opaleye

71+import qualified Opaleye.Aggregate as Opaleye

72+import qualified Opaleye.Order as Opaleye ( orderBy, distinctOnExplicit )

73+

74+-- profunctors

75+import Data.Profunctor ( dimap, lmap )

76+

77+-- product-profunctors

78+import Data.Profunctor.Product

79+ ( ProductProfunctor, (***!)

80+ , SumProfunctor, (+++!)

81+ )

82+import qualified Data.Profunctor.Product as PP

83+

84+-- rel8

85+import Rel8.Aggregate ( Aggregates )

86+import Rel8.Expr ( Expr )

87+import Rel8.Expr.Aggregate ( countStar )

88+import Rel8.Expr.Bool ( true )

89+import Rel8.Order ( Order( Order ) )

90+import Rel8.Query ( Query )

91+import qualified Rel8.Query.Exists as Q ( exists, present, absent )

92+import Rel8.Query.Filter ( where_ )

93+import Rel8.Query.List ( catNonEmptyTable )

94+import qualified Rel8.Query.Maybe as Q ( optional )

95+import Rel8.Query.Opaleye ( mapOpaleye, unsafePeekQuery )

96+import Rel8.Query.Rebind ( rebind )

97+import Rel8.Query.These ( alignBy )

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

99+import Rel8.Table.Aggregate ( hgroupBy, listAgg, nonEmptyAgg )

100+import Rel8.Table.Alternative

101+ ( AltTable, (<|>:)

102+ , AlternativeTable, emptyTable

103+ )

104+import Rel8.Table.Cols ( fromCols, toCols )

105+import Rel8.Table.Eq ( EqTable, (==:), eqTable )

106+import Rel8.Table.List ( ListTable( ListTable ) )

107+import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), maybeTable )

108+import Rel8.Table.NonEmpty ( NonEmptyTable( NonEmptyTable ) )

109+import Rel8.Table.Opaleye ( aggregator, unpackspec )

110+import Rel8.Table.Ord ( OrdTable )

111+import Rel8.Table.Order ( ascTable )

112+import Rel8.Table.Projection

113+ ( Biprojectable, biproject

114+ , Projectable, project

115+ , apply

116+ )

117+import Rel8.Table.These ( TheseTable( TheseTable ), theseTable )

118+

119+-- semigroupoids

120+import Data.Functor.Apply ( Apply, liftF2 )

121+import Data.Functor.Bind ( Bind, (>>-) )

122+

123+

124+type Key :: Type -> Type

125+type Key = Maybe

126+

127+

128+cat :: Table Expr k => Key k -> Query k

129+cat = maybe emptyTable pure

130+

131+

132+key :: (ProductProfunctor p, SumProfunctor p)

133+ => p a b -> p (Key a) (Key b)

134+key a = dimap from to (PP.empty +++! a)

135+ where

136+ from = maybe (Left ()) Right

137+ to = either (const Nothing) Just

138+

139+

140+keyed :: (ProductProfunctor p, SumProfunctor p)

141+ => p k l -> p a b -> p (Key k, a) (Key l, b)

142+keyed k a = key k ***! a

143+

144+

145+type Predicate :: Type -> Type

146+newtype Predicate a = Predicate (Maybe (a -> Expr Bool))

147+

148+

149+instance Contravariant Predicate where

150+ contramap f (Predicate a) = Predicate (lmap f <$> a)

151+

152+

153+instance Semigroup (Predicate k) where

154+ Predicate ma <> Predicate mb = Predicate $ ma <|> mb

155+

156+

157+instance Monoid (Predicate k) where

158+ mempty = Predicate Nothing

159+

160+

161+match :: EqTable k => Key k -> Predicate k

162+match = Predicate . fmap (==:)

163+

164+

165+ensure :: Predicate k -> Key k -> Query ()

166+ensure (Predicate mp) = traverse_ (\k -> traverse_ (\p -> where_ (p k)) mp)

167+

168+

169+-- | A @'Tabulation' k a@ is like a @'Query' a@, except that each row also

170+-- has a key @k@ in addition to the value @a@. 'Tabulation's can be composed

171+-- monadically just like 'Query's, but the resulting join is more like a

172+-- @NATURAL JOIN@ (based on the common key column(s) @k@) than the

173+-- @CROSS JOIN@ given by 'Query'.

174+--

175+-- Another way to think of @'Tabulation' k a@ is as analogous to @Map k a@ in

176+-- the same way @'Query' a@ is analogous to @[a]@. However, there's nothing

177+-- stopping a 'Tabulation' from containing multiple rows with the same key, so

178+-- technically @Map k (NonEmpty a)@ is more accurate.

179+--

180+-- 'Tabulation's can be created from 'Query's with 'fromQuery' and 'liftQuery'

181+-- and converted back to 'Query's with 'lookup' and 'toQuery' (though note the

182+-- caveats that come with the latter).

183+type Tabulation :: Type -> Type -> Type

184+newtype Tabulation k a = Tabulation (Predicate k -> Query (Key k, a))

185+

186+

187+instance Biprojectable Tabulation where

188+ biproject f g =

189+ bimap

190+ (fromColumns . apply f . toColumns)

191+ (fromColumns . apply g . toColumns)

192+

193+

194+instance Bifunctor Tabulation where

195+ bimap f g (Tabulation a) = Tabulation $ \p ->

196+ bimap (fmap f) g <$> a (f >$< p)

197+

198+

199+instance Functor (Tabulation k) where

200+ fmap = second

201+

202+

203+instance Projectable (Tabulation k) where

204+ project f = fmap (fromColumns . apply f . toColumns)

205+

206+

207+-- | If @'Tabulation' k a@ is @Map k (NonEmpty a)@, then @(<.>)@ is

208+-- @intersectionWith (liftA2 (<*>))@

209+instance EqTable k => Apply (Tabulation k) where

210+ liftF2 = liftA2

211+

212+

213+-- | @pure = 'liftQuery' . pure@

214+instance EqTable k => Applicative (Tabulation k) where

215+ pure = liftQuery . pure

216+ liftA2 = liftM2

217+

218+

219+instance EqTable k => Bind (Tabulation k) where

220+ Tabulation as >>- f = Tabulation $ \p -> do

221+ (k, a) <- as p

222+ case f a of

223+ Tabulation bs -> do

224+ let p' = match k

225+ (k', b) <- bs (p' <> p)

226+ ensure p' k'

227+ pure (k' <|> k, b)

228+

229+

230+instance EqTable k => Monad (Tabulation k) where

231+ (>>=) = (>>-)

232+

233+

234+-- | If @'Tabulation' k a@ is @Map k (NonEmpty a)@, then @(<|>:)@ is

235+-- @unionWith (<>)@.

236+instance EqTable k => AltTable (Tabulation k) where

237+ tas <|>: tbs = do

238+ eas <- peek tas

239+ ebs <- peek tbs

240+ case (eas, ebs) of

241+ (Left as, Left bs) -> liftQuery $ as <|>: bs

242+ (Right as, Right bs) -> fromQuery $ as <|>: bs

243+ _ -> catNonEmptyTable `through` ((<>) `on` some) tas tbs

244+

245+

246+instance EqTable k => AlternativeTable (Tabulation k) where

247+ emptyTable = Tabulation $ const $ fmap (empty,) emptyTable

248+

249+

250+-- | If @'Tabulation' k a@ is @Map k (NonEmpty a)@, then @(<>)@ is

251+-- @unionWith (liftA2 (<>))@.

252+instance (EqTable k, Table Expr a, Semigroup a) => Semigroup (Tabulation k a)

253+ where

254+ (<>) = alignWith (theseTable id id (<>))

255+

256+

257+instance (EqTable k, Table Expr a, Semigroup a) => Monoid (Tabulation k a)

258+ where

259+ mempty = emptyTable

260+

261+

262+-- | Any 'Query' of key-value pairs @(k, a)@ can be a @'Tabulation' k a@.

263+fromQuery :: Query (k, a) -> Tabulation k a

264+fromQuery = Tabulation . const . fmap (first pure)

265+

266+

267+-- | Convert a @'Tabulation' k a@ back into a 'Query' of key-value pairs.

268+--

269+-- Note that the result of a 'toQuery' is undefined (will always return zero

270+-- rows) on 'Tabulation's constructed with 'liftQuery' or 'pure'. So while

271+-- @toQuery . fromQuery@ is always @id@, @fromQuery . toQuery@ is not.

272+--

273+-- A safer, more predictable alternative to 'toQuery' is to use 'lookup' with

274+-- an explicit set of keys:

275+--

276+-- @

277+-- do

278+-- k <- keys

279+-- a <- lookup k tabulation

280+-- pure (k, a)

281+-- @

282+--

283+-- Having said that, in practice, most legitimate uses of 'Tabulation' will

284+-- have a well-defined 'toQuery'. It would be possible in theory to encode

285+-- the necessary invariants at the type level using an indexed monad, but we

286+-- would lose the ability to use @do@-notation, which is the main benefit

287+-- of having 'Tabulation' as a monad in the first place.

288+--

289+-- In particular, @'toQuery' t@ is well-defined for any 'Tabulation' @t@

290+-- defined as @t = fromQuery _@. @'toQuery' t@ is also well-defined for any

291+-- 'Tabulation' @t@ defined as @t = t' >>= _@ or @t = t' *> _@ where

292+-- @'toQuery' t'@ is well-defined. There are other valid permutations too.

293+-- Generally, anything that uses 'fromQuery' at some point, unless wrapped in

294+-- a top-level 'present' or 'absent', will have a well-defined 'toQuery'.

295+toQuery :: Table Expr k => Tabulation k a -> Query (k, a)

296+toQuery (Tabulation f) = do

297+ (mk, a) <- f mempty

298+ k <- cat mk

299+ pure (k, a)

300+

301+

302+-- | A @'Query' a@ can be treated as a @'Tabulation' k a@ where the given @a@

303+-- values exist at every possible key @k@.

304+liftQuery :: Query a -> Tabulation k a

305+liftQuery = Tabulation . const . fmap (empty,)

306+

307+

308+-- | Run a Kleisli arrow in the the 'Query' monad \"through\" a 'Tabulation'.

309+-- Useful for 'Rel8.filter'ing a 'Tabulation'.

310+--

311+-- @

312+-- 'Rel8.filter' ((>=. 30) . userAge) `'through'` usersById

313+-- @

314+through :: (a -> Query b) -> Tabulation k a -> Tabulation k b

315+through f (Tabulation as) = Tabulation $ \p -> do

316+ (k, a) <- as p

317+ b <- f a

318+ pure (k, b)

319+infixr 1 `through`

320+

321+

322+-- | @'lookup' k t@ returns the value(s) at the key @k@ in the tabulation @t@.

323+lookup :: EqTable k => k -> Tabulation k a -> Query a

324+lookup k (Tabulation f) = do

325+ (k', a) <- f p

326+ ensure p k'

327+ pure a

328+ where

329+ p = match (pure k)

330+

331+

332+-- | 'aggregate' aggregates the values within each key of a

333+-- 'Tabulation'. There is an implicit @GROUP BY@ on all the key columns.

334+aggregate :: forall k aggregates exprs.

335+ ( EqTable k

336+ , Aggregates aggregates exprs

337+ )

338+ => Tabulation k aggregates -> Tabulation k exprs

339+aggregate (Tabulation f) = Tabulation $

340+ mapOpaleye (Opaleye.aggregate (keyed haggregator aggregator)) .

341+ fmap (first (fmap (hgroupBy (eqTable @k) . toColumns))) .

342+ f

343+ where

344+ haggregator = dimap fromColumns fromCols aggregator

345+

346+

347+-- | 'distinct' ensures a 'Tabulation' has at most one value for

348+-- each key, i.e., it drops duplicates. In general it keeps only the

349+-- \"first\" value it encounters for each key, but note that \"first\" is

350+-- undefined unless you first call 'order'.

351+distinct :: EqTable k => Tabulation k a -> Tabulation k a

352+distinct (Tabulation f) = Tabulation $

353+ mapOpaleye (Opaleye.distinctOnExplicit (key unpackspec) fst) . f

354+

355+

356+-- | 'order' orders the /values/ of a 'Tabulation' within their

357+-- respective keys. This specifies a defined order for 'distinct'.

358+-- It also defines the order of the lists produced by 'many' and

359+-- 'some'.

360+order :: OrdTable k => Order a -> Tabulation k a -> Tabulation k a

361+order ordering (Tabulation f) =

362+ Tabulation $ mapOpaleye (Opaleye.orderBy ordering') . f

363+ where

364+ Order ordering' = runClown (keyed (Clown ascTable) (Clown ordering))

365+

366+

367+-- $magic

368+--

369+-- Some of the following combinators produce \"magic\" 'Tabulation's. Let's

370+-- use 'count' as an example to demonstrate this concept. Consider

371+-- the following:

372+--

373+-- @

374+-- count $ fromQuery $ values

375+-- [ (lit 'a', lit True)

376+-- , (lit 'a', lit False)

377+-- , (lit 'b', lit True)

378+-- ]

379+-- @

380+--

381+-- You might expect this to be equivalent to the following 'Tabulation':

382+--

383+-- @

384+-- fromQuery $ values

385+-- [ (lit 'a', 2)

386+-- , (lit 'b', 1)

387+-- ]

388+-- @

389+--

390+-- However, it isn't quite. While the resulting 'Tabulation' does effectively

391+-- contain the above entries, it also behaves as though it contained the value

392+-- @0@ at every other possible key.

393+--

394+-- This means you can do:

395+--

396+-- @

397+-- do

398+-- user <- usersById

399+-- orderCount <- count ordersByUserId

400+-- @

401+--

402+-- To see how many orders a user has (getting @0@ if they have no orders).

403+

404+

405+-- | 'count' returns a count of how many entries are in the given

406+-- 'Tabulation' at each key.

407+--

408+-- The resulting 'Tabulation' is \"magic\" in that the value @0@ exists at

409+-- every possible key that wasn't in the given 'Tabulation'.

410+count :: EqTable k => Tabulation k a -> Tabulation k (Expr Int64)

411+count =

412+ fmap (maybeTable 0 id) .

413+ optional .

414+ aggregate .

415+ fmap (const countStar)

416+

417+

418+-- | 'optional' produces a \"magic\" 'Tabulation' whereby each

419+-- entry in the given 'Tabulation' is wrapped in 'Rel8.justTable', and every

420+-- other possible key contains a single 'Rel8.nothingTable'.

421+--

422+-- This is used to implement 'leftAlignWith'.

423+optional :: Tabulation k a -> Tabulation k (MaybeTable Expr a)

424+optional (Tabulation f) = Tabulation $ \p -> case p of

425+ Predicate Nothing -> fmap pure <$> f p

426+ _ -> fmap (\m -> (empty, snd <$> m)) $ Q.optional $ do

427+ (k, a) <- f p

428+ ensure p k

429+ pure (k, a)

430+

431+

432+-- | 'many' aggregates each entry with a particular key into a

433+-- single entry with all of the values contained in a 'ListTable'.

434+--

435+-- 'order' can be used to give this 'ListTable' a defined order.

436+--

437+-- The resulting 'Tabulation' is \"magic\" in that the value

438+-- @'Rel8.listTable []'@ exists at every possible key that wasn't in the given

439+-- 'Tabulation'.

440+many :: (EqTable k, Table Expr a)

441+ => Tabulation k a -> Tabulation k (ListTable Expr a)

442+many =

443+ fmap (maybeTable mempty (\(ListTable a) -> ListTable a)) .

444+ optional .

445+ aggregate .

446+ fmap (listAgg . toCols)

447+

448+

449+-- | 'some' aggregates each entry with a particular key into a

450+-- single entry with all of the values contained in a 'NonEmptyTable'.

451+--

452+-- 'order' can be used to give this 'NonEmptyTable' a defined order.

453+some :: (EqTable k, Table Expr a)

454+ => Tabulation k a -> Tabulation k (NonEmptyTable Expr a)

455+some =

456+ fmap (\(NonEmptyTable a) -> NonEmptyTable a) .

457+ aggregate .

458+ fmap (nonEmptyAgg . toCols)

459+

460+

461+-- | 'exists' produces a \"magic\" 'Tabulation' which contains the

462+-- value 'Rel8.true' at each key in the given 'Tabulation', and the value

463+-- 'Rel8.false' at every other possible key.

464+exists :: Tabulation k a -> Tabulation k (Expr Bool)

465+exists (Tabulation f) = Tabulation $ \p -> case p of

466+ Predicate Nothing -> (true <$) <$> f p

467+ _ -> fmap (empty,) $ Q.exists $ do

468+ (k, _) <- f p

469+ ensure p k

470+

471+

472+-- | 'present' produces a 'Tabulation' where a single @()@ row

473+-- exists for every key that was present in the given 'Tabulation'.

474+--

475+-- This is used to implement 'similarity'.

476+present :: Tabulation k a -> Tabulation k ()

477+present (Tabulation f) = Tabulation $ \p -> do

478+ Q.present $ do

479+ (k, _) <- f p

480+ ensure p k

481+ pure (empty, ())

482+

483+

484+-- | 'absent' produces a 'Tabulation' where a single @()@ row exists

485+-- at every possible key that absent from the given 'Tabulation'.

486+--

487+-- This is used to implement 'difference'.

488+absent :: Tabulation k a -> Tabulation k ()

489+absent (Tabulation f) = Tabulation $ \p -> do

490+ Q.absent $ do

491+ (k, _) <- f p

492+ ensure p k

493+ pure (empty, ())

494+

495+

496+-- | Performs a @NATURAL FULL OUTER JOIN@ based on the common key columns.

497+--

498+-- Analogous to 'Data.Semialign.align'.

499+align :: EqTable k

500+ => Tabulation k a -> Tabulation k b -> Tabulation k (TheseTable Expr a b)

501+align = alignWith id

502+

503+

504+-- | Performs a @NATURAL FULL OUTER JOIN@ based on the common key columns.

505+--

506+-- Analogous to 'Data.Semialign.alignWith'.

507+alignWith :: EqTable k

508+ => (TheseTable Expr a b -> c)

509+ -> Tabulation k a -> Tabulation k b -> Tabulation k c

510+alignWith f (Tabulation as) (Tabulation bs) = Tabulation $ \p -> do

511+ tkab <- liftF2 (alignBy condition) as bs p

512+ k <- traverse (rebind "key") $ recover $ bimap fst fst tkab

513+ let

514+ tab = bimap snd snd tkab

515+ pure (k, f tab)

516+ where

517+ condition (k, _) (k', _) = fromMaybe true (liftA2 (==:) k k')

518+ recover (TheseTable mma@(MaybeTable _ ma) mmb@(MaybeTable _ mb)) =

519+ case extract ma of

520+ Nothing -> extract mb

521+ Just a -> case extract mb of

522+ Nothing -> extract ma

523+ Just b -> case a <$ mma <|>: b <$ mmb of

524+ MaybeTable _ c -> pure (extract c)

525+

526+

527+-- | Performs a @NATURAL LEFT OUTER JOIN@ based on the common key columns.

528+--

529+-- Analogous to 'Data.Semialign.rpadZip'.

530+--

531+-- Note that you can achieve the same effect with 'optional' and the

532+-- 'Applicative' instance for 'Tabulation', i.e., this is just

533+-- @\left right -> liftA2 (,) left (optional right). You can also

534+-- use @do@-notation.

535+leftAlign :: EqTable k

536+ => Tabulation k a -> Tabulation k b -> Tabulation k (a, MaybeTable Expr b)

537+leftAlign = leftAlignWith (,)

538+

539+

540+-- | Performs a @NATURAL LEFT OUTER JOIN@ based on the common key columns.

541+--

542+-- Analogous to 'Data.Semialign.rpadZipWith'.

543+--

544+-- Note that you can achieve the same effect with 'optional' and the

545+-- 'Applicative' instance for 'Tabulation', i.e., this is just

546+-- @\f left right -> liftA2 f left (optional right). You can also

547+-- use @do@-notation.

548+leftAlignWith :: EqTable k

549+ => (a -> MaybeTable Expr b -> c)

550+ -> Tabulation k a -> Tabulation k b -> Tabulation k c

551+leftAlignWith f left right = liftA2 f left (optional right)

552+

553+

554+-- | Performs a @NATURAL RIGHT OUTER JOIN@ based on the common key columns.

555+--

556+-- Analogous to 'Data.Semialign.lpadZip'.

557+--

558+-- Note that you can achieve the same effect with 'optional' and the

559+-- 'Applicative' instance for 'Tabulation', i.e., this is just

560+-- @\left right -> liftA2 (flip (,)) right (optional left). You can

561+-- also use @do@-notation.

562+rightAlign :: EqTable k

563+ => Tabulation k a -> Tabulation k b -> Tabulation k (MaybeTable Expr a, b)

564+rightAlign = rightAlignWith (,)

565+

566+

567+-- | Performs a @NATURAL RIGHT OUTER JOIN@ based on the common key columns.

568+--

569+-- Analogous to 'Data.Semialign.lpadZipWith'.

570+--

571+-- Note that you can achieve the same effect with 'optional' and the

572+-- 'Applicative' instance for 'Tabulation', i.e., this is just

573+-- @\f left right -> liftA2 (flip f) right (optional left). You can

574+-- also use @do@-notation.

575+rightAlignWith :: EqTable k

576+ => (MaybeTable Expr a -> b -> c)

577+ -> Tabulation k a -> Tabulation k b -> Tabulation k c

578+rightAlignWith f left right = liftA2 (flip f) right (optional left)

579+

580+

581+-- | Performs a @NATURAL INNER JOIN@ based on the common key columns.

582+--

583+-- Analagous to 'Data.Semialign.zip'.

584+--

585+-- Note that you can achieve the same effect with the 'Applicative' instance

586+-- of 'Tabulation', i.e., this is just @'liftA2 (,)'@. You can also use

587+-- @do@-notation.

588+zip :: EqTable k

589+ => Tabulation k a -> Tabulation k b -> Tabulation k (a, b)

590+zip = zipWith (,)

591+

592+

593+-- | Performs a @NATURAL INNER JOIN@ based on the common key columns.

594+--

595+-- Analagous to 'Data.Semialign.zipWith'.

596+--

597+-- Note that you can achieve the same effect with the 'Applicative' instance

598+-- of 'Tabulation', i.e., this is just @'liftA2'@. You can also use

599+-- @do@-notation.

600+zipWith :: EqTable k

601+ => (a -> b -> c) -> Tabulation k a -> Tabulation k b -> Tabulation k c

602+zipWith = liftA2

603+

604+

605+-- | Performs a [@NATURAL SEMI JOIN@](https://en.wikipedia.org/wiki/Relational_algebra#Semijoin_%28%E2%8B%89%29%28%E2%8B%8A%29)

606+-- based on the common key columns.

607+--

608+-- The result is a subset of the left tabulation where only entries which have

609+-- a corresponding entry in the right tabulation are kept.

610+--

611+-- Note that you can achieve a similar effect with 'present' and the

612+-- 'Applicative' instance of 'Tabulation', i.e., this is just

613+-- @\left right -> left <* present right@. You can also use

614+-- @do@-notation.

615+similarity :: EqTable k => Tabulation k a -> Tabulation k b -> Tabulation k a

616+similarity a b = a <* present b

617+

618+

619+-- | Performs a [@NATURAL ANTI JOIN@](https://en.wikipedia.org/wiki/Relational_algebra#Antijoin_%28%E2%96%B7%29)

620+-- based on the common key columns.

621+--

622+-- The result is a subset of the left tabulation where only entries which do

623+-- not have a corresponding entry in the right tabulation are kept.

624+--

625+-- Note that you can achieve a similar effect with 'absent' and the

626+-- 'Applicative' instance of 'Tabulation', i.e., this is just

627+-- @\left right -> left <* absent right@. You can also use

628+-- @do@-notation.

629+difference :: EqTable k => Tabulation k a -> Tabulation k b -> Tabulation k a

630+difference a b = a <* absent b

631+

632+

633+-- | 'Tabulation's can be produced with either 'fromQuery' or 'liftQuery', and

634+-- in some cases we might want to treat these differently. 'peek' uses

635+-- 'unsafePeekQuery' to determine which type of 'Tabulation' we have.

636+peek :: Tabulation k a -> Tabulation k (Either (Query a) (Query (k, a)))

637+peek (Tabulation f) = Tabulation $ \p ->

638+ pure $ (empty,) $ case unsafePeekQuery (f p) of

639+ (Nothing, _) -> Left $ fmap snd (f p)

640+ (Just _, _) -> Right $ fmap (first fromJust) (f p)

src/Rel8/Type.hs+9−8

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

1+{-# language FlexibleContexts #-}

12{-# language FlexibleInstances #-}

23{-# language MonoLocalBinds #-}

34{-# language MultiWayIf #-}

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

127128instance DBType Float where

128129 typeInformation = TypeInformation

129130 { encode = \x -> Opaleye.ConstExpr

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

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

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

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

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

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

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

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

134135 , decode = Hasql.float4

135136 , typeName = "float4"

136137 }

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

140141instance DBType Double where

141142 typeInformation = TypeInformation

142143 { encode = \x -> Opaleye.ConstExpr

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

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

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

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

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

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

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

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

147148 , decode = Hasql.float8

148149 , typeName = "float8"

149150 }

src/Rel8/Type/Composite.hs+13−12

@@ -20,6 +20,7 @@ where

2020

2121-- base

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

23+import Data.Functor.Identity ( Identity( Identity ) )

2324import Data.Kind ( Constraint, Type )

2425import Prelude

2526

@@ -30,19 +31,19 @@ import qualified Hasql.Decoders as Hasql

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

3132

3233-- rel8

33−import Rel8.Expr ( Col( E ), Expr )

34+import Rel8.Expr ( Expr )

3435import Rel8.Expr.Opaleye ( castExpr, fromPrimExpr, toPrimExpr )

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

36−import Rel8.Schema.Name ( Col( N ), Name( Name ) )

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

3738import Rel8.Schema.Null ( Nullity( Null, NotNull ) )

38−import Rel8.Schema.Result ( Col( R ), Result )

39−import Rel8.Schema.Spec ( SSpec( SSpec, nullity, info ) )

39+import Rel8.Schema.Result ( Result )

40+import Rel8.Schema.Spec ( Spec( Spec, nullity, info ) )

4041import Rel8.Table ( fromColumns, toColumns, fromResult, toResult )

4142import Rel8.Table.Eq ( EqTable )

4243import Rel8.Table.HKD ( HKD, HKDable )

4344import Rel8.Table.Ord ( OrdTable )

4445import Rel8.Table.Rel8able ()

45−import Rel8.Table.Serialize ( lit )

46+import Rel8.Table.Serialize ( litHTable )

4647import Rel8.Type ( DBType, typeInformation )

4748import Rel8.Type.Eq ( DBEq )

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

@@ -68,7 +69,7 @@ newtype Composite a = Composite

6869instance DBComposite a => DBType (Composite a) where

6970 typeInformation = TypeInformation

7071 { decode = Hasql.composite (Composite . fromResult @_ @(HKD a Expr) <$> decoder)

71− , encode = encoder . lit . toResult @_ @(HKD a Expr) . unComposite

72+ , encode = encoder . litHTable . toResult @_ @(HKD a Expr) . unComposite

7273 , typeName = compositeTypeName @a

7374 }

7475

@@ -112,23 +113,23 @@ compose = castExpr . fromPrimExpr . encoder . toColumns

112113decompose :: forall a. DBComposite a => Expr a -> HKD a Expr

113114decompose (toPrimExpr -> a) = fromColumns $ htabulate \field ->

114115 case hfield names field of

115− N (Name name) -> case hfield hspecs field of

116− SSpec {} -> E $ fromPrimExpr $ Opaleye.CompositeExpr a name

116+ Name name -> case hfield hspecs field of

117+ Spec {} -> fromPrimExpr $ Opaleye.CompositeExpr a name

117118 where

118119 names = toColumns (compositeFields @a)

119120

120121

121−decoder :: HTable t => Hasql.Composite (t (Col Result))

122+decoder :: HTable t => Hasql.Composite (t Result)

122123decoder = unwrapApplicative $ htabulateA \field ->

123124 case hfield hspecs field of

124− SSpec {nullity, info} -> WrapApplicative $ R <$>

125+ Spec {nullity, info} -> WrapApplicative $ Identity <$>

125126 case nullity of

126127 Null -> Hasql.field $ Hasql.nullable $ decode info

127128 NotNull -> Hasql.field $ Hasql.nonNullable $ decode info

128129

129130

130−encoder :: HTable t => t (Col Expr) -> Opaleye.PrimExpr

131+encoder :: HTable t => t Expr -> Opaleye.PrimExpr

131132encoder a = Opaleye.FunExpr "ROW" exprs

132133 where

133134 exprs = getConst $ htabulateA \field -> case hfield a field of

134− E (toPrimExpr -> expr) -> Const [expr]

135+ expr -> Const [toPrimExpr expr]

src/Rel8/Type/Enum.hs+1

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

106106

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

108108-- fields).

109+type Enumable :: Type -> Constraint

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

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

111112

src/Rel8/Type/JSONBEncoded.hs+4

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

1+{-# language StandaloneKindSignatures #-}

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

35-- aeson

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

79-- base

810import Data.Bifunctor ( first )

11+import Data.Kind ( Type )

912import Prelude

1013

1114-- hasql

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

2023

2124

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

26+type JSONBEncoded :: Type -> Type

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

2428

2529

src/Rel8/Type/JSONEncoded.hs+4

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

1+{-# language StandaloneKindSignatures #-}

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

35-- aeson

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

57import Data.Aeson.Types ( parseEither )

79-- base

10+import Data.Kind ( Type )

811import Prelude

912

1013-- rel8

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

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

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

1720-- classes.

21+type JSONEncoded :: Type -> Type

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

1923

2024

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

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

1818

1919-- rel8

2020import Rel8.Type ( DBType )

21+import Rel8.Type.Ord ( DBOrd )

2122

2223-- scientific

2324import Data.Scientific ( Scientific )

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

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

4041-- 'fromIntegral'.

4142type DBIntegral :: Type -> Constraint

42−class DBNum a => DBIntegral a

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

4344instance DBIntegral Int16

4445instance DBIntegral Int32

4546instance DBIntegral Int64

4647

4748

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

50+type DBFractional :: Type -> Constraint

4951class DBNum a => DBFractional a

5052instance DBFractional Float

5153instance DBFractional Double

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

5355

5456

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

58+type DBFloating :: Type -> Constraint

5659class DBFractional a => DBFloating a

5760instance DBFloating Float

5861instance DBFloating Double

src/Rel8/Type/Ord.hs−2

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

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

7676type DBMax :: Type -> Constraint

7777class DBOrd a => DBMax a

78−instance DBMax Bool

7978instance DBMax Char

8079instance DBMax Int16

8180instance DBMax Int32

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

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

102101type DBMin :: Type -> Constraint

103102class DBOrd a => DBMin a

104−instance DBMin Bool

105103instance DBMin Char

106104instance DBMin Int16

107105instance DBMin Int32

src/Rel8/Type/ReadShow.hs+3

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

11{-# language ScopedTypeVariables #-}

2+{-# language StandaloneKindSignatures #-}

23{-# language TypeApplications #-}

34{-# language ViewPatterns #-}

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

78-- base

9+import Data.Kind ( Type )

810import Data.Proxy ( Proxy( Proxy ) )

911import Data.Typeable ( Typeable, typeRep )

1012import Prelude

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

2022

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

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

25+type ReadShow :: Type -> Type

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

2427

2528

src/Rel8/Type/Tag.hs+1

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

9090 memptyExpr = litExpr mempty

9191

9292

93+type Tag :: Type

9394newtype Tag = Tag Text

9495 deriving newtype

9596 ( 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 #-}

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+288−178

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

1+{-# language BangPatterns #-}

12{-# language BlockArguments #-}

2−{-# language DataKinds #-}

33{-# language DeriveAnyClass #-}

44{-# language DeriveGeneric #-}

55{-# language DerivingStrategies #-}

6−{-# language DisambiguateRecordFields #-}

76{-# language FlexibleContexts #-}

87{-# language FlexibleInstances #-}

9−{-# language GADTs #-}

8+{-# language MonoLocalBinds #-}

109{-# language NamedFieldPuns #-}

1110{-# language OverloadedStrings #-}

1211{-# language RecordWildCards #-}

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

1413{-# language StandaloneDeriving #-}

1514{-# language TypeApplications #-}

1615

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

18−

1916module Main

2017 ( main

2118 )

2219where

2320

2421-- base

25−import Control.Applicative ( liftA2, liftA3 )

26−import Control.Monad (void)

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

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

23+import Control.Exception ( bracket, throwIO )

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

2825import Data.Bifunctor ( bimap )

2926import Data.Foldable ( for_ )

3027import Data.Int ( Int32, Int64 )

@@ -38,25 +35,27 @@ import GHC.Generics ( Generic )

3835import qualified Data.ByteString.Lazy

3936

4037-- case-insensitive

41−import Data.CaseInsensitive (mk)

38+import Data.CaseInsensitive ( mk )

4239

4340-- containers

41+import Data.Containers.ListUtils ( nubOrdOn )

4442import qualified Data.Map.Strict as Map

4543

4644-- hasql

47−import Hasql.Connection ( Connection, acquire, release )

45+import Hasql.Connection ( Connection, acquire, release )

4846import Hasql.Session ( sql, run )

4947

48+-- hasql-transaction

49+import Hasql.Transaction ( Transaction, condemn, statement )

50+import qualified Hasql.Transaction.Sessions as Hasql

51+

5052-- hedgehog

5153import Hedgehog ( property, (===), forAll, cover, diff, evalM, PropertyT, TestT, test, Gen )

5254import qualified Hedgehog.Gen as Gen

5355import qualified Hedgehog.Range as Range

5456

55−-- lifted-base

56−import Control.Exception.Lifted ( bracket, throwIO, bracket_ )

57−

58−-- monad-control

59−import Control.Monad.Trans.Control ( MonadBaseControl )

57+-- mmorph

58+import Control.Monad.Morph ( hoist )

6059

6160-- rel8

6261import Rel8 ( Result )

@@ -72,12 +71,16 @@ import Test.Tasty

7271import Test.Tasty.Hedgehog ( testProperty )

7372

7473-- text

75−import Data.Text (Text, pack)

74+import Data.Text ( Text, pack, unpack )

7675import qualified Data.Text.Lazy

76+import Data.Text.Encoding ( decodeUtf8 )

7777

7878-- time

7979import Data.Time

8080

81+-- transformers

82+import Control.Monad.Trans.Class ( lift )

83+

8184-- tmp-postgres

8285import qualified Database.Postgres.Temp as TmpPostgres

8386

@@ -113,11 +116,13 @@ tests =

113116 , testCatMaybeTable getTestDatabase

114117 , testCatMaybe getTestDatabase

115118 , testMaybeTable getTestDatabase

119+ , testAggregateMaybeTable getTestDatabase

116120 , testNestedTables getTestDatabase

117121 , testMaybeTableApplicative getTestDatabase

118122 , testLogicalFixities getTestDatabase

119123 , testUpdate getTestDatabase

120124 , testDelete getTestDatabase

125+ , testUpsert getTestDatabase

121126 , testSelectNestedPairs getTestDatabase

122127 , testSelectArray getTestDatabase

123128 , testNestedMaybeTable getTestDatabase

@@ -133,6 +138,7 @@ tests =

133138 flip run conn do

134139 sql "CREATE EXTENSION citext"

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

136142 sql "CREATE SEQUENCE test_seq"

137143

138144 return db

@@ -140,19 +146,21 @@ tests =

140146 stopTestDatabase = TmpPostgres.stop

141147

142148

149+connect :: TmpPostgres.DB -> IO Connection

150+connect = acquire . TmpPostgres.toConnectionString >=> either (maybe empty (fail . unpack . decodeUtf8)) pure

151+

152+

143153databasePropertyTest

144154 :: TestName

145− -> (((Connection -> TestT IO ()) -> PropertyT IO ()) -> PropertyT IO ())

155+ -> ((TestT Transaction () -> PropertyT IO ()) -> PropertyT IO ())

146156 -> IO TmpPostgres.DB -> TestTree

147157databasePropertyTest testName f getTestDatabase =

148− withResource connect release $ \c ->

158+ withResource (connect =<< getTestDatabase) release $ \c ->

149159 testProperty testName $ property do

150− connection <- liftIO c

151− f \g -> test $ rollingBack connection $ g connection

152−

153− where

154−

155− connect = either (error . show) return =<< acquire . TmpPostgres.toConnectionString =<< getTestDatabase

160+ connection <- lift c

161+ f $ test . hoist \m -> do

162+ e <- run (Hasql.transaction Hasql.Serializable Hasql.Write (m <* condemn)) connection

163+ either throwIO pure e

156164

157165

158166data TestTable f = TestTable

@@ -184,18 +192,17 @@ testSelectTestTable :: IO TmpPostgres.DB -> TestTree

184192testSelectTestTable = databasePropertyTest "Can SELECT TestTable" \transaction -> do

185193 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable

186194

187− transaction \connection -> do

188− void do

189− liftIO $ Rel8.insert connection

190− Rel8.Insert

191− { into = testTableSchema

192− , rows = map Rel8.lit rows

193− , onConflict = Rel8.DoNothing

194− , returning = Rel8.NumberOfRowsAffected

195− }

195+ transaction do

196+ selected <- lift do

197+ statement () $ Rel8.insert Rel8.Insert

198+ { into = testTableSchema

199+ , rows = Rel8.values $ map Rel8.lit rows

200+ , onConflict = Rel8.DoNothing

201+ , returning = pure ()

202+ }

196203

197− selected <- liftIO $ Rel8.select connection do

198− Rel8.each testTableSchema

204+ statement () $ Rel8.select do

205+ Rel8.each testTableSchema

199206

200207 sort selected === sort rows

201208

@@ -212,11 +219,12 @@ testWhere_ = databasePropertyTest "WHERE (Rel8.where_)" \transaction -> do

212219

213220 let expected = filter (\t -> testTableColumn2 t == magicBool) rows

214221

215− transaction \connection -> do

216− selected <- liftIO $ Rel8.select connection do

217− t <- Rel8.values $ Rel8.lit <$> rows

218− Rel8.where_ $ testTableColumn2 t Rel8.==. Rel8.lit magicBool

219− return t

222+ transaction do

223+ selected <- lift do

224+ statement () $ Rel8.select do

225+ t <- Rel8.values $ Rel8.lit <$> rows

226+ Rel8.where_ $ testTableColumn2 t Rel8.==. Rel8.lit magicBool

227+ return t

220228

221229 sort selected === sort expected

222230

@@ -229,11 +237,12 @@ testFilter :: IO TmpPostgres.DB -> TestTree

229237testFilter = databasePropertyTest "filter" \transaction -> do

230238 rows <- forAll $ Gen.list (Range.linear 1 10) genTestTable

231239

232− transaction \connection -> do

240+ transaction do

233241 let expected = filter testTableColumn2 rows

234242

235− selected <- liftIO $ Rel8.select connection

236− $ Rel8.filter testTableColumn2 =<< Rel8.values (Rel8.lit <$> rows)

243+ selected <- lift do

244+ statement () $ Rel8.select do

245+ Rel8.filter testTableColumn2 =<< Rel8.values (Rel8.lit <$> rows)

237246

238247 sort selected === sort expected

239248

@@ -248,9 +257,10 @@ testLimit = databasePropertyTest "LIMIT (Rel8.limit)" \transaction -> do

248257

249258 n <- forAll $ Gen.integral (Range.linear 0 10)

250259

251− transaction \connection -> do

252− selected <- liftIO $ Rel8.select connection do

253− Rel8.limit n $ Rel8.values (Rel8.lit <$> rows)

260+ transaction do

261+ selected <- lift do

262+ statement () $ Rel8.select do

263+ Rel8.limit n $ Rel8.values (Rel8.lit <$> rows)

254264

255265 diff (length selected) (<=) (fromIntegral n)

256266

@@ -268,9 +278,10 @@ testUnion = databasePropertyTest "UNION (Rel8.union)" \transaction -> evalM do

268278 left <- forAll $ Gen.list (Range.linear 0 10) genTestTable

269279 right <- forAll $ Gen.list (Range.linear 0 10) genTestTable

270280

271− transaction \connection -> do

272− selected <- liftIO $ Rel8.select connection do

273− Rel8.values (Rel8.lit <$> nub left) `Rel8.union` Rel8.values (Rel8.lit <$> nub right)

281+ transaction do

282+ selected <- lift do

283+ statement () $ Rel8.select do

284+ Rel8.values (Rel8.lit <$> nub left) `Rel8.union` Rel8.values (Rel8.lit <$> nub right)

274285

275286 sort selected === sort (nub (left ++ right))

276287

@@ -279,9 +290,11 @@ testDistinct :: IO TmpPostgres.DB -> TestTree

279290testDistinct = databasePropertyTest "DISTINCT (Rel8.distinct)" \transaction -> do

280291 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable

281292

282− transaction \connection -> do

283− selected <- liftIO $ Rel8.select connection $ Rel8.distinct do

284− Rel8.values (Rel8.lit <$> rows)

293+ transaction do

294+ selected <- lift do

295+ statement () $ Rel8.select do

296+ Rel8.distinct do

297+ Rel8.values (Rel8.lit <$> rows)

285298

286299 sort selected === nub (sort rows)

287300

@@ -294,8 +307,10 @@ testExists :: IO TmpPostgres.DB -> TestTree

294307testExists = databasePropertyTest "EXISTS (Rel8.exists)" \transaction -> do

295308 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable

296309

297− transaction \connection -> do

298− exists <- liftIO $ Rel8.select connection $ Rel8.exists $ Rel8.values $ Rel8.lit <$> rows

310+ transaction do

311+ exists <- lift do

312+ statement () $ Rel8.select do

313+ Rel8.exists $ Rel8.values $ Rel8.lit <$> rows

299314

300315 case rows of

301316 [] -> exists === [False]

@@ -306,9 +321,10 @@ testOptional :: IO TmpPostgres.DB -> TestTree

306321testOptional = databasePropertyTest "Rel8.optional" \transaction -> do

307322 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable

308323

309− transaction \connection -> do

310− selected <- liftIO $ Rel8.select connection do

311− Rel8.optional $ Rel8.values (Rel8.lit <$> rows)

324+ transaction do

325+ selected <- lift do

326+ statement () $ Rel8.select do

327+ Rel8.optional $ Rel8.values (Rel8.lit <$> rows)

312328

313329 case rows of

314330 [] -> selected === [Nothing]

@@ -319,9 +335,10 @@ testAnd :: IO TmpPostgres.DB -> TestTree

319335testAnd = databasePropertyTest "AND (&&.)" \transaction -> do

320336 (x, y) <- forAll $ liftA2 (,) Gen.bool Gen.bool

321337

322− transaction \connection -> do

323− [result] <- liftIO $ Rel8.select connection $ pure $

324− Rel8.lit x Rel8.&&. Rel8.lit y

338+ transaction do

339+ [result] <- lift do

340+ statement () $ Rel8.select do

341+ pure $ Rel8.lit x Rel8.&&. Rel8.lit y

325342

326343 result === (x && y)

327344

@@ -330,9 +347,10 @@ testOr :: IO TmpPostgres.DB -> TestTree

330347testOr = databasePropertyTest "OR (||.)" \transaction -> do

331348 (x, y) <- forAll $ liftA2 (,) Gen.bool Gen.bool

332349

333− transaction \connection -> do

334− [result] <- liftIO $ Rel8.select connection $ pure $

335− Rel8.lit x Rel8.||. Rel8.lit y

350+ transaction do

351+ [result] <- lift do

352+ statement () $ Rel8.select $ pure $

353+ Rel8.lit x Rel8.||. Rel8.lit y

336354

337355 result === (x || y)

338356

@@ -341,9 +359,10 @@ testLogicalFixities :: IO TmpPostgres.DB -> TestTree

341359testLogicalFixities = databasePropertyTest "Logical operator fixities" \transaction -> do

342360 (u, v, w, x) <- forAll $ (,,,) <$> Gen.bool <*> Gen.bool <*> Gen.bool <*> Gen.bool

343361

344− transaction \connection -> do

345− [result] <- liftIO $ Rel8.select connection $ pure $

346− Rel8.lit u Rel8.||. Rel8.lit v Rel8.&&. Rel8.lit w Rel8.==. Rel8.lit x

362+ transaction do

363+ [result] <- lift do

364+ statement () $ Rel8.select do

365+ pure $ Rel8.lit u Rel8.||. Rel8.lit v Rel8.&&. Rel8.lit w Rel8.==. Rel8.lit x

347366

348367 result === (u || v && w == x)

349368

@@ -352,9 +371,10 @@ testNot :: IO TmpPostgres.DB -> TestTree

352371testNot = databasePropertyTest "NOT (not_)" \transaction -> do

353372 x <- forAll Gen.bool

354373

355− transaction \connection -> do

356− [result] <- liftIO $ Rel8.select connection $ pure $

357− Rel8.not_ $ Rel8.lit x

374+ transaction do

375+ [result] <- lift do

376+ statement () $ Rel8.select do

377+ pure $ Rel8.not_ $ Rel8.lit x

358378

359379 result === not x

360380

@@ -363,9 +383,10 @@ testBool :: IO TmpPostgres.DB -> TestTree

363383testBool = databasePropertyTest "ifThenElse_" \transaction -> do

364384 (x, y, z) <- forAll $ liftA3 (,,) Gen.bool Gen.bool Gen.bool

365385

366− transaction \connection -> do

367− [result] <- liftIO $ Rel8.select connection $ pure $

368− Rel8.bool (Rel8.lit z) (Rel8.lit y) (Rel8.lit x)

386+ transaction do

387+ [result] <- lift do

388+ statement () $ Rel8.select do

389+ pure $ Rel8.bool (Rel8.lit z) (Rel8.lit y) (Rel8.lit x)

369390

370391 result === if x then y else z

371392

@@ -377,9 +398,10 @@ testAp = databasePropertyTest "Cartesian product (<*>)" \transaction -> do

377398 (Gen.list (Range.linear 1 10) genTestTable)

378399 (Gen.list (Range.linear 1 10) genTestTable)

379400

380− transaction \connection -> do

381− result <- liftIO $ Rel8.select connection $ do

382− liftA2 (,) (Rel8.values (Rel8.lit <$> rows1)) (Rel8.values (Rel8.lit <$> rows2))

401+ transaction do

402+ result <- lift do

403+ statement () $ Rel8.select do

404+ liftA2 (,) (Rel8.values (Rel8.lit <$> rows1)) (Rel8.values (Rel8.lit <$> rows2))

383405

384406 sort result === sort (liftA2 (,) rows1 rows2)

385407

@@ -408,21 +430,22 @@ testDBType getTestDatabase = testGroup "DBType instances"

408430 where

409431 dbTypeTest :: (Eq a, Show a, Rel8.DBType a) => TestName -> Gen a -> TestTree

410432 dbTypeTest name generator = testGroup name

411− [ databasePropertyTest name (t (==) generator) getTestDatabase

412− , databasePropertyTest ("Maybe " <> name) (t (==) (Gen.maybe generator)) getTestDatabase

433+ [ databasePropertyTest name (t generator) getTestDatabase

434+ , databasePropertyTest ("Maybe " <> name) (t (Gen.maybe generator)) getTestDatabase

413435 ]

414436

415− t :: forall a b. (Show a, Rel8.Sql Rel8.DBType a)

416− => (a -> a -> Bool)

417− -> Gen a

418− -> ((Connection -> TestT IO ()) -> PropertyT IO b)

437+ t :: forall a b. (Eq a, Show a, Rel8.Sql Rel8.DBType a)

438+ => Gen a

439+ -> (TestT Transaction () -> PropertyT IO b)

419440 -> PropertyT IO b

420− t eq generator transaction = do

441+ t generator transaction = do

421442 x <- forAll generator

422443

423− transaction \connection -> do

424− [res] <- liftIO $ Rel8.select connection $ pure (Rel8.litExpr x)

425− diff res eq x

444+ transaction do

445+ [res] <- lift do

446+ statement () $ Rel8.select do

447+ pure (Rel8.litExpr x)

448+ diff res (==) x

426449

427450 genDay :: Gen Day

428451 genDay = do

@@ -464,13 +487,15 @@ testDBEq getTestDatabase = testGroup "DBEq instances"

464487

465488 t :: forall a. (Eq a, Show a, Rel8.Sql Rel8.DBEq a)

466489 => Gen a

467− -> ((Connection -> TestT IO ()) -> PropertyT IO ())

490+ -> (TestT Transaction () -> PropertyT IO ())

468491 -> PropertyT IO ()

469492 t generator transaction = do

470493 (x, y) <- forAll (liftA2 (,) generator generator)

471494

472− transaction \connection -> do

473− [res] <- liftIO $ Rel8.select connection $ pure $ Rel8.litExpr x Rel8.==. Rel8.litExpr y

495+ transaction do

496+ [res] <- lift do

497+ statement () $ Rel8.select do

498+ pure $ Rel8.litExpr x Rel8.==. Rel8.litExpr y

474499 res === (x == y)

475500

476501

@@ -478,9 +503,10 @@ testTableEquality :: IO TmpPostgres.DB -> TestTree

478503testTableEquality = databasePropertyTest "TestTable equality" \transaction -> do

479504 (x, y) <- forAll $ liftA2 (,) genTestTable genTestTable

480505

481− transaction \connection -> do

482− [eq] <- liftIO $ Rel8.select connection do

483− pure $ Rel8.lit x Rel8.==: Rel8.lit y

506+ transaction do

507+ [eq] <- lift do

508+ statement () $ Rel8.select do

509+ pure $ Rel8.lit x Rel8.==: Rel8.lit y

484510

485511 eq === (x == y)

486512

@@ -489,8 +515,10 @@ testFromString :: IO TmpPostgres.DB -> TestTree

489515testFromString = databasePropertyTest "FromString" \transaction -> do

490516 str <- forAll $ Gen.list (Range.linear 0 10) Gen.unicode

491517

492− transaction \connection -> do

493− [result] <- liftIO $ Rel8.select connection $ pure $ fromString str

518+ transaction do

519+ [result] <- lift do

520+ statement () $ Rel8.select do

521+ pure $ fromString str

494522 result === pack str

495523

496524

@@ -498,10 +526,11 @@ testCatMaybeTable :: IO TmpPostgres.DB -> TestTree

498526testCatMaybeTable = databasePropertyTest "catMaybeTable" \transaction -> do

499527 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable

500528

501− transaction \connection -> do

502− selected <- liftIO $ Rel8.select connection do

503− testTable <- Rel8.values $ Rel8.lit <$> rows

504− Rel8.catMaybeTable $ Rel8.bool Rel8.nothingTable (pure testTable) (testTableColumn2 testTable)

529+ transaction do

530+ selected <- lift do

531+ statement () $ Rel8.select do

532+ testTable <- Rel8.values $ Rel8.lit <$> rows

533+ Rel8.catMaybeTable $ Rel8.bool Rel8.nothingTable (pure testTable) (testTableColumn2 testTable)

505534

506535 sort selected === sort (filter testTableColumn2 rows)

507536

@@ -510,9 +539,10 @@ testCatMaybe :: IO TmpPostgres.DB -> TestTree

510539testCatMaybe = databasePropertyTest "catMaybe" \transaction -> evalM do

511540 rows <- forAll $ Gen.list (Range.linear 0 10) $ Gen.maybe Gen.bool

512541

513− transaction \connection -> do

514− selected <- evalM $ liftIO $ Rel8.select connection do

515− Rel8.catNull =<< Rel8.values (map Rel8.lit rows)

542+ transaction do

543+ selected <- lift do

544+ statement () $ Rel8.select do

545+ Rel8.catNull =<< Rel8.values (map Rel8.lit rows)

516546

517547 sort selected === sort (catMaybes rows)

518548

@@ -521,15 +551,38 @@ testMaybeTable :: IO TmpPostgres.DB -> TestTree

521551testMaybeTable = databasePropertyTest "maybeTable" \transaction -> evalM do

522552 (rows, def) <- forAll $ liftA2 (,) (Gen.list (Range.linear 0 10) genTestTable) genTestTable

523553

524− transaction \connection -> do

525− selected <- liftIO $ Rel8.select connection $

526− Rel8.maybeTable (Rel8.lit def) id <$> Rel8.optional (Rel8.values (Rel8.lit <$> rows))

554+ transaction do

555+ selected <- lift do

556+ statement () $ Rel8.select do

557+ Rel8.maybeTable (Rel8.lit def) id <$> Rel8.optional (Rel8.values (Rel8.lit <$> rows))

527558

528559 case rows of

529560 [] -> selected === [def]

530561 _ -> sort selected === sort rows

531562

532563

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+

533586data TwoTestTables f =

534587 TwoTestTables

535588 { testTable1 :: TestTable f

@@ -550,9 +603,10 @@ testNestedTables = databasePropertyTest "Nested TestTables" \transaction -> eval

550603 Gen.list (Range.linear 0 10) $

551604 liftA2 TwoTestTables genTestTable genTestTable

552605

553− transaction \connection -> do

554− selected <- liftIO $ Rel8.select connection do

555− Rel8.values (Rel8.lit <$> rows)

606+ transaction do

607+ selected <- lift do

608+ statement () $ Rel8.select do

609+ Rel8.values (Rel8.lit <$> rows)

556610

557611 sort selected === sort rows

558612

@@ -562,11 +616,12 @@ testMaybeTableApplicative = databasePropertyTest "MaybeTable (<*>)" \transaction

562616 rows1 <- genRows

563617 rows2 <- genRows

564618

565− transaction \connection -> do

566− selected <- liftIO $ Rel8.select connection do

567− as <- Rel8.optional (Rel8.values (Rel8.lit <$> rows1))

568− bs <- Rel8.optional (Rel8.values (Rel8.lit <$> rows2))

569− pure $ liftA2 (,) as bs

619+ transaction do

620+ selected <- lift do

621+ statement () $ Rel8.select do

622+ as <- Rel8.optional (Rel8.values (Rel8.lit <$> rows1))

623+ bs <- Rel8.optional (Rel8.values (Rel8.lit <$> rows2))

624+ pure $ liftA2 (,) as bs

570625

571626 case (rows1, rows2) of

572627 ([], []) -> selected === [Nothing]

@@ -578,14 +633,6 @@ testMaybeTableApplicative = databasePropertyTest "MaybeTable (<*>)" \transaction

578633 genRows = forAll do

579634 Gen.list (Range.linear 0 10) $ liftA2 TestTable (Gen.text (Range.linear 0 10) Gen.unicode) (pure True)

580635

581−rollingBack

582− :: (MonadBaseControl IO m, MonadIO m)

583− => Connection -> m a -> m a

584−rollingBack connection =

585− bracket_

586− (liftIO (run (sql "BEGIN") connection))

587− (liftIO (run (sql "ROLLBACK") connection))

588−

589636

590637genTestTable :: Gen (TestTable Result)

591638genTestTable = do

@@ -598,19 +645,19 @@ testUpdate :: IO TmpPostgres.DB -> TestTree

598645testUpdate = databasePropertyTest "Can UPDATE TestTable" \transaction -> do

599646 rows <- forAll $ Gen.map (Range.linear 0 5) $ liftA2 (,) genTestTable genTestTable

600647

601− transaction \connection -> do

602− void $ liftIO $ Rel8.insert connection

603− Rel8.Insert

648+ transaction do

649+ selected <- lift do

650+ statement () $ Rel8.insert Rel8.Insert

604651 { into = testTableSchema

605− , rows = map Rel8.lit $ Map.keys rows

652+ , rows = Rel8.values $ map Rel8.lit $ Map.keys rows

606653 , onConflict = Rel8.DoNothing

607− , returning = Rel8.NumberOfRowsAffected

654+ , returning = pure ()

608655 }

609656

610− void $ liftIO $ Rel8.update connection

611− Rel8.Update

657+ statement () $ Rel8.update Rel8.Update

612658 { target = testTableSchema

613− , set = \r ->

659+ , from = pure ()

660+ , set = \_ r ->

614661 let updates = map (bimap Rel8.lit Rel8.lit) $ Map.toList rows

615662 in

616663 foldl

@@ -624,12 +671,12 @@ testUpdate = databasePropertyTest "Can UPDATE TestTable" \transaction -> do

624671 )

625672 r

626673 updates

627− , updateWhere = \_ -> Rel8.lit True

628− , returning = Rel8.NumberOfRowsAffected

674+ , updateWhere = \_ _ -> Rel8.lit True

675+ , returning = pure ()

629676 }

630677

631− selected <- liftIO $ Rel8.select connection do

632− Rel8.each testTableSchema

678+ statement () $ Rel8.select do

679+ Rel8.each testTableSchema

633680

634681 sort selected === sort (Map.elems rows)

635682

@@ -642,29 +689,96 @@ testDelete :: IO TmpPostgres.DB -> TestTree

642689testDelete = databasePropertyTest "Can DELETE TestTable" \transaction -> do

643690 rows <- forAll $ Gen.list (Range.linear 0 5) genTestTable

644691

645− transaction \connection -> do

646− void $ liftIO $ Rel8.insert connection

647− Rel8.Insert

692+ transaction do

693+ (deleted, selected) <- lift do

694+ statement () $ Rel8.insert Rel8.Insert

648695 { into = testTableSchema

649− , rows = map Rel8.lit rows

696+ , rows = Rel8.values $ map Rel8.lit rows

650697 , onConflict = Rel8.DoNothing

651− , returning = Rel8.NumberOfRowsAffected

698+ , returning = pure ()

652699 }

653700

654− deleted <-

655− liftIO $ Rel8.delete connection

656− Rel8.Delete

701+ deleted <- statement () $ Rel8.delete Rel8.Delete

657702 { from = testTableSchema

658− , deleteWhere = testTableColumn2

703+ , using = pure ()

704+ , deleteWhere = const testTableColumn2

659705 , returning = Rel8.Projection id

660706 }

661707

662− selected <- liftIO $ Rel8.select connection do

663− Rel8.each testTableSchema

708+ selected <- statement () $ Rel8.select do

709+ Rel8.each testTableSchema

710+

711+ pure (deleted, selected)

664712

665713 sort (deleted <> selected) === sort rows

666714

667715

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+

668782newtype HKNestedPair f = HKNestedPair { pairOne :: (TestTable f, TestTable f) }

669783 deriving stock Generic

670784 deriving anyclass Rel8.Rel8able

@@ -678,9 +792,10 @@ testSelectNestedPairs :: IO TmpPostgres.DB -> TestTree

678792testSelectNestedPairs = databasePropertyTest "Can SELECT nested pairs" \transaction -> do

679793 rows <- forAll $ Gen.list (Range.linear 0 10) $ HKNestedPair <$> liftA2 (,) genTestTable genTestTable

680794

681− transaction \connection -> do

682− selected <- liftIO $ Rel8.select connection do

683− Rel8.values $ map Rel8.lit rows

795+ transaction do

796+ selected <- lift do

797+ statement () $ Rel8.select do

798+ Rel8.values $ map Rel8.lit rows

684799

685800 sort selected === sort rows

686801

@@ -689,18 +804,20 @@ testSelectArray :: IO TmpPostgres.DB -> TestTree

689804testSelectArray = databasePropertyTest "Can SELECT Arrays (with aggregation)" \transaction -> do

690805 rows <- forAll $ Gen.list (Range.linear 1 10) Gen.bool

691806

692− transaction \connection -> do

693− selected <- liftIO $ Rel8.select connection do

694− Rel8.many $ Rel8.values (map Rel8.lit rows)

807+ transaction do

808+ selected <- lift do

809+ statement () $ Rel8.select do

810+ Rel8.many $ Rel8.values (map Rel8.lit rows)

695811

696812 selected === [foldMap pure rows]

697813

698− selected' <- liftIO $ Rel8.select connection $ do

699− a <- Rel8.catListTable =<< do

700− Rel8.many $ Rel8.values (map Rel8.lit rows)

701− b <- Rel8.catListTable =<< do

702− Rel8.many $ Rel8.values (map Rel8.lit rows)

703− pure (a, b)

814+ selected' <- lift do

815+ statement () $ Rel8.select do

816+ a <- Rel8.catListTable =<< do

817+ Rel8.many $ Rel8.values (map Rel8.lit rows)

818+ b <- Rel8.catListTable =<< do

819+ Rel8.many $ Rel8.values (map Rel8.lit rows)

820+ pure (a, b)

704821

705822 selected' === liftA2 (,) rows rows

706823

@@ -722,10 +839,11 @@ testNestedMaybeTable :: IO TmpPostgres.DB -> TestTree

722839testNestedMaybeTable = databasePropertyTest "Can nest MaybeTable within other tables" \transaction -> do

723840 let example = NestedMaybeTable { nmt1 = True, nmt2 = Just (TestTable "Hi" True) }

724841

725− transaction \connection -> do

726− selected <- liftIO $ Rel8.select connection do

727− x <- Rel8.values [Rel8.lit example]

728− pure $ Rel8.maybeTable (Rel8.lit False) (\_ -> Rel8.lit True) (nmt2 x)

842+ transaction do

843+ selected <- lift do

844+ statement () $ Rel8.select do

845+ x <- Rel8.values [Rel8.lit example]

846+ pure $ Rel8.maybeTable (Rel8.lit False) (\_ -> Rel8.lit True) (nmt2 x)

729847

730848 selected === [True]

731849

@@ -733,11 +851,12 @@ testNestedMaybeTable = databasePropertyTest "Can nest MaybeTable within other ta

733851testEvaluate :: IO TmpPostgres.DB -> TestTree

734852testEvaluate = databasePropertyTest "evaluate has the evaluation order we expect" \transaction -> do

735853

736− transaction \connection -> do

737− selected <- liftIO $ Rel8.select connection do

738− x <- Rel8.values (Rel8.lit <$> ['a', 'b', 'c'])

739− y <- Rel8.evaluate (Rel8.nextval "test_seq")

740− pure (x, (y, y))

854+ transaction do

855+ selected <- lift do

856+ statement () $ Rel8.select do

857+ x <- Rel8.values (Rel8.lit <$> ['a', 'b', 'c'])

858+ y <- Rel8.evaluate (Rel8.nextval "test_seq")

859+ pure (x, (y, y))

741860

742861 normalize selected ===

743862 [ ('a', (0, 0))

@@ -745,11 +864,12 @@ testEvaluate = databasePropertyTest "evaluate has the evaluation order we expect

745864 , ('c', (2, 2))

746865 ]

747866

748− selected' <- liftIO $ Rel8.select connection do

749− x <- Rel8.values (Rel8.lit <$> ['a', 'b', 'c'])

750− y <- Rel8.values (Rel8.lit <$> ['d', 'e', 'f'])

751− z <- Rel8.evaluate (Rel8.nextval "test_seq")

752− pure ((x, y), (z, z))

867+ selected' <- lift do

868+ statement () $ Rel8.select do

869+ x <- Rel8.values (Rel8.lit <$> ['a', 'b', 'c'])

870+ y <- Rel8.values (Rel8.lit <$> ['d', 'e', 'f'])

871+ z <- Rel8.evaluate (Rel8.nextval "test_seq")

872+ pure ((x, y), (z, z))

753873

754874 normalize selected' ===

755875 [ (('a', 'd'), (0, 0))

@@ -767,13 +887,3 @@ testEvaluate = databasePropertyTest "evaluate has the evaluation order we expect

767887 normalize :: [(x, (Int64, Int64))] -> [(x, (Int64, Int64))]

768888 normalize [] = []

769889 normalize xs@((_, (i, _)) : _) = map (fmap (\(a, b) -> (a - i, b - i))) xs

770−

771−{-

772− selected <- liftIO $ Rel8.select connection do

773− x <- Rel8.values (Rel8.lit <$> ['a', 'b', 'c'])

774− x <- Rel8.values (Rel8.lit <$> ['d', 'e', 'f'])

775− y <- Rel8.evaluate (Rel8.nextval "test_seq")

776− pure (x, y, y)

777−

778− selected === [('a', 1, 1), ('b', 2, 2), ('c', 3, 3)]

779−-}

tests/Rel8/Generic/Rel8able/Test.hs+44−1

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

55{-# language DuplicateRecordFields #-}

66{-# language FlexibleInstances #-}

77{-# language MultiParamTypeClasses #-}

8+{-# language StandaloneKindSignatures #-}

89{-# language TypeFamilies #-}

10+{-# language UndecidableInstances #-}

911

1012{-# options_ghc -O0 #-}

1113

@@ -136,10 +138,51 @@ data TableSum f

136138 deriving stock Generic

137139

138140

141+data BarbieSum f

142+ = BarbieSumA (f Bool) (f Text)

143+ | BarbieSumB

144+ | BarbieSumC (f Text)

145+ deriving stock Generic

146+

147+

139148data TableProduct f = TableProduct

140− { sum :: HADT f TableSum

149+ { sum :: HADT f BarbieSum

141150 , list :: TableList f

142151 , foos :: HList f (HADT f TableSum, Lift f HKDSum, HKDTest f)

143152 }

144153 deriving stock Generic

145154 deriving anyclass Rel8able

155+

156+

157+data TableTestB f = TableTestB

158+ { foo :: f Bool

159+ , bar :: f (Maybe Bool)

160+ }

161+ deriving stock Generic

162+ deriving anyclass Rel8able

163+

164+

165+data NestedTableTestB f = NestedTableTestB

166+ { foo :: f Bool

167+ , bar :: f (Maybe Bool)

168+ , baz :: Column f Char

169+ , nest :: TableTestB f

170+ }

171+ deriving stock Generic

172+ deriving anyclass Rel8able

173+

174+

175+newtype IdRecord a f = IdRecord { recordId :: Column f a }

176+ deriving stock Generic

177+

178+

179+instance 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