master..e0a1851 · rel8

git.iko.soy/rel8

117 files changed+1845−4155

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@v14.1

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

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://cache.iog.io

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

1818

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

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

2020 with:

2121 name: rel8

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

Changelog.md+1−126

@@ -1,124 +1,7 @@

1−# 1.4.0.0 (2002-08-17)

1+# 1.1.0.0 (??)

33## Breaking changes

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

6−

7−## New features

8−

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

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

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

12−

13−## Improvements

14−

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

16−

17−## Other

18−

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

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

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

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

23−

24−# 1.3.1.0 (2022-01-20)

25−

26−## Other

27−

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

29−

30−# 1.3.0.0 (2022-01-31)

31−

32−## Breaking changes

33−

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

35−

36−## New features

37−

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

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

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

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

42−

43−## Other

44−

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

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

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

48−

49−# 1.2.2.0 (2021-11-21)

50−

51−## Other

52−

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

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

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

56−

57−# 1.2.1.0 (2021-11-21)

58−

59−## New features

60−

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

62−

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

64−

65−## Other

66−

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

68−

69−# 1.2.0.0 (2021-10-22)

70−

71−## New features

72−

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

74−

75−## Bug fixes

76−

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

78−

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

80−

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

82−

83−## Breaking changes

84−

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

86−

87−# 1.1.0.0 (2021-07-16)

88−

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−

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

1236

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

@@ -127,14 +10,6 @@

12710

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

12912

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−

13813## Bug fixes

13914

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

cabal.project+5

@@ -1 +1,6 @@

11packages: .

3+allow-newer: generic-monoid:base

4+allow-newer: cryptohash-sha1:base

5+allow-newer: cryptohash-md5:base

6+allow-newer: entropy:Cabal

cabal.project.haskell-nix+6

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

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.

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-unstable;

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

66 nixpkgsArgs = haskellNix.nixpkgsArgs;

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

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

1010 pkgs = import nixpkgsSrc nixpkgsArgs;

1111

docs/concepts/insert.rst+10−37

@@ -21,16 +21,9 @@ 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−

3024``deleteWhere``

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

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

33− of the row.

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

3427

3528``returning``

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

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

4437``target``

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

4639

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 ()``.

40+``updateWhere``

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

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

5243

5344``set``

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

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

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

5748

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.

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

6450

6551``returning``

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

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

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

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

8066

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

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

8268

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

8470

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

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

8672

8773``onConflict``

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

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

9480 ``DoNothing``

9581 PostgreSQL should not insert the duplicate rows.

9682

97− ``DoUpdate``

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

99− with rows proposed for insertion.

100−

10183``returning``

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

10385

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

11799

118100 insert Insert

119101 { into = orderSchema

120− , rows = values [ order ]

102+ , rows = [ order ]

121103 , onConflict = Abort

122104 , returning = Projection orderId

123105 }

124106

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−

134107Default values

135108--------------

136109

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

146119

147120 insert Insert

148121 { into = orderSchema

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

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

150123 , onConflict = Abort

151124 , returning = Projection orderId

152125 }

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

175148

176149 insert Insert

177150 { into = orderSchema

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

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

179152 , onConflict = Abort

180153 , returning = Projection orderId

181154 }

docs/cookbook.rst+7−9

@@ -142,25 +142,23 @@ 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 that have at least one tag each.

145+1. The latest 5 blog posts.

1461462. For each blog post, all tags.

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

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

148148

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

150150

151151 latestBlogPosts = do

152152 post <- each postSchema

153153

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

155− tags <- some $ do

154+ tags <- aggregate do

156155 tag <- each tagSchema

157156 where_ (tagPostId tag ==. postId post)

158− return (tagName tag)

157+ return (listAgg (tagName tag))

159158

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

161− latestComments <-

162− many $

163− limit 3 $

159+ latestComments <-

160+ many $

161+ limit 3 $

164162 orderBy (commentCreatedAt >$< desc) do

165163 comment <- each commentSchema

166164 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": "0837156c56cb5350dd9bd84eb424187e00aa1e8a",

9− "sha256": "1djmv5a0vfj78csw2cad6nicrs8iqrp928b9b3v4h7lwwhhzliwl",

8+ "rev": "3856d2d24dca0ecc71fcfc314253a2a2d07a3c4f",

9+ "sha256": "0s69nasqhkv8n0qmdv075k83p3z584ja9vkzdnp2291mymghvx87",

1010 "type": "tarball",

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

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

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": "acdb1726783637852c01e0ad639ac9cbec28d8c8",

21− "sha256": "1wszl8q70z6wfgkh2dvgmhhry6qp9nar421qq2ifd17hq2jj9ck3",

20+ "rev": "e0ca65c81a2d7a4d82a189f1e23a48d59ad42070",

21+ "sha256": "1pq9nh1d8nn3xvbdny8fafzw87mj7gsmp6pxkdl65w2g18rmcmzx",

2222 "type": "tarball",

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

23+ "url": "https://github.com/nmattia/niv/archive/e0ca65c81a2d7a4d82a189f1e23a48d59ad42070.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": "1c1f5649bb9c1b0d98637c8c365228f57126f361",

33− "sha256": "0f2nvdijyxfgl5kwyb4465pppd5vkhqxddx6v40k2s0z9jfhj0xl",

32+ "rev": "59b8d9cf24e9fcf10341a0923c9bdca088dca8c8",

33+ "sha256": "08f38v4b2kcxnbapdwrb54bglka92cxj9qlnqlk5px206jyq9v4c",

3434 "type": "tarball",

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

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

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

3737 }

3838}

nix/sources.nix+1−21

@@ -31,28 +31,8 @@ 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;

5334 in

54− builtins.fetchGit

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

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

5636

5737 fetch_local = spec: spec.path;

5838

rel8.cabal+11−30

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

11cabal-version: 2.0

22name: rel8

3−version: 1.4.0.0

3+version: 1.0.0.1

44synopsis: Hey! Hey! Can u rel8?

55license: BSD3

66license-file: LICENSE

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

2020library

2121 build-depends:

2222 aeson

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

24− , bifunctors

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

2524 , bytestring

2625 , case-insensitive

2726 , comonad

2827 , contravariant

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

30− , opaleye ^>= 0.9.6.1

31− , pretty

28+ , hasql ^>= 1.4.5.1

29+ , opaleye ^>= 0.7.3.0

3230 , profunctors

33− , product-profunctors

3431 , scientific

3532 , semialign

3633 , semigroupoids

3734 , text

3835 , these

3936 , time

37+ , transformers

4038 , uuid

4139 default-language:

4240 Haskell2010

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

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

4745 -Wno-monomorphism-restriction

4846 -Wno-missing-local-signatures

49− -Wno-missing-kind-signatures

5047 hs-source-dirs:

5148 src

5249 exposed-modules:

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

5451 Rel8.Expr.Num

5552 Rel8.Expr.Text

5653 Rel8.Expr.Time

57− Rel8.Tabulate

5854

5955 other-modules:

6056 Rel8.Aggregate

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

6662 Rel8.Column.List

6763 Rel8.Column.Maybe

6864 Rel8.Column.NonEmpty

69− Rel8.Column.Null

7065 Rel8.Column.These

7166

7267 Rel8.Expr

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

8277 Rel8.Expr.Order

8378 Rel8.Expr.Sequence

8479 Rel8.Expr.Serialize

85− Rel8.Expr.Window

8680

8781 Rel8.FCF

8882

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

109103 Rel8.Query.Evaluate

110104 Rel8.Query.Exists

111105 Rel8.Query.Filter

112− Rel8.Query.Indexed

113106 Rel8.Query.Limit

114107 Rel8.Query.List

115108 Rel8.Query.Maybe

116109 Rel8.Query.Null

117110 Rel8.Query.Opaleye

118111 Rel8.Query.Order

119− Rel8.Query.Rebind

120112 Rel8.Query.Set

121113 Rel8.Query.SQL

122114 Rel8.Query.These

123115 Rel8.Query.Values

124− Rel8.Query.Window

125116

117+ Rel8.Schema.Context.Lower

126118 Rel8.Schema.Context.Nullify

119+ Rel8.Schema.Context.Virtual

127120 Rel8.Schema.Dict

128− Rel8.Schema.Field

129121 Rel8.Schema.HTable

130122 Rel8.Schema.HTable.Either

131123 Rel8.Schema.HTable.Identity

@@ -143,19 +135,15 @@ library

143135 Rel8.Schema.Null

144136 Rel8.Schema.Result

145137 Rel8.Schema.Spec

138+ Rel8.Schema.Spec.Constrain

146139 Rel8.Schema.Table

147140

148141 Rel8.Statement.Delete

149142 Rel8.Statement.Insert

150− Rel8.Statement.OnConflict

151143 Rel8.Statement.Returning

152144 Rel8.Statement.Select

153− Rel8.Statement.Set

154− Rel8.Statement.SQL

155145 Rel8.Statement.Update

156− Rel8.Statement.Using

157146 Rel8.Statement.View

158− Rel8.Statement.Where

159147

160148 Rel8.Table

161149 Rel8.Table.ADT

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

170158 Rel8.Table.Maybe

171159 Rel8.Table.Name

172160 Rel8.Table.NonEmpty

173− Rel8.Table.Null

174161 Rel8.Table.Nullify

175162 Rel8.Table.Opaleye

176163 Rel8.Table.Ord

177164 Rel8.Table.Order

178− Rel8.Table.Projection

179165 Rel8.Table.Rel8able

180166 Rel8.Table.Serialize

181167 Rel8.Table.These

182168 Rel8.Table.Transpose

183169 Rel8.Table.Undefined

184− Rel8.Table.Window

185170

186171 Rel8.Type

187172 Rel8.Type.Array

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

200185 Rel8.Type.Sum

201186 Rel8.Type.Tag

202187

203− Rel8.Window

204−

205−

206188test-suite tests

207189 type: exitcode-stdio-1.0

208190 build-depends:

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

211193 , case-insensitive

212194 , containers

213195 , hasql

214− , hasql-transaction

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

216− , mmorph

196+ , hedgehog ^>=1.0.2

197+ , lifted-base ^>=0.2.3.12

198+ , monad-control ^>=1.0.2.3

217199 , rel8

218200 , scientific

219201 , tasty

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

221203 , text

222204 , time

223205 , tmp-postgres ^>=1.34.1.0

224− , transformers

225206 , uuid

226207

227208 other-modules:

shell.nix+1−1

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

11let

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

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

3+ pkgs = import sources.nixpkgs {};

44 hsPkgs = import ./default.nix;

55in

66 hsPkgs.shellFor {

src/Rel8.hs+8−295

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

3838 , HMaybe

3939 , HList

4040 , HNonEmpty

41− , HNull

4241 , HThese

4342 , Lift

4443

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

4746 , Transposes

4847 , AltTable((<|>:))

4948 , AlternativeTable( emptyTable )

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

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

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

50+ , OrdTable, ascTable, descTable

5251 , lit

5352 , bool

5453 , case_

55− , castTable

5654

5755 -- ** @MaybeTable@

5856 , MaybeTable

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

6058 , isNothingTable, isJustTable

61− , fromMaybeTable

6259 , optional

6360 , catMaybeTable

6461 , traverseMaybeTable

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

8178 , isThisTable, isThatTable, isThoseTable

8279 , hasHereTable, hasThereTable

8380 , justHereTable, justThereTable

84− , alignMaybeTable

8581 , alignBy

8682 , keepHereTable, loseHereTable

8783 , keepThereTable, loseThereTable

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

9490

9591 -- ** @ListTable@

9692 , ListTable

97− , listTable, ($*)

93+ , listTable

9894 , nameListTable

9995 , many

10096 , manyExpr

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

10399

104100 -- ** @NonEmptyTable@

105101 , NonEmptyTable

106− , nonEmptyTable, ($+)

102+ , nonEmptyTable

107103 , nameNonEmptyTable

108104 , some

109105 , someExpr

110106 , catNonEmptyTable

111107 , catNonEmpty

112108

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

109+ -- ** @ADT@

127110 , ADT, ADTable

128−

129− -- *** Deconstruction of ADTs

130− -- $deconstruction

131− , DeconstructADT, deconstructADT

132−

133− -- *** Construction of ADTs

134− -- $construction

135111 , BuildADT, buildADT

136112 , ConstructADT, constructADT

137−

138− -- *** Other ADT operations

113+ , DeconstructADT, deconstructADT

114+ , NameADT, nameADT

139115 , AggregateADT, aggregateADT

140116

141− -- *** Miscellaneous notes

142− -- $misc-notes

143−

144117 -- ** @HKD@

145118 , HKD, HKDable

146119 , BuildHKD, buildHKD

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

165138 -- ** @null@

166139 , NotNull

167140 , Nullable

168− , Homonullable

169141 , null

170142 , nullify

171143 , nullable

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

184156 , (==.), (/=.), (==?), (/=?)

185157 , in_

186158 , boolExpr, caseExpr

187− , like, ilike

188159

189160 -- ** Ordering

190161 , DBOrd

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

202173 , Query

203174 , showQuery

204175

205− -- ** Projection

206− , Projection

207− , Projectable( project )

208− , Biprojectable( biproject )

209− , Projecting

210− , Field

211−

212176 -- ** Selecting rows

213177 , Selects

214178 , each

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

253217 , countRows

254218 , groupBy

255219 , listAgg, listAggExpr

256− , mode

257220 , nonEmptyAgg, nonEmptyAggExpr

258221 , DBMax, max

259222 , DBMin, min

260− , DBSum, sum, sumWhere, avg

223+ , DBSum, sum, sumWhere

261224 , DBString, stringAgg

262225 , count

263226 , countStar

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

274237 , nullsFirst

275238 , nullsLast

276239

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−

303240 -- * IO

304241 , Serializable

305242 , ToExprs

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

314251 -- ** @INSERT@

315252 , Insert(..)

316253 , OnConflict(..)

317− , Upsert(..)

318254 , insert

319255 , unsafeDefault

320− , showInsert

321256

322257 -- ** @DELETE@

323258 , Delete(..)

324259 , delete

325− , showDelete

326260

327261 -- ** @UPDATE@

328262 , Update(..)

329263 , update

330− , showUpdate

331264

332265 -- ** @.. RETURNING@

333266 , Returning(..)

334267

335268 -- ** @CREATE VIEW@

336269 , createView

337− , createOrReplaceView

338270

339271 -- ** Sequences

340272 , nextval

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

353285import Rel8.Column.List

354286import Rel8.Column.Maybe

355287import Rel8.Column.NonEmpty

356−import Rel8.Column.Null

357288import Rel8.Column.These

358289import Rel8.Expr

359290import Rel8.Expr.Aggregate

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

367298import Rel8.Expr.Order

368299import Rel8.Expr.Serialize

369300import Rel8.Expr.Sequence

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

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

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

373302import Rel8.Order

374303import Rel8.Query

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

379308import Rel8.Query.Evaluate

380309import Rel8.Query.Exists

381310import Rel8.Query.Filter

382−import Rel8.Query.Indexed

383311import Rel8.Query.Limit

384312import Rel8.Query.List

385313import Rel8.Query.Maybe

386314import Rel8.Query.Null

387315import Rel8.Query.Order

388−import Rel8.Query.Rebind

389316import Rel8.Query.SQL (showQuery)

390317import Rel8.Query.Set

391318import Rel8.Query.These

392319import Rel8.Query.Values

393−import Rel8.Query.Window

394−import Rel8.Schema.Field

395320import Rel8.Schema.HTable

396321import Rel8.Schema.Name

397322import Rel8.Schema.Null hiding ( nullable )

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

399324import Rel8.Schema.Table

400325import Rel8.Statement.Delete

401326import Rel8.Statement.Insert

402−import Rel8.Statement.OnConflict

403327import Rel8.Statement.Returning

404328import Rel8.Statement.Select

405−import Rel8.Statement.SQL

406329import Rel8.Statement.Update

407330import Rel8.Statement.View

408331import Rel8.Table

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

417340import Rel8.Table.Maybe

418341import Rel8.Table.Name

419342import Rel8.Table.NonEmpty

420−import Rel8.Table.Null

421−import Rel8.Table.Opaleye ( castTable )

422343import Rel8.Table.Ord

423344import Rel8.Table.Order

424−import Rel8.Table.Projection

425345import Rel8.Table.Rel8able ()

426346import Rel8.Table.Serialize

427347import Rel8.Table.These

428348import Rel8.Table.Transpose

429−import Rel8.Table.Window

430349import Rel8.Type

431350import Rel8.Type.Composite

432351import Rel8.Type.Eq

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

441360import Rel8.Type.Semigroup

442361import Rel8.Type.String

443362import Rel8.Type.Sum

444−import Rel8.Window

445363

446364

447365-- $running

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

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

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

451369-- `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+62−30

@@ -1,38 +1,39 @@

11{-# language DataKinds #-}

22{-# language FlexibleContexts #-}

33{-# language FlexibleInstances #-}

4+{-# language GADTs #-}

45{-# language MultiParamTypeClasses #-}

6+{-# language NamedFieldPuns #-}

7+{-# language PolyKinds #-}

58{-# language RankNTypes #-}

69{-# language StandaloneKindSignatures #-}

710{-# language TypeFamilies #-}

811{-# language UndecidableInstances #-}

912

1013module Rel8.Aggregate

11− ( Aggregate(..), zipOutputs

12− , unsafeMakeAggregate

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

15+ , Aggregator(..), unsafeMakeAggregate

1316 , Aggregates

1417 )

1518where

1619

1720-- base

18−import Control.Applicative ( liftA2 )

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

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

2022import Data.Kind ( Constraint, Type )

2123import Prelude

2224

23−-- profunctors

24−import Data.Profunctor ( dimap )

25−

2625-- opaleye

27−import qualified Opaleye.Aggregate as Opaleye

26+import qualified Opaleye.Internal.Aggregate as Opaleye

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

29−import qualified Opaleye.Internal.Column as Opaleye

28+import qualified Opaleye.Internal.PackMap as Opaleye

3029

3130-- rel8

3231import Rel8.Expr ( Expr )

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

34−import qualified Rel8.Schema.Kind as K

32+import Rel8.Schema.Context.Lower ( Lower )

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

3534import Rel8.Schema.Null ( Sql )

35+import Rel8.Schema.Result ( Result( R ) )

36+import Rel8.Schema.Spec ( Spec( Spec ) )

3637import Rel8.Table

3738 ( Table, Columns, Context, fromColumns, toColumns

3839 , FromExprs, fromResult, toResult

@@ -42,42 +43,73 @@ import Rel8.Table.Transpose ( Transposes )

4243import Rel8.Type ( DBType )

4344

4445

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

46−type Aggregate :: K.Context

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

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

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

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

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

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

51+type Aggregate :: k -> Type

52+data Aggregate a where

53+ Aggregate :: forall (a :: Type). !(Opaleye.Aggregator () (Expr a)) -> Aggregate a

54+ A :: { unA :: !(Aggregate a) } -> Aggregate ('Spec a)

55+

56+

57+type instance Lower Aggregate = Aggregate

4858

4959

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

51− type Columns (Aggregate a) = HIdentity a

61+ type Columns (Aggregate a) = HType a

5262 type Context (Aggregate a) = Aggregate

5363 type FromExprs (Aggregate a) = a

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

64+ type Transpose to (Aggregate a) = Lower to a

5565

56− toColumns = HIdentity

57− fromColumns (HIdentity a) = a

58− toResult = HIdentity . Identity

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

66+ toColumns = HIdentity . A

67+ fromColumns (HIdentity (A a)) = a

68+ toResult = HIdentity . R

69+ fromResult (HIdentity (R a)) = a

6070

6171

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

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

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

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

6474type Aggregates :: Type -> Type -> Constraint

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

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

6777

6878

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)

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

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

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

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

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

84+ where

85+ detuplize (operation, ordering, distinction) =

86+ Aggregator {operation, ordering, distinction}

87+

88+

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

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

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

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

93+ f (fmap transform input)

94+

95+

96+type Aggregator :: Type

97+data Aggregator = Aggregator

98+ { operation :: Opaleye.AggrOp

99+ , ordering :: [Opaleye.OrderExpr]

100+ , distinction :: Opaleye.AggrDistinct

101+ }

72102

73103

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

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

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

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

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

107+ -> Maybe Aggregator

78108 -> Expr input

79109 -> Aggregate output

80110unsafeMakeAggregate input output aggregator expr =

81− Aggregate $ dimap in_ out aggregator

82− where out = output . Opaleye.unColumn

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

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

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

113+ where

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

115+ (operation, ordering, distinction)

src/Rel8/Column.hs+2−1

@@ -15,6 +15,7 @@ import Prelude ()

1515-- rel8

1616import Rel8.FCF ( Eval, Exp )

1717import qualified Rel8.Schema.Kind as K

18+import Rel8.Schema.Context.Lower ( Lower )

1819import Rel8.Schema.Result ( Result )

1920

2021

@@ -24,7 +25,7 @@ import Rel8.Schema.Result ( Result )

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

2526type family Column context a where

2627 Column Result a = a

27− Column context a = context a

28+ Column context a = Lower context a

2829

2930

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

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

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

1212import Prelude

1313

1414-- rel8

15+import Rel8.Aggregate ( Aggregate )

16+import Rel8.Expr ( Expr )

1517import qualified Rel8.Schema.Kind as K

18+import Rel8.Schema.Name ( Name )

1619import Rel8.Schema.Result ( Result )

1720import Rel8.Table.Either ( EitherTable )

1821

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

2225-- 'Result' context.

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

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

28+ HEither Aggregate = EitherTable Aggregate

29+ HEither Expr = EitherTable Expr

30+ HEither Name = EitherTable Name

2531 HEither Result = Either

26− HEither context = EitherTable context

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

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

1212import Prelude ()

1313

1414-- rel8

15+import Rel8.Aggregate ( Aggregate )

16+import Rel8.Expr ( Expr )

1517import qualified Rel8.Schema.Kind as K

18+import Rel8.Schema.Name ( Name )

1619import Rel8.Schema.Result ( Result )

1720import Rel8.Table.List ( ListTable )

1821

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

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

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

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

27+ HList Aggregate = ListTable Aggregate

28+ HList Expr = ListTable Expr

29+ HList Name = ListTable Name

2430 HList Result = []

25− HList context = ListTable context

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

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

1212import Prelude

1313

1414-- rel8

15+import Rel8.Aggregate ( Aggregate )

16+import Rel8.Expr ( Expr )

1517import qualified Rel8.Schema.Kind as K

18+import Rel8.Schema.Name ( Name )

1619import Rel8.Schema.Result ( Result )

1720import Rel8.Table.Maybe ( MaybeTable )

1821

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

2225-- context.

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

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

28+ HMaybe Aggregate = MaybeTable Aggregate

29+ HMaybe Expr = MaybeTable Expr

30+ HMaybe Name = MaybeTable Name

2531 HMaybe Result = Maybe

26− HMaybe context = MaybeTable context

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

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

1313import Prelude ()

1414

1515-- rel8

16+import Rel8.Aggregate ( Aggregate )

17+import Rel8.Expr ( Expr )

1618import qualified Rel8.Schema.Kind as K

19+import Rel8.Schema.Name ( Name )

1720import Rel8.Schema.Result ( Result )

1821import Rel8.Table.NonEmpty ( NonEmptyTable )

1922

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

2326-- 'Result' context.

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

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

29+ HNonEmpty Aggregate = NonEmptyTable Aggregate

30+ HNonEmpty Expr = NonEmptyTable Expr

31+ HNonEmpty Name = NonEmptyTable Name

2632 HNonEmpty Result = NonEmpty

27− HNonEmpty context = NonEmptyTable context

src/Rel8/Column/Null.hsdeleted−26

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

1−{-# language DataKinds #-}

2−{-# language StandaloneKindSignatures #-}

3−{-# language TypeFamilyDependencies #-}

4−

5−module Rel8.Column.Null

6− ( HNull

7− )

8−where

9−

10−-- base

11−import Data.Kind ( Type )

12−import Prelude

13−

14−-- rel8

15−import qualified Rel8.Schema.Kind as K

16−import Rel8.Schema.Result ( Result )

17−import Rel8.Table.Null ( NullTable )

18−

19−

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

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

22−-- context.

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

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

25− HNull Result = Maybe

26− HNull context = NullTable context

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

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

1212import Prelude ()

1313

1414-- rel8

15+import Rel8.Aggregate ( Aggregate )

16+import Rel8.Expr ( Expr )

1517import qualified Rel8.Schema.Kind as K

18+import Rel8.Schema.Name ( Name )

1619import Rel8.Schema.Result ( Result )

1720import Rel8.Table.These ( TheseTable )

1821

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

2528-- 'Result' context.

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

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

31+ HThese Aggregate = TheseTable Aggregate

32+ HThese Expr = TheseTable Expr

33+ HThese Name = TheseTable Name

2834 HThese Result = These

29− HThese context = TheseTable context

src/Rel8/Expr.hs+25−13

@@ -1,9 +1,12 @@

11{-# language DataKinds #-}

22{-# language DerivingStrategies #-}

3−{-# language FlexibleContexts #-}

43{-# language FlexibleInstances #-}

4+{-# language GADTs #-}

55{-# language MultiParamTypeClasses #-}

6+{-# language PolyKinds #-}

7+{-# language RoleAnnotations #-}

68{-# language ScopedTypeVariables #-}

9+{-# language StandaloneDeriving #-}

710{-# language StandaloneKindSignatures #-}

811{-# language TypeApplications #-}

912{-# language TypeFamilies #-}

@@ -15,7 +18,7 @@ module Rel8.Expr

1518where

1619

1720-- base

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

21+import Data.Kind ( Type )

1922import Data.String ( IsString, fromString )

2023import Prelude hiding ( null )

2124

@@ -32,9 +35,11 @@ import Rel8.Expr.Opaleye

3235 , zipPrimExprsWith

3336 )

3437import Rel8.Expr.Serialize ( litExpr )

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

36−import qualified Rel8.Schema.Kind as K

38+import Rel8.Schema.Context.Lower ( Lower )

39+import Rel8.Schema.HTable.Identity ( HIdentity( HType ), HType )

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

41+import Rel8.Schema.Result ( Result( R ) )

42+import Rel8.Schema.Spec ( Spec( Spec ) )

3843import Rel8.Table

3944 ( Table, Columns, Context, fromColumns, toColumns

4045 , FromExprs, fromResult, toResult

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

4752

4853

4954-- | Typed SQL expressions.

50−type Expr :: K.Context

51−newtype Expr a = Expr Opaleye.PrimExpr

52− deriving stock Show

55+type Expr :: k -> Type

56+data Expr a where

57+ Expr :: forall (a :: Type). !Opaleye.PrimExpr -> Expr a

58+ E :: { unE :: !(Expr a) } -> Expr ('Spec a)

59+

60+

61+deriving stock instance Show (Expr a)

62+

63+

64+type instance Lower Expr = Expr

5365

5466

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

@@ -114,12 +126,12 @@ instance Sql DBFloating a => Floating (Expr a) where

114126

115127

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

117− type Columns (Expr a) = HIdentity a

129+ type Columns (Expr a) = HType a

118130 type Context (Expr a) = Expr

119131 type FromExprs (Expr a) = a

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

132+ type Transpose to (Expr a) = Lower to a

121133

122− toColumns a = HIdentity a

123− fromColumns (HIdentity a) = a

124− toResult a = HIdentity (Identity a)

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

134+ toColumns a = HType (E a)

135+ fromColumns (HType (E a)) = a

136+ toResult a = HType (R a)

137+ fromResult (HType (R a)) = a

src/Rel8/Expr.hs-boot+10−4

@@ -1,4 +1,8 @@

11{-# language DataKinds #-}

2+{-# language GADTs #-}

3+{-# language PolyKinds #-}

4+{-# language RankNTypes #-}

5+{-# language RoleAnnotations #-}

26{-# language StandaloneKindSignatures #-}

48module Rel8.Expr

@@ -7,14 +11,16 @@ module Rel8.Expr

711where

812

913-- base

14+import Data.Kind ( Type )

1015import Prelude ()

1116

1217-- opaleye

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

1419

15−-- rel8

16−import Rel8.Schema.Kind ( Context )

20+import Rel8.Schema.Spec ( Spec(..) )

1721

1822

19−type Expr :: Context

20−newtype Expr a = Expr Opaleye.PrimExpr

23+type Expr :: k -> Type

24+data Expr a where

25+ Expr :: forall (a :: Type). !Opaleye.PrimExpr -> Expr a

26+ E :: { unE :: !(Expr a) } -> Expr ('Spec a)

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

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

1010 , and, or

1111 , min, max

1212 , sum, sumWhere

13− , avg

1413 , stringAgg

1514 , groupByExpr

1615 , listAggExpr, nonEmptyAggExpr

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

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

2524

2625-- opaleye

27−import qualified Opaleye.Internal.Aggregate as Opaleye

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

29−import qualified Opaleye.Aggregate as Opaleye

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

3027

3128-- rel8

32−import Rel8.Aggregate ( Aggregate, unsafeMakeAggregate )

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

3330import Rel8.Expr ( Expr )

3431import Rel8.Expr.Bool ( caseExpr )

3532import Rel8.Expr.Opaleye

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

5350

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

5552count :: Expr a -> Aggregate Int64

56−count = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.count

53+count = unsafeMakeAggregate toPrimExpr fromPrimExpr $

54+ Just Aggregator

55+ { operation = Opaleye.AggrCount

56+ , ordering = []

57+ , distinction = Opaleye.AggrAll

58+ }

59+

5760

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

5962-- @COUNT(DISTINCT a)@

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

6164countDistinct = unsafeMakeAggregate toPrimExpr fromPrimExpr $

62− Opaleye.distinctAggregator Opaleye.count

65+ Just Aggregator

66+ { operation = Opaleye.AggrCount

67+ , ordering = []

68+ , distinction = Opaleye.AggrDistinct

69+ }

6370

6471

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

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

7481

7582-- | Corresponds to @bool_and@.

7683and :: Expr Bool -> Aggregate Bool

77−and = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.boolAnd

84+and = unsafeMakeAggregate toPrimExpr fromPrimExpr $

85+ Just Aggregator

86+ { operation = Opaleye.AggrBoolAnd

87+ , ordering = []

88+ , distinction = Opaleye.AggrAll

89+ }

7890

7991

8092-- | Corresponds to @bool_or@.

8193or :: Expr Bool -> Aggregate Bool

82−or = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.boolOr

94+or = unsafeMakeAggregate toPrimExpr fromPrimExpr $

95+ Just Aggregator

96+ { operation = Opaleye.AggrBoolOr

97+ , ordering = []

98+ , distinction = Opaleye.AggrAll

99+ }

83100

84101

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

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

87−max = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.unsafeMax

104+max = unsafeMakeAggregate toPrimExpr fromPrimExpr $

105+ Just Aggregator

106+ { operation = Opaleye.AggrMax

107+ , ordering = []

108+ , distinction = Opaleye.AggrAll

109+ }

88110

89111

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

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

92−min = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.unsafeMin

114+min = unsafeMakeAggregate toPrimExpr fromPrimExpr $

115+ Just Aggregator

116+ { operation = Opaleye.AggrMin

117+ , ordering = []

118+ , distinction = Opaleye.AggrAll

119+ }

93120

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

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

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

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

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

98125-- your input.

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

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

101−

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

128+ Just Aggregator

129+ { operation = Opaleye.AggrSum

130+ , ordering = []

131+ , distinction = Opaleye.AggrAll

132+ }

102133

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

110134

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

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

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

118142stringAgg :: Sql DBString a

119143 => Expr db -> Expr a -> Aggregate a

120144stringAgg delimiter =

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

145+ unsafeMakeAggregate toPrimExpr (castExpr . fromPrimExpr) $

146+ Just Aggregator

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

148+ , ordering = []

149+ , distinction = Opaleye.AggrAll

150+ }

122151

123152

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

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

126−groupByExpr = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.groupBy

155+groupByExpr = unsafeMakeAggregate toPrimExpr fromPrimExpr Nothing

127156

128157

129158-- | Collect expressions values as a list.

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

138167

139168slistAggExpr :: ()

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

141−slistAggExpr info = unsafeMakeAggregate to fromPrimExpr Opaleye.arrayAgg

170+slistAggExpr info = unsafeMakeAggregate to fromPrimExpr $ Just

171+ Aggregator

172+ { operation = Opaleye.AggrArr

173+ , ordering = []

174+ , distinction = Opaleye.AggrAll

175+ }

142176 where

143177 to = encodeArrayElement info . toPrimExpr

144178

145179

146180snonEmptyAggExpr :: ()

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

148−snonEmptyAggExpr info = unsafeMakeAggregate to fromPrimExpr Opaleye.arrayAgg

182+snonEmptyAggExpr info = unsafeMakeAggregate to fromPrimExpr $ Just

183+ Aggregator

184+ { operation = Opaleye.AggrArr

185+ , ordering = []

186+ , distinction = Opaleye.AggrAll

187+ }

149188 where

150189 to = encodeArrayElement info . toPrimExpr

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

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

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

66module Rel8.Expr.Num

7− ( fromIntegral

8− , realToFrac

9− , div, mod, divMod

10− , quot, rem, quotRem

11− , ceiling, floor, round, truncate

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

128 )

139where

1410

1511-- base

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

12+import Prelude ()

1713

1814-- rel

1915import Rel8.Expr ( Expr( Expr ) )

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

2116import Rel8.Expr.Function ( function )

2217import Rel8.Expr.Opaleye ( castExpr )

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

24−import Rel8.Table.Bool ( bool )

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

2620

2721

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

4842ceiling = function "ceiling"

4943

5044

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

52−-- PostgreSQL.

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

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

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

47+div = function "div"

5548

5649

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

58−-- PostgreSQL.

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

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

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)

52+mod = function "mod"

8653

8754

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

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

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

1010 , scastExpr, sunsafeCastExpr

1111 , unsafeLiteral

1212 , fromPrimExpr, toPrimExpr, mapPrimExpr, zipPrimExprsWith, traversePrimExpr

13− , toColumn, fromColumn, traverseFieldP

13+ , toColumn, fromColumn

1414 )

1515where

1616

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

3330

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

3532castExpr = scastExpr typeInformation

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

8380traversePrimExpr f = fmap fromPrimExpr . f . toPrimExpr

8481

8582

86−traverseFieldP :: Profunctor p

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

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

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

90−

91−

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

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

9384toColumn = Opaleye.Column

9485

9586

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

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

9788fromColumn (Opaleye.Column a) = a

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

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

1111import Rel8.Expr ( Expr )

1212import Rel8.Expr.Function ( function )

1313import Rel8.Expr.Serialize ( litExpr )

14−import Rel8.Expr.Text ( quoteIdent )

1514

1615-- text

1716import Data.Text ( pack )

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

1918

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

2120nextval :: String -> Expr Int64

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

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

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

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

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

2320 )

2421where

2522

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

2724import Data.Bool ( Bool )

2825import Data.Int ( Int32 )

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

30−import Prelude ( flip )

27+import Prelude ()

3128

3229-- bytestring

3330import Data.ByteString ( ByteString )

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

5249

5350

5451-- | Matches regular expression, case sensitive

55−--

52+--

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

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

5855(~.) = binaryOperator "~."

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

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

277274translate :: Expr Text -> Expr Text -> Expr Text -> Expr Text

278275translate = function "translate"

279−

280−

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

282−--

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

284−-- you can write expressions like

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

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

287−like = flip (binaryOperator "LIKE")

288−

289−

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

291−--

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

293−-- you can write expressions like

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

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

296−ilike = flip (binaryOperator "ILIKE")

src/Rel8/Expr/Window.hsdeleted−121

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

1−module Rel8.Expr.Window

2− ( cumulative

3− , rowNumber

4− , rank

5− , denseRank

6− , percentRank

7− , cumeDist

8− , ntile

9− , lag

10− , lead

11− , firstValue

12− , lastValue

13− , nthValue

14− )

15−where

16−

17−-- base

18−import Data.Int ( Int32, Int64 )

19−import Prelude

20−

21−-- opaleye

22−import qualified Opaleye.Internal.Aggregate as Opaleye

23−import qualified Opaleye.Internal.PackMap as Opaleye

24−import qualified Opaleye.Internal.Window as Opaleye

25−import qualified Opaleye.Window as Opaleye

26−

27−-- profunctors

28−import Data.Profunctor (dimap)

29−

30−-- rel8

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

32−import Rel8.Expr ( Expr )

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

34−import Rel8.Schema.Null ( Nullify )

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

36−

37−

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

39−cumulative f =

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

41−

42−

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

44−rowNumber :: Window a (Expr Int64)

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

46−

47−

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

49−rank :: Window a (Expr Int64)

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

51−

52−

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

54−denseRank :: Window a (Expr Int64)

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

56−

57−

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

59−percentRank :: Window a (Expr Double)

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

61−

62−

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

64−cumeDist :: Window a (Expr Double)

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

66−

67−

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

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

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

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

72−

73−

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

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

76−lag offset def =

77− fromWindowFunction $

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

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

80−

81−

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

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

84−lead offset def =

85− fromWindowFunction $

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

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

88−

89−

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

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

92−firstValue =

93− fromWindowFunction $

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

95− Opaleye.firstValue

96−

97−

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

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

100−lastValue =

101− fromWindowFunction $

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

103− Opaleye.lastValue

104−

105−

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

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

108−nthValue n =

109− fromWindowFunction $

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

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

112−

113−

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

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

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

117−

118−

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

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

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

src/Rel8/Generic/Construction.hs+24−24

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

2929import Prelude

3030

3131-- rel8

32−import Rel8.Aggregate ( Aggregate( Aggregate ) )

33−import Rel8.Expr ( Expr )

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

33+import Rel8.Expr ( Expr( E ) )

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

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

6161import qualified Rel8.Schema.Kind as K

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

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

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

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

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

6565import Rel8.Table

6666 ( TTable, TColumns

6767 , Table, fromColumns, toColumns

@@ -127,11 +127,11 @@ ggbuild gfromColumns = case algebraSing @algebra of

127127 @name

128128 @(Eval (rep Expr))

129129 (const toColumns)

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

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

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

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

132132 Null -> id

133− NotNull -> nullify)

134− (HIdentity . litExpr)

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

134+ (HType . E . litExpr)

135135

136136

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

@@ -198,11 +198,11 @@ ggconstruct gfromColumns f = case algebraSing @algebra of

198198 @Expr

199199 @(Eval (rep Expr))

200200 (const toColumns)

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

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

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

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

203203 Null -> id

204− NotNull -> nullify)

205− (HIdentity . litExpr)

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

205+ (HType . E . litExpr)

206206

207207

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

@@ -230,7 +230,7 @@ ggdeconstruct gtoColumns = case algebraSing @algebra of

230230 SSum ->

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

232232 let

233− (HIdentity tag, cases) =

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

234234 gdeconstructADT

235235 @(TTable Expr)

236236 @TColumns

@@ -238,9 +238,9 @@ ggdeconstruct gtoColumns = case algebraSing @algebra of

238238 @Expr

239239 @(Eval (rep Expr))

240240 (const fromColumns)

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

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

242242 Null -> id

243− NotNull -> unsafeUnnullify)

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

244244 constructors $

245245 gtoColumns as

246246 in

@@ -279,8 +279,8 @@ ggname gfromColumns = case algebraSing @algebra of

279279 @Name

280280 @(Eval (rep Name))

281281 (const toColumns)

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

283− (HIdentity tag)

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

283+ (HType (N tag))

284284

285285

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

@@ -330,15 +330,15 @@ ggaggregate gfromColumns gtoColumns agg es = case algebraSing @algebra of

330330 @Aggregate

331331 @(Eval (rep Aggregate))

332332 (const toColumns)

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

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

335− (HIdentity (groupByExpr tag))

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

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

335+ (HType (A (groupByExpr tag)))

336336 where

337337 f =

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

339339 agg .

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

341− (HIdentity tag, exprs) =

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

342342 gunbuildADT

343343 @(TTable Expr)

344344 @TColumns

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

346346 @Expr

347347 @(Eval (rep Expr))

348348 (const fromColumns)

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

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

350350 Null -> id

351− NotNull -> unsafeUnnullify) $

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

352352 gtoColumns es

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

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

11{-# language AllowAmbiguousTypes #-}

22{-# language BlockArguments #-}

33{-# language DataKinds #-}

4−{-# language FlexibleContexts #-}

54{-# language FlexibleInstances #-}

65{-# language MultiParamTypeClasses #-}

76{-# language RankNTypes #-}

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

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

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

5251import Rel8.Schema.HTable ( HTable )

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

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

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

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

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

5756import Rel8.Schema.Null ( Nullify )

58−import Rel8.Schema.Spec ( Spec )

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

5958import qualified Rel8.Schema.Kind as K

6059import Rel8.Type.Tag ( Tag( Tag ) )

6160

@@ -64,15 +63,23 @@ import Data.Text ( pack )

6463

6564

6665type Null :: K.Context -> Type

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

66+type Null context = forall a. ()

67+ => SSpec ('Spec a)

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

6869

6970

7071type Nullifier :: K.Context -> Type

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

72+type Nullifier context = forall a. ()

73+ => SSpec ('Spec a)

74+ -> context ('Spec a)

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

7276

7377

7478type Unnullifier :: K.Context -> Type

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

79+type Unnullifier context = forall a. ()

80+ => SSpec ('Spec a)

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

82+ -> context ('Spec a)

7683

7784

7885type NoConstructor :: Symbol -> Symbol -> ErrorMessage

@@ -186,7 +193,7 @@ class GConstructableADT _Table _Columns f context rep where

186193 gbuildADT :: ()

187194 => ToColumns _Table _Columns f context

188195 -> (Tag -> Nullifier context)

189− -> HIdentity Tag context

196+ -> HType Tag context

190197 -> GFieldsADT f rep

191198 -> GColumnsADT _Columns rep context

192199

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

194201 => FromColumns _Table _Columns f context

195202 -> Unnullifier context

196203 -> GColumnsADT _Columns rep context

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

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

198205

199206 gconstructADT :: ()

200207 => ToColumns _Table _Columns f context

201208 -> Null context

202209 -> Nullifier context

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

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

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

205212

206213 gdeconstructADT :: ()

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

208215 -> Unnullifier context

209216 -> GConstructors f rep r

210217 -> GColumnsADT _Columns rep context

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

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

212219

213220

214221instance

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

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

216223 , GConstructableADT' _Table _Columns f context htable rep

217224 )

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

@@ -382,13 +389,13 @@ class GMakeableADT _Table _Columns f context name rep where

382389 => ToColumns _Table _Columns f context

383390 -> Null context

384391 -> Nullifier context

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

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

386393 -> GFields f (GConstructorADT name rep)

387394 -> GColumnsADT _Columns rep context

388395

389396

390397instance

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

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

392399 , meta ~ 'MetaData datatype _module _package _newtype

393400 , fallback ~ TypeError (NoConstructor datatype name)

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

src/Rel8/Generic/Record.hs−2

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

11{-# language AllowAmbiguousTypes #-}

22{-# language DataKinds #-}

3−{-# language FlexibleContexts #-}

43{-# language FlexibleInstances #-}

54{-# language MultiParamTypeClasses #-}

65{-# language PolyKinds #-}

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

142141 uncount = id

143142

144143

145−type Record :: Type -> Type

146144newtype Record a = Record

147145 { unrecord :: a

148146 }

src/Rel8/Generic/Rel8able.hs+65−150

@@ -3,16 +3,12 @@

33{-# language DataKinds #-}

44{-# language DefaultSignatures #-}

55{-# language FlexibleContexts #-}

6−{-# language FlexibleInstances #-}

76{-# language LambdaCase #-}

8−{-# language MultiParamTypeClasses #-}

9−{-# language PolyKinds #-}

10−{-# language QuantifiedConstraints #-}

117{-# language ScopedTypeVariables #-}

128{-# language StandaloneKindSignatures #-}

139{-# language TypeApplications #-}

10+{-# language TypeFamilies #-}

1411{-# language TypeFamilyDependencies #-}

15−{-# language TypeOperators #-}

1612{-# language UndecidableInstances #-}

1713

1814module Rel8.Generic.Rel8able

@@ -21,38 +17,31 @@ module Rel8.Generic.Rel8able

2117 , GRep

2218 , GColumns, gfromColumns, gtoColumns

2319 , GFromExprs, gfromResult, gtoResult

24− , TSerialize, serialize, deserialize

2520 )

2621where

2722

2823-- base

29−import Data.Functor.Identity ( Identity )

3024import Data.Kind ( Constraint, Type )

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

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

3326import Prelude

3427

3528-- rel8

3629import Rel8.Aggregate ( Aggregate )

3730import Rel8.Expr ( Expr )

38−import Rel8.FCF ( Exp, Eval )

31+import Rel8.Generic.Map ( GMap )

3932import Rel8.Generic.Record ( Record(..) )

4033import Rel8.Generic.Table ( GAlgebra )

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

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

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

44−import Rel8.Schema.Field ( Field )

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

4537import Rel8.Schema.HTable ( HTable )

4638import qualified Rel8.Schema.Kind as K

4739import Rel8.Schema.Name ( Name )

4840import Rel8.Schema.Result ( Result )

4941import Rel8.Table

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

51− , FromExprs, fromResult, toResult

52− , Transpose

53− , TTable, TColumns

42+ ( fromColumns, toColumns, fromResult, toResult

43+ , TTable, TColumns, TFromExprs

5444 )

55−import Rel8.Table.Transpose ( Transposes )

5645

5746

5847-- | The kind of 'Rel8able' types

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

6049type KRel8able = K.Rel8able

6150

6251

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−

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

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

11854--

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

14682-- [Supplying @Rel8able@ instances]

14783--

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

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

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

15086-- extensions:

15187--

15288-- @

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

16096 type GColumns t :: K.HTable

16197 type GFromExprs t :: Type

16298

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

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

99+ gfromColumns :: Abstract context -> GColumns t context -> t context

100+ gtoColumns :: Abstract context -> t context -> GColumns t context

165101

166102 gfromResult :: GColumns t Result -> GFromExprs t

167103 gtoResult :: GFromExprs t -> GColumns t Result

@@ -170,42 +106,62 @@ class HTable (GColumns t) => Rel8able t where

170106 type GFromExprs t = t Result

171107

172108 default gfromColumns :: forall context.

173− ( SRel8able t Aggregate

174− , SRel8able t Expr

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

176− , SRel8able t Name

177− , SSerialize t

109+ ( VRel8able t Aggregate

110+ , VRel8able t Expr

111+ , VRel8able t Name

178112 )

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

113+ => Abstract context -> GColumns t context -> t context

180114 gfromColumns = \case

181− SAggregate -> sfromColumns

182− SExpr -> sfromColumns

183− SField -> sfromColumns

184− SName -> sfromColumns

185− SResult -> sfromResult

115+ VAggregate -> vfromColumns

116+ VExpr -> vfromColumns

117+ VName -> vfromColumns

186118

187119 default gtoColumns :: forall context.

188− ( SRel8able t Aggregate

189− , SRel8able t Expr

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

191− , SRel8able t Name

192− , SSerialize t

120+ ( VRel8able t Aggregate

121+ , VRel8able t Expr

122+ , VRel8able t Name

193123 )

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

124+ => Abstract context -> t context -> GColumns t context

195125 gtoColumns = \case

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)

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

203137 => GColumns t Result -> GFromExprs t

204− gfromResult = sfromResult

205−

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

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

207155 => GFromExprs t -> GColumns t Result

208− gtoResult = stoResult

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

209165

210166

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

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

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

217173

218174

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

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

176+type VRel8able t context =

227177 ( Generic (Record (t context))

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

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

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

230180 )

231− => SRel8able t context

232181

233182

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

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

243184 => GColumns t context -> t context

244−sfromColumns =

185+vfromColumns =

245186 unrecord .

246187 to .

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

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

248189

249190

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

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

251192 => t context -> GColumns t context

252−stoColumns =

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

254− from .

255− Record

256−

257−

258−sfromResult :: forall t. SSerialize t

259− => GColumns t Result -> t Result

260−sfromResult =

261− unrecord .

262− to .

263− G.gfromResult

264− @TSerialize

265− @TColumns

266− @(GRep t Expr)

267− @(GRep t Result)

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

269−

270−

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

193+vtoColumns =

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

280195 from .

281196 Record

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

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

1212{-# language UndecidableInstances #-}

1313

1414module Rel8.Generic.Table

15− ( GGSerialize, GGColumns, ggfromResult, ggtoResult

15+ ( GGTable, GGColumns, ggfromResult, ggtoResult

1616 , GAlgebra

1717 )

1818where

@@ -24,10 +24,11 @@ import Prelude ()

2424

2525-- rel8

2626import Rel8.FCF ( Eval, Exp )

27+import Rel8.Generic.Map ( GMap )

2728import Rel8.Generic.Table.ADT

28− ( GSerializeADT, GColumnsADT, gtoResultADT, gfromResultADT

29+ ( GTableADT, GColumnsADT, gtoResultADT, gfromResultADT

2930 )

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

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

3132import Rel8.Kind.Algebra

3233 ( Algebra( Product, Sum )

3334 , SAlgebra( SProduct, SSum )

@@ -37,21 +38,21 @@ import qualified Rel8.Schema.Kind as K

3738import Rel8.Schema.Result ( Result )

3839

3940

40−data GGSerialize

41+data GGTable

4142 :: Algebra

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

43+ -> (Type -> Exp Constraint)

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

44− -> (Type -> Type)

45+ -> (Type -> Exp Type)

4546 -> (Type -> Type)

4647 -> Exp Constraint

4748

4849

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

50− GSerialize _Serialize _Columns exprs rep

50+type instance Eval (GGTable 'Product _Table _Columns _FromExprs rep) =

51+ GTable _Table _Columns _FromExprs rep

5152

5253

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

54− GSerializeADT _Serialize _Columns exprs rep

54+type instance Eval (GGTable 'Sum _Table _Columns _FromExprs rep) =

55+ GTableADT _Table _Columns _FromExprs rep

5556

5657

5758data GGColumns

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

7778 GAlgebra (K1 _ _) = 'Product

7879

7980

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

81+ggfromResult :: forall algebra _Table _Columns _FromExprs rep x.

8182 ( KnownAlgebra algebra

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

83+ , Eval (GGTable algebra _Table _Columns _FromExprs rep)

8384 )

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

85+ => (forall a proxy. Eval (_Table a)

86+ => proxy a -> Eval (_Columns a) Result -> Eval (_FromExprs a))

87+ -> Eval (GGColumns algebra _Columns rep) Result

88+ -> GMap _FromExprs rep x

8889ggfromResult f x = case algebraSing @algebra of

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

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

90+ SProduct -> gfromResult @_Table @_Columns @_FromExprs @rep f x

91+ SSum -> gfromResultADT @_Table @_Columns @_FromExprs @rep f x

9192

9293

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

94+ggtoResult :: forall algebra _Table _Columns _FromExprs rep x.

9495 ( KnownAlgebra algebra

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

96+ , Eval (GGTable algebra _Table _Columns _FromExprs rep)

9697 )

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

98+ => (forall a proxy. Eval (_Table a)

99+ => proxy a -> Eval (_FromExprs a) -> Eval (_Columns a) Result)

100+ -> GMap _FromExprs rep x

101+ -> Eval (GGColumns algebra _Columns rep) Result

101102ggtoResult f x = case algebraSing @algebra of

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

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

103+ SProduct -> gtoResult @_Table @_Columns @_FromExprs @rep f x

104+ SSum -> gtoResultADT @_Table @_Columns @_FromExprs @rep f x

src/Rel8/Generic/Table/ADT.hs+68−64

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

11{-# language AllowAmbiguousTypes #-}

22{-# language DataKinds #-}

3−{-# language FlexibleContexts #-}

43{-# language FlexibleInstances #-}

54{-# language LambdaCase #-}

65{-# language MultiParamTypeClasses #-}

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

1312{-# language UndecidableInstances #-}

1413

1514module Rel8.Generic.Table.ADT

16− ( GSerializeADT, GColumnsADT, gfromResultADT, gtoResultADT

17− , GSerializeADT', GColumnsADT'

15+ ( GTableADT, GColumnsADT, gfromResultADT, gtoResultADT

16+ , GTableADT', GColumnsADT'

1817 )

1918where

2019

2120-- base

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

2321import Data.Kind ( Constraint, Type )

2422import Data.Proxy ( Proxy( Proxy ) )

2523import GHC.Generics

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

3230

3331-- rel8

3432import Rel8.FCF ( Eval, Exp )

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

33+import Rel8.Generic.Map ( GMap )

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

3635import Rel8.Schema.HTable ( HTable )

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

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

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

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

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

4140import qualified Rel8.Schema.Kind as K

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

41+import Rel8.Schema.Result

42+ ( Result( R )

43+ , null, nullifier, unnullifier

44+ )

4345import Rel8.Type.Tag ( Tag( Tag ) )

4446

4547-- text

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

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

5254type family GColumnsADT _Columns rep where

5355 GColumnsADT _Columns (M1 D _ rep) =

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

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

5557

5658

5759type GColumnsADT'

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

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

6668

6769

68−type GSerializeADT

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

70+type GTableADT

71+ :: (Type -> Exp Constraint)

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

71− -> (Type -> Type) -> (Type -> Type) -> Constraint

72−class GSerializeADT _Serialize _Columns exprs rep where

73+ -> (Type -> Exp Type)

74+ -> (Type -> Type) -> Constraint

75+class GTableADT _Table _Columns _FromExprs rep where

7376 gfromResultADT :: ()

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

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

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

79+ -> GColumnsADT _Columns rep Result

80+ -> GMap _FromExprs rep x

7881

7982 gtoResultADT :: ()

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

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

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

85+ -> GMap _FromExprs rep x

86+ -> GColumnsADT _Columns rep Result

8487

8588

8689instance

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

88− , GSerializeADT' _Serialize _Columns htable exprs rep

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

91+ , GTableADT' _Table _Columns _FromExprs htable rep

8992 )

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

93+ => GTableADT _Table _Columns _FromExprs (M1 D meta rep)

9194 where

9295 gfromResultADT fromResult columns =

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

96+ case gfromResultADT' @_Table @_Columns @_FromExprs @htable @rep fromResult tag columns of

9497 Just rep -> M1 rep

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

9699 where

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

100+ tag = (\(HType (R a)) -> a) . hunlabel @"tag"

98101

99102 gtoResultADT toResult (M1 rep) =

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

103+ gtoResultADT' @_Table @_Columns @_FromExprs @htable @rep toResult tag (Just rep)

101104 where

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

105+ tag = hlabel @"tag" . HType . R

103106

104107

105−type GSerializeADT'

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

108+type GTableADT'

109+ :: (Type -> Exp Constraint)

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

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

109−class GSerializeADT' _Serialize _Columns htable exprs rep where

111+ -> (Type -> Exp Type)

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

113+class GTableADT' _Table _Columns _FromExprs htable rep where

110114 gfromResultADT' :: context ~ Result

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

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

115+ => (forall a proxy. Eval (_Table a)

116+ => proxy a -> Eval (_Columns a) context -> Eval (_FromExprs a))

113117 -> (htable Result -> Tag)

114− -> GColumnsADT' _Columns htable exprs context

115− -> Maybe (rep x)

118+ -> GColumnsADT' _Columns htable rep context

119+ -> Maybe (GMap _FromExprs rep x)

116120

117121 gtoResultADT' :: context ~ Result

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

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

122+ => (forall a proxy. Eval (_Table a)

123+ => proxy a -> Eval (_FromExprs a) -> Eval (_Columns a) context)

120124 -> (Tag -> htable Result)

121− -> Maybe (rep x)

122− -> GColumnsADT' _Columns htable exprs context

125+ -> Maybe (GMap _FromExprs rep x)

126+ -> GColumnsADT' _Columns htable rep context

123127

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

128+ extract :: GColumnsADT' _Columns htable rep context -> htable context

125129

126130

127131instance

128− ( htable' ~ GColumnsADT' _Columns htable exprs1

129− , GSerializeADT' _Serialize _Columns htable exprs1 a

130− , GSerializeADT' _Serialize _Columns htable' exprs2 b

132+ ( htable' ~ GColumnsADT' _Columns htable a

133+ , GTableADT' _Table _Columns _FromExprs htable a

134+ , GTableADT' _Table _Columns _FromExprs htable' b

131135 )

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

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

133137 where

134138 gfromResultADT' fromResult f columns =

135139 case ma of

136140 Just a -> Just (L1 a)

137141 Nothing -> R1 <$>

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

142+ gfromResultADT' @_Table @_Columns @_FromExprs @_ @b

139143 fromResult

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

144+ (f . extract @_Table @_Columns @_FromExprs @_ @a)

141145 columns

142146 where

143147 ma =

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

148+ gfromResultADT' @_Table @_Columns @_FromExprs @_ @a

145149 fromResult

146150 f

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

151+ (extract @_Table @_Columns @_FromExprs @_ @b columns)

148152

149153 gtoResultADT' toResult tag = \case

150154 Just (L1 a) ->

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

155+ gtoResultADT' @_Table @_Columns @_FromExprs @_ @b

152156 toResult

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

157+ (\_ -> gtoResultADT' @_Table @_Columns @_FromExprs @_ @a

154158 toResult

155159 tag

156160 (Just a))

157161 Nothing

158162 Just (R1 b) ->

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

163+ gtoResultADT' @_Table @_Columns @_FromExprs @_ @b

160164 toResult

161165 (\tag' ->

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

166+ gtoResultADT' @_Table @_Columns @_FromExprs @_ @a

163167 toResult

164168 (\_ -> tag tag')

165169 Nothing)

166170 (Just b)

167171 Nothing ->

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

172+ gtoResultADT' @_Table @_Columns @_FromExprs @_ @b

169173 toResult

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

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

171175 Nothing

172176

173177 extract =

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

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

178+ extract @_Table @_Columns @_FromExprs @_ @a .

179+ extract @_Table @_Columns @_FromExprs @_ @b

176180

177181

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

179− GSerializeADT' _Serialize _Columns _htable (M1 C meta U1) (M1 C meta U1)

183+ GTableADT' _Table _Columns _FromExprs htable (M1 C meta U1)

180184 where

181185 gfromResultADT' _ tag columns

182186 | tag columns == tag' = Just (M1 U1)

@@ -192,18 +196,18 @@ instance (meta ~ 'MetaCons label _fixity _isRecord, KnownSymbol label) =>

192196

193197

194198instance {-# OVERLAPPABLE #-}

195− ( HTable (GColumns _Columns exprs)

196− , GSerialize _Serialize _Columns exprs rep

199+ ( HTable (GColumns _Columns rep)

200+ , GTable _Table _Columns _FromExprs rep

197201 , meta ~ 'MetaCons label _fixity _isRecord

198202 , KnownSymbol label

199− , GColumnsADT' _Columns htable (M1 C ('MetaCons label _fixity _isRecord) exprs) ~

200− HProduct htable (HLabel label (HNullify (GColumns _Columns exprs)))

203+ , GColumnsADT' _Columns htable (M1 C ('MetaCons label _fixity _isRecord) rep) ~

204+ HProduct htable (HLabel label (HNullify (GColumns _Columns rep)))

201205 )

202− => GSerializeADT' _Serialize _Columns htable (M1 C meta exprs) (M1 C meta rep)

206+ => GTableADT' _Table _Columns _FromExprs htable (M1 C meta rep)

203207 where

204208 gfromResultADT' fromResult tag (HProduct a b)

205209 | tag a == tag' =

206− M1 . gfromResult @_Serialize @_Columns @exprs @rep fromResult <$>

210+ M1 . gfromResult @_Table @_Columns @_FromExprs @rep fromResult <$>

207211 hunnullify unnullifier (hunlabel b)

208212 | otherwise = Nothing

209213 where

@@ -214,7 +218,7 @@ instance {-# OVERLAPPABLE #-}

214218 Just (M1 rep) -> HProduct (tag tag') $

215219 hlabel $

216220 hnullify nullifier $

217− gtoResult @_Serialize @_Columns @exprs @rep toResult rep

221+ gtoResult @_Table @_Columns @_FromExprs @rep toResult rep

218222 where

219223 tag' = Tag $ pack $ symbolVal (Proxy @label)

220224

src/Rel8/Generic/Table/Record.hs+50−78

@@ -13,8 +13,8 @@

1313{-# language UndecidableInstances #-}

1414

1515module Rel8.Generic.Table.Record

16− ( GTable, GColumns, GContext, gfromColumns, gtoColumns, gtable

17− , GSerialize, gfromResult, gtoResult

16+ ( GTable, GColumns, GContext

17+ , gfromColumns, gtoColumns, gfromResult, gtoResult, gtable

1818 )

1919where

2020

@@ -30,6 +30,7 @@ import Prelude hiding ( null )

3030

3131-- rel8

3232import Rel8.FCF ( Eval, Exp )

33+import Rel8.Generic.Map ( GMap )

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

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

3536import qualified Rel8.Schema.Kind as K

@@ -55,8 +56,9 @@ type family GContext _Context rep where

5556type GTable

5657 :: (Type -> Exp Constraint)

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

59+ -> (Type -> Exp Type)

5860 -> (Type -> Type) -> Constraint

59−class GTable _Table _Columns rep

61+class GTable _Table _Columns _FromExprs rep

6062 where

6163 gfromColumns :: ()

6264 => (forall a. Eval (_Table a) => Eval (_Columns a) context -> a)

@@ -68,93 +70,73 @@ class GTable _Table _Columns rep

6870 -> rep x

6971 -> GColumns _Columns rep context

7072

71− gtable :: ()

72− => (forall a proxy. Eval (_Table a) => proxy a -> Eval (_Columns a) context)

73− -> GColumns _Columns rep context

74−

75−

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

8273 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

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

8778

8879 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

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

9384

85+ gtable :: ()

86+ => (forall a proxy. Eval (_Table a) => proxy a -> Eval (_Columns a) context)

87+ -> GColumns _Columns rep context

9488

95−instance GTable _Table _Columns rep => GTable _Table _Columns (M1 D c rep)

89+

90+instance GTable _Table _Columns _FromExprs rep =>

91+ GTable _Table _Columns _FromExprs (M1 D c rep)

9692 where

9793 gfromColumns fromColumns =

98− M1 . gfromColumns @_Table @_Columns @rep fromColumns

94+ M1 . gfromColumns @_Table @_Columns @_FromExprs @rep fromColumns

9995 gtoColumns toColumns (M1 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

96+ gtoColumns @_Table @_Columns @_FromExprs @rep toColumns a

10797 gfromResult fromResult =

108− M1 . gfromResult @_Serialize @_Columns @exprs @rep fromResult

98+ M1 . gfromResult @_Table @_Columns @_FromExprs @rep fromResult

10999 gtoResult toResult (M1 a) =

110− gtoResult @_Serialize @_Columns @exprs @rep toResult a

100+ gtoResult @_Table @_Columns @_FromExprs @rep toResult a

101+ gtable = gtable @_Table @_Columns @_FromExprs @rep

111102

112103

113−instance GTable _Table _Columns rep => GTable _Table _Columns (M1 C c rep)

104+instance GTable _Table _Columns _FromExprs rep =>

105+ GTable _Table _Columns _FromExprs (M1 C c rep)

114106 where

115107 gfromColumns fromColumns =

116− M1 . gfromColumns @_Table @_Columns @rep fromColumns

108+ M1 . gfromColumns @_Table @_Columns @_FromExprs @rep fromColumns

117109 gtoColumns toColumns (M1 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

110+ gtoColumns @_Table @_Columns @_FromExprs @rep toColumns a

125111 gfromResult fromResult =

126− M1 . gfromResult @_Serialize @_Columns @exprs @rep fromResult

112+ M1 . gfromResult @_Table @_Columns @_FromExprs @rep fromResult

127113 gtoResult toResult (M1 a) =

128− gtoResult @_Serialize @_Columns @exprs @rep toResult a

129−

130−

131−instance (GTable _Table _Columns rep1, GTable _Table _Columns rep2) =>

132− GTable _Table _Columns (rep1 :*: rep2)

133− where

134− gfromColumns fromColumns (HProduct a b) =

135− gfromColumns @_Table @_Columns @rep1 fromColumns a :*:

136− gfromColumns @_Table @_Columns @rep2 fromColumns b

137− gtoColumns toColumns (a :*: b) = HProduct

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)

114+ gtoResult @_Table @_Columns @_FromExprs @rep toResult a

115+ gtable = gtable @_Table @_Columns @_FromExprs @rep

143116

144117

145118instance

146− ( GSerialize _Serialize _Columns expr1 rep1

147− , GSerialize _Serialize _Columns expr2 rep2

119+ ( GTable _Table _Columns _FromExprs rep1

120+ , GTable _Table _Columns _FromExprs rep2

148121 )

149− => GSerialize _Serialize _Columns (expr1 :*: expr2) (rep1 :*: rep2)

122+ => GTable _Table _Columns _FromExprs (rep1 :*: rep2)

150123 where

124+ gfromColumns fromColumns (HProduct a b) =

125+ gfromColumns @_Table @_Columns @_FromExprs @rep1 fromColumns a :*:

126+ gfromColumns @_Table @_Columns @_FromExprs @rep2 fromColumns b

127+ gtoColumns toColumns (a :*: b) = HProduct

128+ (gtoColumns @_Table @_Columns @_FromExprs @rep1 toColumns a)

129+ (gtoColumns @_Table @_Columns @_FromExprs @rep2 toColumns b)

151130 gfromResult fromResult (HProduct a b) =

152− gfromResult @_Serialize @_Columns @expr1 @rep1 fromResult a :*:

153− gfromResult @_Serialize @_Columns @expr2 @rep2 fromResult b

131+ gfromResult @_Table @_Columns @_FromExprs @rep1 fromResult a :*:

132+ gfromResult @_Table @_Columns @_FromExprs @rep2 fromResult b

154133 gtoResult toResult (a :*: b) =

155134 HProduct

156− (gtoResult @_Serialize @_Columns @expr1 @rep1 toResult a)

157− (gtoResult @_Serialize @_Columns @expr2 @rep2 toResult b)

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)

158140

159141

160142instance

@@ -162,20 +144,10 @@ instance

162144 , meta ~ 'MetaSel ('Just label) _su _ss _ds

163145 , k1 ~ K1 i a

164146 )

165− => GTable _Table _Columns (M1 S meta k1)

147+ => GTable _Table _Columns _FromExprs (M1 S meta k1)

166148 where

167149 gfromColumns fromColumns = M1 . K1 . fromColumns . hunlabel

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

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

11{-# language DataKinds #-}

22{-# language GADTs #-}

33{-# language StandaloneKindSignatures #-}

4−{-# language TypeSynonymInstances #-}

65module Rel8.Kind.Context

76 ( Reifiable( contextSing )

@@ -16,7 +15,6 @@ import Prelude ()

1615-- rel8

1716import Rel8.Aggregate ( Aggregate )

1817import Rel8.Expr ( Expr )

19−import Rel8.Schema.Field ( Field )

2018import Rel8.Schema.Kind ( Context )

2119import Rel8.Schema.Name ( Name )

2220import Rel8.Schema.Result ( Result )

@@ -26,7 +24,6 @@ type SContext :: Context -> Type

2624data SContext context where

2725 SAggregate :: SContext Aggregate

2826 SExpr :: SContext Expr

29− SField :: SContext (Field table)

3027 SName :: SContext Name

3128 SResult :: SContext Result

3229

@@ -44,10 +41,6 @@ instance Reifiable Expr where

4441 contextSing = SExpr

4542

4643

47−instance Reifiable (Field table) where

48− contextSing = SField

49−

50−

5144instance Reifiable Result where

5245 contextSing = SResult

5346

src/Rel8/Order.hs+8−1

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

55module Rel8.Order

66 ( Order(..)

7+ , toOrderExprs

78 )

89where

910

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

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

1718

1819-- opaleye

19−import qualified Opaleye.Order as Opaleye

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

21+import qualified Opaleye.Internal.Order as Opaleye

2022

2123

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

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

2830type Order :: Type -> Type

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

3032 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+9−28

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

1−{-# language FlexibleContexts #-}

21{-# language StandaloneKindSignatures #-}

3−{-# language UndecidableInstances #-}

53module Rel8.Query

64 ( Query( Query )

@@ -17,21 +15,18 @@ import Prelude

1715-- opaleye

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

1917import qualified Opaleye.Internal.PackMap as Opaleye

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

18+import qualified Opaleye.Internal.PrimQuery as Opaleye

2119import qualified Opaleye.Internal.QueryArr as Opaleye

2220import qualified Opaleye.Internal.Tag as Opaleye

2321

2422-- rel8

25−import Rel8.Expr ( Expr )

2623import Rel8.Query.Set ( unionAll )

2724import Rel8.Query.Opaleye ( fromOpaleye )

2825import Rel8.Query.Values ( values )

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

3026import Rel8.Table.Alternative

3127 ( AltTable, (<|>:)

3228 , AlternativeTable, emptyTable

3329 )

34−import Rel8.Table.Projection ( Projectable, apply, project )

3530

3631-- semigroupoids

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

@@ -156,10 +151,6 @@ newtype Query a =

156151 )

157152

158153

159−instance Projectable Query where

160− project f = fmap (fromColumns . apply f . toColumns)

161−

162−

163154instance Functor Query where

164155 fmap f (Query a) = Query (fmap (fmap (fmap f)) a)

165156

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

178169

179170

180171instance Monad Query where

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

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

182173 let

183− qa = q dummies

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

174+ Opaleye.QueryArr qa = q dummies

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

185176 Query q' = f a

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

187178 ( dummy : dummies

188− , query <> Opaleye.aRebind bindings

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

189180 , Opaleye.next tag'

190181 )

191182 where

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

193184 where

194185 random = Opaleye.FunExpr "random" []

195186 name = Opaleye.extractAttr "dummy" tag'

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

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

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

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

198189 query'''

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

200− | otherwise = query <> query''

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

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

201192 m'' = m <> m'

202193 in

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

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

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

212203instance AlternativeTable Query where

213204 emptyTable = values []

214−

215−

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

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

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

219−

220−

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

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

223− mempty = emptyTable

src/Rel8/Query/Aggregate.hs−19

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

11{-# language FlexibleContexts #-}

22{-# language MonoLocalBinds #-}

3−{-# language ScopedTypeVariables #-}

4−{-# language TypeApplications #-}

64module Rel8.Query.Aggregate

75 ( aggregate

86 , countRows

9− , mode

107 )

118where

129

1310-- base

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

1511import Data.Int ( Int64 )

1612import Prelude

1713

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

2218import Rel8.Aggregate ( Aggregates )

2319import Rel8.Expr ( Expr )

2420import Rel8.Expr.Aggregate ( countStar )

25−import Rel8.Expr.Order ( desc )

2621import Rel8.Query ( Query )

27−import Rel8.Query.Limit ( limit )

2822import Rel8.Query.Maybe ( optional )

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

3524import Rel8.Table.Opaleye ( aggregator )

3625import Rel8.Table.Maybe ( maybeTable )

3726

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

4635-- will return @0@.

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

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

49−

50−

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

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

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

54− aggregate $ do

55− row <- toColumns <$> rows

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

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

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

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

13module Rel8.Query.Distinct

24 ( distinct

35 , distinctOn

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

68where

810-- base

9−import Prelude ()

11+import Prelude

1012

1113-- opaleye

1214import qualified Opaleye.Distinct as Opaleye

13−import qualified Opaleye.Order as Opaleye

15+import qualified Opaleye.Internal.Order as Opaleye

16+import qualified Opaleye.Internal.QueryArr as Opaleye

1417

1518-- rel8

1619import Rel8.Order ( Order( Order ) )

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

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

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

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

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

36+distinctOn proj =

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

3438

3539

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

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

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

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

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

44+distinctOnBy proj (Order order) =

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

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

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

44module Rel8.Query.Evaluate

55 ( evaluate

6+ , rebind

67 )

78where

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

1516

1617-- opaleye

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

1824

1925-- rel8

2026import Rel8.Expr ( Expr )

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

2228import Rel8.Expr.Opaleye ( fromPrimExpr )

2329import Rel8.Query ( Query( Query ) )

24−import Rel8.Query.Rebind ( rebind )

2530import Rel8.Table ( Table )

2631import Rel8.Table.Bool ( case_ )

27−import Rel8.Table.Undefined ( undefined )

32+import Rel8.Table.Opaleye ( unpackspec )

33+import Rel8.Table.Undefined

2834

2935

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

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

3238-- effects and can safely be reused.

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

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

40+evaluate = laterally >=> rebind

3541

3642

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

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

4551 go = fromPrimExpr . Opaleye.UnExpr Opaleye.OpIsNotNull

4652

4753

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+

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

4968foldl1' 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

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

1616

1717-- rel8

1818import Rel8.Expr ( Expr )

src/Rel8/Query/Indexed.hsdeleted−21

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

1−module Rel8.Query.Indexed

2− ( indexed

3− )

4−where

5−

6−-- base

7−import Control.Applicative ( liftA2 )

8−import Data.Int ( Int64 )

9−import Prelude

10−

11−-- rel8

12−import Rel8.Expr ( Expr )

13−import Rel8.Expr.Window ( rowNumber )

14−import Rel8.Query ( Query )

15−import Rel8.Query.Window ( window )

16−import Rel8.Table.Window ( currentRow )

17−

18−

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

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

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

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

@@ -19,16 +19,16 @@ import Prelude

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

2020

2121-- rel8

22−import Rel8.Expr ( Expr )

22+import Rel8.Expr ( Expr( E, unE ) )

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 )

2728import 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 ( Spec( Spec, info ) )

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

3232import Rel8.Table ( Table, fromColumns )

3333import Rel8.Table.Cols ( toCols )

3434import Rel8.Table.Aggregate ( listAgg, nonEmptyAgg )

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

8585--

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

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

88−catListTable (ListTable as) =

89− rebind "unnest" $ fromColumns $ runIdentity $

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

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

89+ hunvectorize (\SSpec {info} -> pure . E . sunnest info . unE) as

9190

9291

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

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

9594--

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

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

98−catNonEmptyTable (NonEmptyTable as) =

99− rebind "unnest" $ fromColumns $ runIdentity $

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

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

98+ hunvectorize (\SSpec {info} -> pure . E . sunnest info . unE) as

10199

102100

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

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

105103--

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

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

108−catList = rebind "unnest" . sunnest typeInformation

106+catList = rebind . sunnest typeInformation

109107

110108

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

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

113111--

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

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

116−catNonEmpty = rebind "unnest" . sunnest typeInformation

114+catNonEmpty = rebind . sunnest typeInformation

117115

118116

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

src/Rel8/Query/Maybe.hs+5−5

@@ -19,7 +19,7 @@ import Control.Comonad ( extract )

1919import qualified Opaleye.Internal.MaybeFields as Opaleye

2020

2121-- rel8

22−import Rel8.Expr ( Expr )

22+import Rel8.Expr ( Expr( E ) )

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

2424import Rel8.Expr.Opaleye ( fromColumn, fromPrimExpr )

2525import Rel8.Query ( Query )

@@ -35,7 +35,7 @@ import Rel8.Table.Maybe ( MaybeTable(..), isJustTable )

3535-- JOIN@s.

3636optional :: Query a -> Query (MaybeTable Expr a)

3737optional = mapOpaleye $ Opaleye.optionalInternal $ \tag a -> MaybeTable

38− { tag = fromPrimExpr $ fromColumn tag

38+ { tag = E $ fromPrimExpr $ fromColumn tag

3939 , just = pure a

4040 }

4141

@@ -61,8 +61,8 @@ catMaybeTable ma@(MaybeTable _ a) = do

6161-- the input is @nothingTable@, you will always get exactly one @nothingTable@

6262-- back.

6363traverseMaybeTable :: (a -> Query b) -> MaybeTable Expr a -> Query (MaybeTable Expr b)

64−traverseMaybeTable query ma@(MaybeTable input _) = do

64+traverseMaybeTable query ma@(MaybeTable (E input) _) = do

6565 optional (query =<< catMaybeTable ma) >>= \case

66− MaybeTable output b -> do

66+ MaybeTable (E output) b -> do

6767 where_ $ output ==. input

68− pure $ MaybeTable input b

68+ pure $ MaybeTable (E input) b

src/Rel8/Query/Null.hs−15

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

1−{-# language FlexibleContexts #-}

2−

31module Rel8.Query.Null

42 ( catNull

5− , catNullTable

63 )

74where

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

129-- rel8

1310import Rel8.Expr ( Expr )

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

15−import Rel8.Table ( Table )

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

1712import Rel8.Query ( Query )

1813import Rel8.Query.Filter ( where_ )

1914

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

2621catNull a = do

2722 where_ $ isNonNull a

2823 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+10−18

@@ -5,7 +5,6 @@ module Rel8.Query.Opaleye

55 , toOpaleye

66 , mapOpaleye

77 , zipOpaleyeWith

8− , unsafePeekQuery

98 )

109where

1110

@@ -15,7 +14,6 @@ import Prelude

1514

1615-- opaleye

1716import qualified Opaleye.Internal.QueryArr as Opaleye

18−import qualified Opaleye.Internal.Tag as Opaleye

1917

2018-- rel8

2119import {-# SOURCE #-} Rel8.Query ( Query( Query ) )

@@ -39,32 +37,26 @@ zipOpaleyeWith :: ()

3937zipOpaleyeWith f (Query a) (Query b) = Query $ liftA2 (zipping f) a b

4038

4139

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−

4840mapping :: ()

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

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

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

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

5244 let

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

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

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

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

5547 in

56− Opaleye.runStateQueryArr q' () tag

48+ qa' ((), tag)

5749

5850

5951zipping :: Semigroup m

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

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

62−zipping f q q' =

63− Opaleye.stateQueryArr $ \_ tag ->

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

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

6456 let

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

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

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

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

6759 m'' = m <> m'

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

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

6961 in

70− Opaleye.runStateQueryArr q'' () tag

62+ qa'' ((), tag)

src/Rel8/Query/Rebind.hsdeleted−27

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

1−{-# language FlexibleContexts #-}

2−

3−module Rel8.Query.Rebind

4− ( rebind

5− )

6−where

7−

8−-- base

9−import Prelude

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

11−

12−-- opaleye

13−import qualified Opaleye.Internal.Rebind as Opaleye

14−

15−-- rel8

16−import Rel8.Expr ( Expr )

17−import Rel8.Query ( Query )

18−import Rel8.Table ( Table )

19−import Rel8.Table.Opaleye ( unpackspec )

20−import Rel8.Query.Opaleye (fromOpaleye)

21−

22−

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

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

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

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

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

src/Rel8/Query/SQL.hs+60−6

@@ -1,21 +1,75 @@

11{-# language FlexibleContexts #-}

2−{-# language MonoLocalBinds #-}

2+{-# language TypeFamilies #-}

3+{-# language ViewPatterns #-}

45module Rel8.Query.SQL

56 ( showQuery

7+ , sqlForQuery, sqlForQueryWithNames

68 )

79where

810

911-- base

12+import Data.Foldable ( fold )

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

14+import Data.Void ( Void )

1015import Prelude

1116

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+

1225-- rel8

13−import Rel8.Expr ( Expr )

26+import Rel8.Expr ( Expr( E ) )

27+import Rel8.Expr.Opaleye ( toPrimExpr )

1428import Rel8.Query ( Query )

15−import Rel8.Statement.Select ( ppSelect )

16−import Rel8.Table ( Table )

29+import Rel8.Query.Opaleye ( toOpaleye )

30+import Rel8.Schema.Name ( Name( N, Name ), Selects )

31+import Rel8.Schema.HTable ( htabulateA, hfield )

32+import Rel8.Table ( Table, toColumns )

33+import Rel8.Table.Cols ( toCols )

34+import Rel8.Table.Name ( namesFromLabels )

35+import Rel8.Table.Opaleye ( castTable )

1736

1837

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

38+-- | Convert a query to a 'String' containing the query as a @SELECT@

39+-- statement.

2040showQuery :: Table Expr a => Query a -> String

21−showQuery = show . ppSelect

41+showQuery = fold . sqlForQuery

42+

43+

44+sqlForQuery :: Table Expr a

45+ => Query a -> Maybe String

46+sqlForQuery = sqlForQueryWithNames namesFromLabels . fmap toCols

47+

48+

49+sqlForQueryWithNames :: Selects names exprs

50+ => names -> Query exprs -> Maybe String

51+sqlForQueryWithNames names query =

52+ show . Opaleye.ppSql . selectFrom names exprs <$> optimize primQuery

53+ where

54+ (exprs, primQuery, _) =

55+ Opaleye.runSimpleQueryArrStart (toOpaleye query) ()

56+

57+

58+optimize :: Opaleye.PrimQuery' a -> Maybe (Opaleye.PrimQuery' Void)

59+optimize = Opaleye.removeEmpty . Opaleye.optimize

60+

61+

62+selectFrom :: Selects names exprs

63+ => names -> exprs -> Opaleye.PrimQuery' Void -> Opaleye.Select

64+selectFrom (toColumns -> names) (toColumns . castTable -> exprs) query =

65+ Opaleye.SelectFrom $ Opaleye.newSelect

66+ { Opaleye.attrs = Opaleye.SelectAttrs attributes

67+ , Opaleye.tables = Opaleye.oneTable select

68+ }

69+ where

70+ select = Opaleye.foldPrimQuery Opaleye.sqlQueryGenerator query

71+ attributes = getConst $ htabulateA $ \field -> case hfield names field of

72+ N (Name name) -> case hfield exprs field of

73+ E (toPrimExpr -> expr) -> Const (pure (makeAttr name expr))

74+ makeAttr label expr =

75+ (Opaleye.sqlExpr expr, Just (Opaleye.SqlColumn label))

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

26+-- duplicates. @union a b@ is the same as the SQL statement @x 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 @a UNION ALL b@.

32+-- @unionAll a b@ is the same as the SQL statement @x 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 @a INTERSECT b@.

38+-- b@ is the same as the SQL statement @x 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 @a INTERSECT ALL b@.

44+-- a b@ is the same as the SQL statement @x 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 @a EXCEPT b@.

50+-- the same as the SQL statement @x INTERSECT 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 @a EXCEPT ALL b@.

56+-- is the same as the SQL statement @x 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 ( Expr )

28+import Rel8.Expr ( Expr( E ) )

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.stateQueryArr $ \_ t -> case t of

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

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

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

5353 where

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

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

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 = Opaleye.Join Opaleye.FullJoin on left'' right''

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

6464 where

6565 on = toPrimExpr $ condition (extract a) (extract 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

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

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

71− join' = Opaleye.aProduct join

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

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 tag a b

123+ pure $ EitherTable (E tag) a b

124124 where

125125 tag = boolExpr (litExpr IsLeft) (litExpr IsRight) (isThatTable t)

126126

src/Rel8/Query/Window.hsdeleted−26

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

1−module Rel8.Query.Window

2− ( window

3− )

4−where

5−

6−-- base

7−import Prelude ()

8−

9−-- opaleye

10−import qualified Opaleye.Window as Opaleye

11−

12−-- rel8

13−import Rel8.Query ( Query )

14−import Rel8.Query.Opaleye ( mapOpaleye )

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

16−

17−

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

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

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

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

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

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

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

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

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

src/Rel8/Schema/Context/Lower.hsnew file+19

@@ -0,0 +1,19 @@

1+{-# language DataKinds #-}

2+{-# language StandaloneKindSignatures #-}

3+{-# language TypeFamilyDependencies #-}

5+module Rel8.Schema.Context.Lower

6+ ( Lower

7+ )

8+where

10+-- base

11+import Data.Kind ( Type )

12+import Prelude ()

13+

14+-- rel8

15+import Rel8.Schema.Kind ( Context )

16+

17+

18+type Lower :: Context -> Type -> Type

19+type family Lower context = f | f -> context

src/Rel8/Schema/Context/Nullify.hs+44−38

@@ -16,26 +16,28 @@ where

1616

1717-- base

1818import Data.Bool ( bool )

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

2019import 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 ( Aggregate(..), zipOutputs )

28−import Rel8.Expr ( Expr )

27+import Rel8.Aggregate

28+ ( Aggregate( A, Aggregate )

29+ , foldInputs, mapInputs

30+ )

31+import Rel8.Expr ( Expr( E ) )

2932import Rel8.Expr.Bool ( boolExpr )

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

31−import Rel8.Expr.Opaleye ( fromPrimExpr )

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

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

33−import Rel8.Schema.Field ( Field )

3436import qualified Rel8.Schema.Kind as K

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

37+import Rel8.Schema.Name ( Name( N, Name ) )

3638import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ) )

37−import Rel8.Schema.Result ( Result )

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

39+import Rel8.Schema.Result ( Result( R ) )

40+import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )

3941

4042

4143type Nullifiability :: K.Context -> Type

@@ -64,8 +66,7 @@ instance Nullifiable Name where

6466

6567type NonNullifiability :: K.Context -> Type

6668data NonNullifiability context where

67− NField :: NonNullifiability (Field table)

68− NResult :: NonNullifiability Result

69+ NNResult :: NonNullifiability Result

6970

7071

7172nullifiableOrNot :: ()

@@ -74,9 +75,8 @@ nullifiableOrNot :: ()

7475nullifiableOrNot = \case

7576 SAggregate -> Right NAggregate

7677 SExpr -> Right NExpr

77− SField -> Left NField

7878 SName -> Right NName

79− SResult -> Left NResult

79+ SResult -> Left NNResult

8080

8181

8282absurd :: Nullifiability context -> NonNullifiability context -> a

@@ -88,42 +88,48 @@ absurd = \case

8888

8989guarder :: ()

9090 => SContext context

91− -> context tag

91+ -> context ('Spec tag)

9292 -> (tag -> Bool)

9393 -> (Expr tag -> Expr Bool)

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

94+ -> context ('Spec (Maybe a))

95+ -> 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

103111

104112

105113nullifier :: ()

106114 => Nullifiability context

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

115+ -> SSpec ('Spec a)

116+ -> context ('Spec a)

117+ -> 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

115122

116123

117124unnullifier :: ()

118125 => Nullifiability context

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

126+ -> SSpec ('Spec a)

127+ -> context ('Spec (Nullify a))

128+ -> 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

127133

128134

129135sguard :: Expr Bool -> Expr (Maybe a) -> Expr (Maybe a)

src/Rel8/Schema/Context/Virtual.hsnew file+70

@@ -0,0 +1,70 @@

1+{-# language EmptyCase #-}

2+{-# language DataKinds #-}

3+{-# language GADTs #-}

4+{-# language LambdaCase #-}

5+{-# language StandaloneKindSignatures #-}

6+{-# language TypeFamilies #-}

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.hsdeleted−50

@@ -1,50 +0,0 @@

1−{-# language DataKinds #-}

2−{-# language FlexibleContexts #-}

3−{-# language MultiParamTypeClasses #-}

4−{-# language StandaloneKindSignatures #-}

5−{-# language TypeFamilies #-}

6−

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

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

1616module Rel8.Schema.HTable

1717 ( HTable (HField, HConstrainTable)

1818 , hfield, htabulate, htraverse, hdicts, hspecs

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

19+ , hmap, htabulateA

2020 )

2121where

2222

2323-- base

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

2524import Data.Kind ( Constraint, Type )

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

2726import Data.Proxy ( Proxy )

@@ -33,21 +32,16 @@ import GHC.Generics

3332 )

3433import Prelude

3534

36−-- profunctors

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

38−

39−-- product-profunctors

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

41−

4235-- rel8

4336import Rel8.Schema.Dict ( Dict )

44−import Rel8.Schema.Spec ( Spec )

37+import Rel8.Schema.Spec ( Spec, SSpec )

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

4639import qualified Rel8.Schema.Kind as K

4740

4841-- semigroupoids

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

5043

44+

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

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

5347-- specified ('hspecs').

@@ -56,14 +50,14 @@ import Data.Functor.Apply ( Apply, (<.>) )

5650-- instances yourself or specify this constraint.

5751type HTable :: K.HTable -> Constraint

5852class HTable t where

59− type HField t = (field :: Type -> Type) | field -> t

60− type HConstrainTable t (c :: Type -> Constraint) :: Constraint

53+ type HField t = (field :: Spec -> Type) | field -> t

54+ type HConstrainTable t (c :: Spec -> Constraint) :: Constraint

6155

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)

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)

6559 hdicts :: HConstrainTable t c => t (Dict c)

66− hspecs :: t Spec

60+ hspecs :: t SSpec

6761

6862 type HField t = GHField t

6963 type HConstrainTable t c = HConstrainTable (GHColumns (Rep (t Proxy))) c

@@ -74,7 +68,7 @@ class HTable t where

7468 , HField (GHColumns (Rep (t Proxy))) ~ HField (GHColumns (Rep (t context)))

7569 , GHTable context (Rep (t context))

7670 )

77− => t context -> HField t a -> context a

71+ => t context -> HField t spec -> context spec

7872 hfield table (GHField field) = hfield (toGHColumns (from table)) field

7973

8074 default htabulate ::

@@ -83,7 +77,7 @@ class HTable t where

8377 , HField (GHColumns (Rep (t Proxy))) ~ HField (GHColumns (Rep (t context)))

8478 , GHTable context (Rep (t context))

8579 )

86− => (forall a. HField t a -> context a) -> t context

80+ => (forall spec. HField t spec -> context spec) -> t context

8781 htabulate f = to $ fromGHColumns $ htabulate (f . GHField)

8882

8983 default htraverse

@@ -93,7 +87,7 @@ class HTable t where

9387 , Generic (t g), GHTable g (Rep (t g))

9488 , GHColumns (Rep (t f)) ~ GHColumns (Rep (t g))

9589 )

96− => (forall a. f a -> m (g a)) -> t f -> m (t g)

90+ => (forall spec. f spec -> m (g spec)) -> t f -> m (t g)

9791 htraverse f = fmap (to . fromGHColumns) . htraverse f . toGHColumns . from

9892

9993 default hdicts

@@ -107,10 +101,10 @@ class HTable t where

107101 hdicts = to $ fromGHColumns (hdicts @(GHColumns (Rep (t Proxy))) @c)

108102

109103 default hspecs ::

110− ( Generic (t Spec)

111− , GHTable Spec (Rep (t Spec))

104+ ( Generic (t SSpec)

105+ , GHTable SSpec (Rep (t SSpec))

112106 )

113− => t Spec

107+ => t SSpec

114108 hspecs = to $ fromGHColumns hspecs

115109

116110 {-# INLINABLE hfield #-}

@@ -120,40 +114,19 @@ class HTable t where

120114 {-# INLINABLE hspecs #-}

121115

122116

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−

128117hmap :: HTable t

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

118+ => (forall spec. context spec -> context' spec) -> t context -> t context'

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

131120

132121

133122htabulateA :: (HTable t, Apply m)

134− => (forall a. HField t a -> m (context a)) -> m (t context)

123+ => (forall spec. HField t spec -> m (context spec)) -> m (t context)

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

136125{-# INLINABLE htabulateA #-}

137126

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)

154127

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

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

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

129+newtype GHField t spec = GHField (HField (GHColumns (Rep (t Proxy))) spec)

157130

158131

159132type GHTable :: K.Context -> (Type -> Type) -> Constraint

@@ -182,10 +155,10 @@ instance (GHTable context a, GHTable context b) => GHTable context (a :*: b) whe

182155

183156

184157-- | A HField type for indexing into HProduct.

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)

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)

189162

190163

191164instance (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 ( HIdentity )

18+import Rel8.Schema.HTable.Identity ( HType )

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" (HIdentity EitherTag) context

27+ { htag :: HLabel "isRight" (HType EitherTag) context

2828 , hleft :: HLabel "Left" (HNullify left) context

2929 , hright :: HLabel "Right" (HNullify right) context

3030 }

src/Rel8/Schema/HTable/Identity.hs+28−16

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

11{-# language DataKinds #-}

2−{-# language FlexibleContexts #-}

2+{-# language GADTs #-}

3+{-# language PatternSynonyms #-}

34{-# language StandaloneKindSignatures #-}

45{-# language TypeFamilies #-}

5−{-# language UndecidableInstances #-}

77module Rel8.Schema.HTable.Identity

8− ( HIdentity( HIdentity, unHIdentity )

8+ ( HIdentity( HIdentity, HType, unHIdentity )

9+ , HType

910 )

1011where

1112

1213-- base

1314import Data.Kind ( Type )

14−import Data.Type.Equality ( (:~:)( Refl ) )

1515import Prelude

1616

1717-- rel8

@@ -21,23 +21,35 @@ import Rel8.Schema.HTable

2121 , hfield, htabulate, htraverse, hdicts, hspecs

2222 )

2323import qualified Rel8.Schema.Kind as K

24−import Rel8.Schema.Null ( Sql )

25−import Rel8.Schema.Spec ( specification )

26−import Rel8.Type ( DBType )

24+import Rel8.Schema.Spec ( Spec( Spec ), KnownSpec, specSing )

2725

2826

29−type HIdentity :: Type -> K.HTable

30−newtype HIdentity a context = HIdentity

31− { unHIdentity :: context a

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

3239 }

3340

3441

35−instance Sql DBType a => HTable (HIdentity a) where

36− type HConstrainTable (HIdentity a) constraint = constraint a

37− type HField (HIdentity a) = (:~:) a

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

3850

39− hfield (HIdentity a) Refl = a

40− htabulate f = HIdentity $ f Refl

51+ hfield (HIdentity a) HIdentityField = a

52+ htabulate f = HIdentity $ f HIdentityField

4153 htraverse f (HIdentity a) = HIdentity <$> f a

4254 hdicts = HIdentity Dict

43− hspecs = HIdentity specification

55+ hspecs = HIdentity specSing

src/Rel8/Schema/HTable/Label.hs+4−15

@@ -1,5 +1,4 @@

11{-# language DataKinds #-}

2−{-# language RankNTypes #-}

32{-# language RecordWildCards #-}

43{-# language ScopedTypeVariables #-}

54{-# language StandaloneKindSignatures #-}

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

98module Rel8.Schema.HTable.Label

109 ( HLabel, hlabel, hrelabel, hunlabel

11− , hproject

1210 )

1311where

1412

@@ -20,19 +18,16 @@ import Prelude

2018

2119-- rel8

2220import Rel8.Schema.HTable

23− ( HTable, HConstrainTable, HField

24− , htabulate, hfield, htraverse, hdicts, hspecs

25− )

2621import qualified Rel8.Schema.Kind as K

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

22+import Rel8.Schema.Spec ( Spec, SSpec(..) )

2823

2924

3025type HLabel :: Symbol -> K.HTable -> K.HTable

3126newtype HLabel label table context = HLabel (table context)

3227

3328

34−type HLabelField :: Symbol -> K.HTable -> Type -> Type

35−newtype HLabelField label table a = HLabelField (HField table a)

29+type HLabelField :: Symbol -> K.HTable -> Spec -> Type

30+newtype HLabelField label table spec = HLabelField (HField table spec)

3631

3732

3833instance (HTable table, KnownSymbol label) => HTable (HLabel label table) where

@@ -45,7 +40,7 @@ instance (HTable table, KnownSymbol label) => HTable (HLabel label table) where

4540 htraverse f (HLabel a) = HLabel <$> htraverse f a

4641 hdicts = HLabel (hdicts @table)

4742 hspecs = HLabel $ htabulate $ \field -> case hfield (hspecs @table) field of

48− Spec {..} -> Spec {labels = symbolVal (Proxy @label) : labels, ..}

43+ SSpec {..} -> SSpec {labels = symbolVal (Proxy @label) : labels, ..}

4944 {-# INLINABLE hspecs #-}

5045

5146

@@ -62,9 +57,3 @@ hrelabel = hlabel . hunlabel

6257hunlabel :: forall label t context. HLabel label t context -> t context

6358hunlabel (HLabel a) = a

6459{-# 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+12−22

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

66{-# language GADTs #-}

77{-# language InstanceSigs #-}

88{-# language MultiParamTypeClasses #-}

9−{-# language RankNTypes #-}

9+{-# language PolyKinds #-}

1010{-# language ScopedTypeVariables #-}

1111{-# language StandaloneKindSignatures #-}

1212{-# language TypeApplications #-}

@@ -19,38 +19,34 @@ module Rel8.Schema.HTable.MapTable

1919 , MapSpec(..)

2020 , Precompose(..)

2121 , HMapTableField(..)

22− , hproject

2322 )

2423where

2524

2625-- base

2726import Data.Kind ( Constraint, Type )

28−import Prelude

27+import Prelude ( ($), (.), (<$>), fmap )

2928

3029-- rel8

31−import Rel8.FCF ( Exp, Eval )

30+import Rel8.FCF

3231import Rel8.Schema.HTable

33− ( HTable, HConstrainTable, HField

34− , hfield, htabulate, htraverse, hdicts, hspecs

35− )

36−import Rel8.Schema.Spec ( Spec )

32+import Rel8.Schema.Spec ( Spec, SSpec )

3733import qualified Rel8.Schema.Kind as K

3834import Rel8.Schema.Dict ( Dict( Dict ) )

3935

4036

41−type HMapTable :: (Type -> Exp Type) -> K.HTable -> K.HTable

42−newtype HMapTable f t context = HMapTable

43− { unHMapTable :: t (Precompose f context)

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)

4440 }

4541

4642

47−type Precompose :: (Type -> Exp Type) -> K.Context -> K.Context

43+type Precompose :: (a -> Exp b) -> (b -> Type) -> a -> Type

4844newtype Precompose f g x = Precompose

4945 { precomposed :: g (Eval (f x))

5046 }

5147

5248

53−type HMapTableField :: (Type -> Exp Type) -> K.HTable -> K.Context

49+type HMapTableField :: (Spec -> Exp a) -> K.HTable -> a -> Type

5450data HMapTableField f t x where

5551 HMapTableField :: HField t a -> HMapTableField f t (Eval (f a))

5652

@@ -83,17 +79,11 @@ instance (HTable t, MapSpec f) => HTable (HMapTable f t) where

8379 {-# INLINABLE hspecs #-}

8480

8581

86−type MapSpec :: (Type -> Exp Type) -> Constraint

82+type MapSpec :: (Spec -> Exp Spec) -> Constraint

8783class MapSpec f where

88− mapInfo :: Spec x -> Spec (Eval (f x))

84+ mapInfo :: SSpec x -> SSpec (Eval (f x))

8985

9086

91−type ComposeConstraint :: (Type -> Exp Type) -> (Type -> Constraint) -> Type -> Constraint

87+type ComposeConstraint :: (a -> Exp b) -> (b -> Constraint) -> a -> Constraint

9288class c (Eval (f a)) => ComposeConstraint f c a

9389instance 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 ( HIdentity )

18+import Rel8.Schema.HTable.Identity ( HType )

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" (HIdentity (Maybe MaybeTag)) context

27+ { htag :: HLabel "isJust" (HType (Maybe MaybeTag)) context

2828 , hjust :: HLabel "Just" (HNullify table) context

2929 }

3030 deriving stock Generic

src/Rel8/Schema/HTable/Nullify.hs+24−22

@@ -23,12 +23,10 @@ module Rel8.Schema.HTable.Nullify

2323 , hnulls

2424 , hnullify

2525 , hunnullify

26− , hproject

2726 )

2827where

2928

3029-- base

31−import Data.Kind ( Type )

3230import GHC.Generics ( Generic )

3331import Prelude hiding ( null )

3432

@@ -39,11 +37,10 @@ import Rel8.Schema.HTable.MapTable

3937 ( HMapTable, HMapTableField( HMapTableField )

4038 , MapSpec, mapInfo

4139 )

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

4340import qualified Rel8.Schema.Kind as K

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

4542import qualified Rel8.Schema.Null as Type ( Nullify )

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

43+import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )

4744

4845-- semigroupoids

4946import Data.Functor.Apply ( Apply )

@@ -55,14 +52,17 @@ newtype HNullify table context = HNullify (HMapTable Nullify table context)

5552 deriving anyclass HTable

5653

5754

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

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)

6161

6262

6363instance MapSpec Nullify where

6464 mapInfo = \case

65− Spec {nullity, ..} -> Spec

65+ SSpec {nullity, ..} -> SSpec

6666 { nullity = case nullity of

6767 Null -> Null

6868 NotNull -> Null

@@ -71,47 +71,49 @@ instance MapSpec Nullify where

7171

7272

7373hguard :: HTable t

74− => (forall a. context (Maybe a) -> context (Maybe a))

74+ => (forall a. context ('Spec (Maybe a)) -> context ('Spec (Maybe a)))

7575 -> HNullify t context -> HNullify t context

7676hguard guarder (HNullify as) = HNullify $ htabulate $ \(HMapTableField field) ->

7777 case hfield hspecs field of

78− Spec {nullity} -> case hfield as (HMapTableField field) of

78+ SSpec {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. Spec a -> context (Type.Nullify a))

85+ => (forall a. ()

86+ => SSpec ('Spec a)

87+ -> context ('Spec (Type.Nullify a)))

8688 -> HNullify t context

8789hnulls null = HNullify $ htabulate $ \(HMapTableField field) ->

8890 case hfield hspecs field of

89− spec@Spec {} -> null spec

91+ spec@SSpec {} -> null spec

9092{-# INLINABLE hnulls #-}

9193

9294

9395hnullify :: HTable t

94− => (forall a. Spec a -> context a -> context (Type.Nullify a))

96+ => (forall a. ()

97+ => SSpec ('Spec a)

98+ -> context ('Spec a)

99+ -> context ('Spec (Type.Nullify a)))

95100 -> t context

96101 -> HNullify t context

97102hnullify nullifier a = HNullify $ htabulate $ \(HMapTableField field) ->

98103 case hfield hspecs field of

99− spec@Spec {} -> nullifier spec (hfield a field)

104+ spec@SSpec {} -> nullifier spec (hfield a field)

100105{-# INLINABLE hnullify #-}

101106

102107

103108hunnullify :: (HTable t, Apply m)

104− => (forall a. Spec a -> context (Type.Nullify a) -> m (context a))

109+ => (forall a. ()

110+ => SSpec ('Spec a)

111+ -> context ('Spec (Type.Nullify a))

112+ -> m (context ('Spec a)))

105113 -> HNullify t context

106114 -> m (t context)

107115hunnullify unnullifier (HNullify as) =

108116 htabulateA $ \field -> case hfield hspecs field of

109− spec@Spec {} -> case hfield as (HMapTableField field) of

117+ spec@SSpec {} -> case hfield as (HMapTableField field) of

110118 a -> unnullifier spec a

111119{-# 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 ( HIdentity )

18+import Rel8.Schema.HTable.Identity ( HType )

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" (HIdentity (Maybe MaybeTag)) context

27+ { hhereTag :: HLabel "hereTag" (HType (Maybe MaybeTag)) context

2828 , hhere :: HLabel "Here" (HNullify here) context

29− , hthereTag :: HLabel "thereTag" (HIdentity (Maybe MaybeTag)) context

29+ , hthereTag :: HLabel "thereTag" (HType (Maybe MaybeTag)) context

3030 , hthere :: HLabel "There" (HNullify there) context

3131 }

3232 deriving stock Generic

src/Rel8/Schema/HTable/Vectorize.hs+40−39

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

99{-# language GADTs #-}

1010{-# language LambdaCase #-}

1111{-# language MultiParamTypeClasses #-}

12+{-# language NamedFieldPuns #-}

1213{-# language RankNTypes #-}

1314{-# language RecordWildCards #-}

1415{-# language ScopedTypeVariables #-}

@@ -21,39 +22,33 @@ module Rel8.Schema.HTable.Vectorize

2122 ( HVectorize

2223 , hvectorize, hunvectorize

2324 , happend, hempty

24− , hproject

25− , hcolumn

2625 )

2726where

2827

2928-- base

30−import Data.Kind ( Constraint, Type )

29+import Data.Kind ( Type )

3130import Data.List.NonEmpty ( NonEmpty )

32−import GHC.Generics (Generic)

3331import Prelude

3432

3533-- rel8

36−import Rel8.FCF ( Eval, Exp )

3734import Rel8.Schema.Dict ( Dict( Dict ) )

3835import qualified Rel8.Schema.Kind as K

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 )

36+import Rel8.Schema.HTable

37+ ( HTable

38+ , hfield, htabulate, htabulateA, hspecs

4539 )

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

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

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

41+import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )

4942import Rel8.Type.Array ( listTypeInformation, nonEmptyTypeInformation )

5043import Rel8.Type.Information ( TypeInformation )

5144

5245-- semialign

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

47+import Rel8.FCF

48+import Rel8.Schema.HTable.MapTable

49+import GHC.Generics (Generic)

5450

5551

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

5752class Vector list where

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

5954 vectorTypeInformation :: ()

@@ -78,16 +73,16 @@ newtype HVectorize list table context = HVectorize (HMapTable (Vectorize list) t

7873 deriving anyclass HTable

7974

8075

81−data Vectorize :: (Type -> Type) -> Type -> Exp Type

76+data Vectorize :: (Type -> Type) -> Spec -> Exp Spec

8277

8378

84−type instance Eval (Vectorize list a) = list a

79+type instance Eval (Vectorize list ('Spec a)) = 'Spec (list a)

8580

8681

8782instance Vector list => MapSpec (Vectorize list) where

8883 mapInfo = \case

89− Spec {..} -> case listNotNull @list nullity of

90− Dict -> Spec

84+ SSpec {..} -> case listNotNull @list nullity of

85+ Dict -> SSpec

9186 { nullity = NotNull

9287 , info = vectorTypeInformation nullity info

9388 , ..

@@ -95,49 +90,55 @@ instance Vector list => MapSpec (Vectorize list) where

9590

9691

9792hvectorize :: (HTable t, Unzip f, Vector list)

98− => (forall a. Spec a -> f (context a) -> context' (list a))

93+ => (forall a. ()

94+ => SSpec ('Spec a)

95+ -> f (context ('Spec a))

96+ -> context' ('Spec (list a)))

9997 -> f (t context)

10098 -> HVectorize list t context'

10199hvectorize vectorizer as = HVectorize $ htabulate $ \(HMapTableField field) ->

102100 case hfield hspecs field of

103− spec -> vectorizer spec (fmap (`hfield` field) as)

101+ spec@SSpec {} -> vectorizer spec (fmap (`hfield` field) as)

104102{-# INLINABLE hvectorize #-}

105103

106104

107105hunvectorize :: (HTable t, Zip f, Vector list)

108− => (forall a. Spec a -> context (list a) -> f (context' a))

106+ => (forall a. ()

107+ => SSpec ('Spec a)

108+ -> context ('Spec (list a))

109+ -> f (context' ('Spec a)))

109110 -> HVectorize list t context

110111 -> f (t context')

111112hunvectorize unvectorizer (HVectorize table) =

112113 getZippy $ htabulateA $ \field -> case hfield hspecs field of

113− spec -> case hfield table (HMapTableField field) of

114+ spec@SSpec{} -> case hfield table (HMapTableField field) of

114115 a -> Zippy (unvectorizer spec a)

115116{-# INLINABLE hunvectorize #-}

116117

117118

118−happend :: (HTable t, Vector list)

119− => (forall a. Spec a -> context (list a) -> context (list a) -> context (list a))

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

120127 -> HVectorize list t context

121128 -> HVectorize list t context

122129 -> HVectorize list t context

123130happend append (HVectorize as) (HVectorize bs) = HVectorize $

124131 htabulate $ \field@(HMapTableField j) -> case (hfield as field, hfield bs field) of

125132 (a, b) -> case hfield hspecs j of

126− spec -> append spec a b

133+ SSpec {nullity, info} -> append nullity info a b

127134

128135

129−hempty :: HTable t

130− => (forall a. Spec a -> context [a])

136+hempty :: HTable t =>

137+ ( forall a. ()

138+ => Nullity a

139+ -> TypeInformation (Unnullify a)

140+ -> context ('Spec [a])

141+ )

131142 -> HVectorize [] t context

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

143+hempty empty = HVectorize $ htabulate $ \(HMapTableField field) -> case hfield hspecs field of

144+ SSpec {nullity, info} -> empty nullity info

src/Rel8/Schema/Kind.hs+5−7

@@ -1,19 +1,17 @@

11{-# language StandaloneKindSignatures #-}

3−module Rel8.Schema.Kind

4− ( Rel8able

5− , Context

6− , HTable

7− )

8−where

3+module Rel8.Schema.Kind ( Rel8able, Context, HTable ) where

105-- base

116import Data.Kind ( Type )

127import Prelude ()

138

9+-- rel8

10+import Rel8.Schema.Spec ( Spec )

11+

1412

1513type Context :: Type

16−type Context = Type -> Type

14+type Context = Spec -> Type

1715

1816

1917type HTable :: Type

src/Rel8/Schema/Name.hs+27−27

@@ -3,9 +3,10 @@

33{-# language FlexibleContexts #-}

44{-# language FlexibleInstances #-}

55{-# language GADTs #-}

6−{-# language GeneralizedNewtypeDeriving #-}

76{-# language MultiParamTypeClasses #-}

7+{-# language PolyKinds #-}

88{-# language RankNTypes #-}

9+{-# language StandaloneDeriving #-}

910{-# language StandaloneKindSignatures #-}

1011{-# language TypeFamilies #-}

1112{-# language UndecidableInstances #-}

@@ -13,28 +14,21 @@

1314module Rel8.Schema.Name

1415 ( Name(..)

1516 , Selects

16− , ppColumn

1717 )

1818where

1919

2020-- base

21−import Data.Functor.Identity ( Identity( Identity ) )

2221import Data.Kind ( Constraint, Type )

23−import Data.String ( IsString )

22+import Data.String ( IsString, fromString )

2423import Prelude

2524

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−

3325-- rel8

3426import Rel8.Expr ( Expr )

35−import qualified Rel8.Schema.Kind as K

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

27+import Rel8.Schema.Context.Lower ( Lower )

28+import Rel8.Schema.HTable.Identity ( HIdentity( HType ), HType )

3729import Rel8.Schema.Null ( Sql )

30+import Rel8.Schema.Result ( Result( R ) )

31+import Rel8.Schema.Spec ( Spec( Spec ) )

3832import Rel8.Table

3933 ( Table, Columns, Context, fromColumns, toColumns

4034 , FromExprs, fromResult, toResult

@@ -48,22 +42,32 @@ import Rel8.Type ( DBType )

4842-- schema definition. You can construct names by using the @OverloadedStrings@

4943-- extension and writing string literals. This is typically done when providing

5044-- a 'TableSchema' value.

51−type Name :: K.Context

52−newtype Name a = Name String

53− deriving stock Show

54− deriving newtype IsString

45+type Name :: k -> Type

46+data Name a where

47+ Name :: forall (a :: Type). !String -> Name a

48+ N :: { unN :: !(Name a) } -> Name ('Spec a)

49+

50+

51+type instance Lower Name = Name

52+

53+

54+deriving stock instance Show (Name a)

55+

56+

57+instance k ~ Type => IsString (Name (a :: k)) where

58+ fromString = Name

5559

5660

5761instance Sql DBType a => Table Name (Name a) where

58− type Columns (Name a) = HIdentity a

62+ type Columns (Name a) = HType a

5963 type Context (Name a) = Name

6064 type FromExprs (Name a) = a

61− type Transpose to (Name a) = to a

65+ type Transpose to (Name a) = Lower to a

6266

63− toColumns a = HIdentity a

64− fromColumns (HIdentity a) = a

65− toResult a = HIdentity (Identity a)

66− fromResult (HIdentity (Identity a)) = a

67+ toColumns a = HType (N a)

68+ fromColumns (HType (N a)) = a

69+ toResult a = HType (R a)

70+ fromResult (HType (R a)) = a

6771

6872

6973-- | @Selects a b@ means that @a@ is a schema (i.e., a 'Table' of 'Name's) for

@@ -71,7 +75,3 @@ instance Sql DBType a => Table Name (Name a) where

7175type Selects :: Type -> Type -> Constraint

7276class Transposes Name Expr names exprs => Selects names exprs

7377instance 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+33−16

@@ -5,20 +5,21 @@

55{-# language TypeFamilies #-}

77module Rel8.Schema.Result

8− ( Result

8+ ( Result( R, unR )

99 , null, nullifier, unnullifier

1010 , vectorizer, unvectorizer

1111 )

1212where

1313

1414-- base

15−import Data.Functor.Identity ( Identity( Identity), runIdentity )

15+import Data.Functor.Identity ( Identity )

1616import Prelude hiding ( null )

1717

1818-- rel8

19+import Rel8.Schema.Context.Lower ( Lower )

1920import Rel8.Schema.Kind ( Context )

2021import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ) )

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

22+import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )

2223

2324

2425-- | The @Result@ context is the context used for decoded query results.

@@ -26,29 +27,45 @@ import Rel8.Schema.Spec ( Spec(..) )

2627-- When a query is executed against a PostgreSQL database, Rel8 parses the

2728-- returned rows, decoding each row into the @Result@ context.

2829type Result :: Context

29−type Result = Identity

30+data Result a where

31+ R :: { unR :: !a } -> Result ('Spec a)

3032

3133

32−null :: Result (Maybe a)

33−null = Identity Nothing

34+type instance Lower Result = Identity

3435

3536

36−nullifier :: Spec a -> Result a -> Result (Nullify a)

37−nullifier Spec {nullity} (Identity a) = Identity $ case nullity of

37+null :: Result ('Spec (Maybe a))

38+null = R Nothing

39+

40+

41+nullifier :: ()

42+ => SSpec ('Spec a)

43+ -> Result ('Spec a)

44+ -> Result ('Spec (Nullify a))

45+nullifier SSpec {nullity} (R a) = R $ case nullity of

3846 Null -> a

3947 NotNull -> Just a

4048

4149

42−unnullifier :: Spec a -> Result (Nullify a) -> Maybe (Result a)

43−unnullifier Spec {nullity} (Identity a) =

50+unnullifier :: ()

51+ => SSpec ('Spec a)

52+ -> Result ('Spec (Nullify a))

53+ -> Maybe (Result ('Spec a))

54+unnullifier SSpec {nullity} (R a) =

4455 case nullity of

45− Null -> pure $ Identity a

46− NotNull -> Identity <$> a

56+ Null -> pure $ R a

57+ NotNull -> R <$> a

4758

4859

49−vectorizer :: Functor f => Spec a -> f (Result a) -> Result (f a)

50−vectorizer _ = Identity . fmap runIdentity

60+vectorizer :: Functor f

61+ => SSpec ('Spec a)

62+ -> f (Result ('Spec a))

63+ -> Result ('Spec (f a))

64+vectorizer _ = R . fmap unR

5165

5266

53−unvectorizer :: Functor f => Spec a -> Result (f a) -> f (Result a)

54−unvectorizer _ (Identity results) = Identity <$> results

67+unvectorizer :: Functor f

68+ => SSpec ('Spec a)

69+ -> Result ('Spec (f a))

70+ -> f (Result ('Spec a))

71+unvectorizer _ (R results) = R <$> results

src/Rel8/Schema/Spec.hs+30−16

@@ -1,15 +1,18 @@

1+{-# language DataKinds #-}

12{-# language FlexibleContexts #-}

2−{-# language MonoLocalBinds #-}

3+{-# language GADTs #-}

34{-# language StandaloneKindSignatures #-}

5+{-# language UndecidableInstances #-}

57module Rel8.Schema.Spec

6− ( Spec( Spec, labels, info, nullity )

7− , specification

8+ ( Spec( Spec )

9+ , SSpec( SSpec, labels, info, nullity )

10+ , KnownSpec( specSing )

811 )

912where

1013

1114-- base

12−import Data.Kind ( Type )

15+import Data.Kind ( Constraint, Type )

1316import Prelude

1417

1518-- rel8

@@ -18,17 +21,28 @@ import Rel8.Type ( DBType, typeInformation )

1821import Rel8.Type.Information ( TypeInformation )

1922

2023

21−type Spec :: Type -> Type

22−data Spec a = Spec

23− { labels :: [String]

24− , info :: TypeInformation (Unnullify a)

25− , nullity :: Nullity a

26− }

24+type Spec :: Type

25+newtype Spec = Spec Type

2726

2827

29−specification :: Sql DBType a => Spec a

30−specification = Spec

31− { labels = []

32− , info = typeInformation

33− , nullity = nullable

34− }

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

src/Rel8/Schema/Spec/Constrain.hsnew file+32

@@ -0,0 +1,32 @@

1+{-# language ConstraintKinds #-}

2+{-# language DataKinds #-}

3+{-# language FlexibleInstances #-}

4+{-# language MultiParamTypeClasses #-}

5+{-# language StandaloneKindSignatures #-}

6+{-# language TypeFamilies #-}

7+{-# language UndecidableInstances #-}

8+{-# language UndecidableSuperClasses #-}

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,26 +1,14 @@

11{-# language DeriveFunctor #-}

22{-# language DerivingStrategies #-}

3−{-# language DisambiguateRecordFields #-}

4−{-# language NamedFieldPuns #-}

5−{-# language StandaloneKindSignatures #-}

74module Rel8.Schema.Table

85 ( TableSchema(..)

9− , ppTable

106 )

117where

128

139-- base

14−import Data.Kind ( Type )

1510import Prelude

1611

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−

2412

2513-- | The schema for a table. This is used to specify the name and schema that a

2614-- table belongs to (the @FROM@ part of a SQL query), along with the schema of

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

2816--

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

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

31−type TableSchema :: Type -> Type

3219data TableSchema names = TableSchema

3320 { name :: String

3421 -- ^ The name of the table.

@@ -40,10 +27,3 @@ data TableSchema names = TableSchema

4027 -- data type here, parameterized by the 'Rel8.ColumnSchema.ColumnSchema' functor.

4128 }

4229 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+48−35

@@ -1,37 +1,40 @@

11{-# language DuplicateRecordFields #-}

22{-# language GADTs #-}

33{-# language NamedFieldPuns #-}

4−{-# language RankNTypes #-}

5−{-# language RecordWildCards #-}

4+{-# language ScopedTypeVariables #-}

65{-# language StandaloneKindSignatures #-}

7−{-# language StrictData #-}

6+{-# language TypeApplications #-}

98module Rel8.Statement.Delete

109 ( Delete(..)

1110 , delete

12− , ppDelete

1311 )

1412where

1513

1614-- base

15+import Control.Exception ( throwIO )

1716import Data.Kind ( Type )

1817import Prelude

1918

2019-- hasql

20+import Hasql.Connection ( Connection )

21+import qualified Hasql.Decoders as Hasql

2122import qualified Hasql.Encoders as Hasql

23+import qualified Hasql.Session as Hasql

2224import qualified Hasql.Statement as Hasql

2325

24−-- pretty

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

26+-- opaleye

27+import qualified Opaleye.Internal.Manipulation as Opaleye

2628

2729-- rel8

2830import Rel8.Expr ( Expr )

29−import Rel8.Query ( Query )

31+import Rel8.Expr.Opaleye ( toColumn, toPrimExpr )

3032import Rel8.Schema.Name ( Selects )

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 )

33+import Rel8.Schema.Table ( TableSchema )

34+import Rel8.Statement.Returning ( Returning( NumberOfRowsAffected, Projection ) )

35+import Rel8.Table.Cols ( fromCols, toCols )

36+import Rel8.Table.Opaleye ( castTable, table, unpackspec )

37+import Rel8.Table.Serialize ( Serializable, parse )

3538

3639-- text

3740import qualified Data.Text as Text

@@ -44,10 +47,7 @@ data Delete a where

4447 Delete :: Selects names exprs =>

4548 { from :: TableSchema names

4649 -- ^ Which table to delete from.

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

50+ , deleteWhere :: 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,25 +55,38 @@ data Delete a where

5555 -> Delete a

5656

5757

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

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 $ toCols <$> from

73+ where' = toColumn . toPrimExpr . deleteWhere . fromCols

6874

69−

70−-- | Run a 'Delete' statement.

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

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

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 $ toCols <$> from

87+ where' = toColumn . toPrimExpr . deleteWhere . fromCols

88+ project' = castTable . toCols . project . fromCols

7389 where

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

90+ decoder :: forall exprs projection a. Serializable projection a

91+ => (exprs -> projection) -> Hasql.Result [a]

92+ decoder _ = Hasql.rowList (parse @projection @a)

src/Rel8/Statement/Insert.hs+72−43

@@ -1,59 +1,64 @@

11{-# language DuplicateRecordFields #-}

2−{-# language FlexibleContexts #-}

32{-# language GADTs #-}

43{-# language NamedFieldPuns #-}

5−{-# language RecordWildCards #-}

4+{-# language ScopedTypeVariables #-}

65{-# language StandaloneKindSignatures #-}

7−{-# language StrictData #-}

6+{-# language TypeApplications #-}

98module Rel8.Statement.Insert

109 ( Insert(..)

10+ , OnConflict(..)

1111 , insert

12− , ppInsert

13− , ppInto

1412 )

1513where

1614

1715-- base

18−import Data.Foldable ( toList )

16+import Control.Exception ( throwIO )

17+import Data.List.NonEmpty ( NonEmpty( (:|) ) )

1918import Data.Kind ( Type )

2019import Prelude

2120

2221-- hasql

22+import Hasql.Connection ( Connection )

23+import qualified Hasql.Decoders as Hasql

2324import qualified Hasql.Encoders as Hasql

25+import qualified Hasql.Session as Hasql

2426import qualified Hasql.Statement as Hasql

2527

2628-- opaleye

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

28−

29−-- pretty

30−import Text.PrettyPrint ( Doc, (<+>), ($$), parens, text )

29+import qualified Opaleye.Internal.Manipulation as Opaleye

30+import qualified Opaleye.Manipulation as Opaleye

3131

3232-- rel8

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 )

33+import Rel8.Schema.Name ( Selects )

34+import Rel8.Schema.Table ( TableSchema )

35+import Rel8.Statement.Returning ( Returning( Projection, NumberOfRowsAffected ) )

36+import Rel8.Table.Cols ( fromCols, toCols )

37+import Rel8.Table.Opaleye ( castTable, table, unpackspec )

38+import Rel8.Table.Serialize ( Serializable, parse )

4139

4240-- text

4341import qualified Data.Text as Text ( pack )

4442import Data.Text.Encoding ( encodeUtf8 )

4543

4644

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+

4753-- | The constituent parts of a SQL @INSERT@ statement.

4854type Insert :: Type -> Type

4955data Insert a where

5056 Insert :: Selects names exprs =>

5157 { into :: TableSchema names

5258 -- ^ Which table to insert into.

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

59+ , rows :: [exprs]

60+ -- ^ The rows to insert.

61+ , onConflict :: OnConflict

5762 -- ^ What to do if the inserted rows conflict with data already in the

5863 -- table.

5964 , returning :: Returning names a

@@ -62,28 +67,52 @@ data Insert a where

6267 -> Insert a

6368

6469

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

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 []

7276

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 $ toCols <$> into

88+ rows' = toCols <$> x :| xs

7389

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

75−ppInto table@TableSchema {columns} =

76− ppTable table <+>

77− parens (Opaleye.commaV ppColumn (toList (showNames columns)))

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 $ toCols <$> into

107+ rows' = toCols <$> x :| xs

108+ project' = castTable . toCols . project . fromCols

78109

79−

80−-- | Run an 'Insert' statement.

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

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

83110 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

111+ onConflict' =

112+ case onConflict of

113+ DoNothing -> Just Opaleye.DoNothing

114+ Abort -> Nothing

115+

116+ decoder :: forall exprs projection a. Serializable projection a

117+ => (exprs -> projection) -> Hasql.Result [a]

118+ decoder _ = Hasql.rowList (parse @projection @a)

src/Rel8/Statement/OnConflict.hsdeleted−106

@@ -1,106 +0,0 @@

1−{-# language DuplicateRecordFields #-}

2−{-# language FlexibleContexts #-}

3−{-# language GADTs #-}

4−{-# language LambdaCase #-}

5−{-# language NamedFieldPuns #-}

6−{-# language RecordWildCards #-}

7−{-# language StandaloneKindSignatures #-}

8−{-# language StrictData #-}

9−

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+10−114

@@ -1,133 +1,29 @@

11{-# language GADTs #-}

2−{-# language LambdaCase #-}

3−{-# language NamedFieldPuns #-}

4−{-# language RankNTypes #-}

5−{-# language ScopedTypeVariables #-}

62{-# language StandaloneKindSignatures #-}

7−{-# language StrictData #-}

8−{-# language TypeApplications #-}

104module Rel8.Statement.Returning

11− ( Returning( NumberOfRowsAffected, Projection )

12− , decodeReturning

13− , ppReturning

5+ ( Returning(..)

146 )

157where

168

179-- base

18−import Control.Applicative ( liftA2 )

19−import Data.Foldable ( toList )

2010import Data.Int ( Int64 )

2111import Data.Kind ( Type )

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 )

12+import Prelude ()

3513

3614-- rel8

3715import Rel8.Schema.Name ( Selects )

38−import Rel8.Schema.Table ( TableSchema(..) )

39−import Rel8.Table.Opaleye ( castTable, exprs, view )

40−import Rel8.Table.Serialize ( Serializable, parse )

16+import Rel8.Table.Serialize ( Serializable )

4117

42−-- semigropuoids

43−import Data.Functor.Apply ( Apply, (<.>) )

4418

45−

46−-- | 'Rel8.Insert', 'Rel8.Update' and 'Rel8.Delete' all support returning either

47−-- the number of rows affected, or the actual rows modified.

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

4824type Returning :: Type -> Type -> Type

4925data 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.

5426 NumberOfRowsAffected :: Returning names Int64

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)

27+ Projection :: (Selects names exprs, Serializable projection a)

28+ => (exprs -> projection)

6229 -> 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.hsdeleted−29

@@ -1,29 +0,0 @@

1−module Rel8.Statement.SQL

2− ( showDelete

3− , showInsert

4− , showUpdate

5− )

6−where

7−

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+35−120

@@ -1,147 +1,62 @@

1−{-# language DeriveTraversable #-}

2−{-# language DerivingStrategies #-}

3−{-# language FlexibleContexts #-}

41{-# language MonoLocalBinds #-}

52{-# language ScopedTypeVariables #-}

6−{-# language StandaloneKindSignatures #-}

73{-# language TypeApplications #-}

95module Rel8.Statement.Select

106 ( select

11− , ppSelect

12−

13− , Optimized(..)

14− , ppPrimSelect

15− , ppRows

7+ , selectWithNames

168 )

179where

1810

1911-- base

20−import Data.Foldable ( toList )

21−import Data.Kind ( Type )

22−import Data.Void ( Void )

23−import Prelude hiding ( undefined )

12+import Control.Exception ( throwIO )

13+import Prelude

2414

2515-- hasql

16+import Hasql.Connection ( Connection )

2617import qualified Hasql.Decoders as Hasql

2718import qualified Hasql.Encoders as Hasql

19+import qualified Hasql.Session as Hasql

2820import qualified Hasql.Statement as Hasql

2921

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−

4422-- rel8

45−import Rel8.Expr ( Expr )

46−import Rel8.Expr.Bool ( false )

47−import Rel8.Expr.Opaleye ( toPrimExpr )

4823import Rel8.Query ( Query )

49−import Rel8.Query.Opaleye ( toOpaleye )

24+import Rel8.Query.SQL ( sqlForQuery, sqlForQueryWithNames )

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

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

57−import Rel8.Table.Undefined ( undefined )

5827

5928-- text

6029import qualified Data.Text as Text

6130import Data.Text.Encoding ( encodeUtf8 )

6231

6332

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

33+-- | Run a @SELECT@ query, returning all rows.

6534select :: forall exprs a. Serializable exprs a

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

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

src/Rel8/Statement/Set.hsdeleted−33

@@ -1,33 +0,0 @@

1−{-# language MonoLocalBinds #-}

2−{-# language NamedFieldPuns #-}

3−

4−module Rel8.Statement.Set

5− ( ppSet

6− )

7−where

8−

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+56−38

@@ -1,37 +1,39 @@

1−{-# language DuplicateRecordFields #-}

21{-# language GADTs #-}

32{-# language NamedFieldPuns #-}

4−{-# language RecordWildCards #-}

3+{-# language ScopedTypeVariables #-}

54{-# language StandaloneKindSignatures #-}

6−{-# language StrictData #-}

5+{-# language TypeApplications #-}

87module Rel8.Statement.Update

98 ( Update(..)

109 , update

11− , ppUpdate

1210 )

1311where

1412

1513-- base

14+import Control.Exception ( throwIO )

1615import Data.Kind ( Type )

1716import Prelude

1817

1918-- hasql

19+import Hasql.Connection ( Connection )

20+import qualified Hasql.Decoders as Hasql

2021import qualified Hasql.Encoders as Hasql

22+import qualified Hasql.Session as Hasql

2123import qualified Hasql.Statement as Hasql

2224

23−-- pretty

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

25+-- opaleye

26+import qualified Opaleye.Internal.Manipulation as Opaleye

2527

2628-- rel8

2729import Rel8.Expr ( Expr )

28−import Rel8.Query ( Query )

30+import Rel8.Expr.Opaleye ( toColumn, toPrimExpr )

2931import Rel8.Schema.Name ( Selects )

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 )

32+import Rel8.Schema.Table ( TableSchema )

33+import Rel8.Statement.Returning ( Returning( Projection, NumberOfRowsAffected ) )

34+import Rel8.Table.Cols ( fromCols, toCols )

35+import Rel8.Table.Opaleye ( castTable, table, unpackspec )

36+import Rel8.Table.Serialize ( Serializable, parse )

3537

3638-- text

3739import qualified Data.Text as Text

@@ -44,12 +46,9 @@ data Update a where

4446 Update :: Selects names exprs =>

4547 { target :: TableSchema names

4648 -- ^ Which table to update.

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

49+ , set :: exprs -> exprs

5150 -- ^ How to update each selected row.

52− , updateWhere :: from -> exprs -> Expr Bool

51+ , updateWhere :: exprs -> Expr Bool

5352 -- ^ Which rows to select for update.

5453 , returning :: Returning names a

5554 -- ^ What to return from the @UPDATE@ statement.

@@ -57,27 +56,46 @@ data Update a where

5756 -> Update a

5857

5958

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

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 $ toCols <$> target

74+ set' = toCols . set . fromCols

75+ where' = toColumn . toPrimExpr . updateWhere . fromCols

7276

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 $ toCols <$> target

94+ set' = toCols . set . fromCols

95+ where' = toColumn . toPrimExpr . updateWhere . fromCols

96+ project' = castTable . toCols . project . fromCols

7397

74−-- | Run an @UPDATE@ statement.

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

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

7798 where

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

99+ decoder :: forall exprs projection a. Serializable projection a

100+ => (exprs -> projection) -> Hasql.Result [a]

101+ decoder _ = Hasql.rowList (parse @projection @a)

src/Rel8/Statement/Using.hsdeleted−36

@@ -1,36 +0,0 @@

1−module Rel8.Statement.Using

2− ( ppFrom

3− , ppUsing

4− )

5−where

6−

7−-- base

8−import Prelude

9−

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+28−43

@@ -3,76 +3,61 @@

44module Rel8.Statement.View

55 ( createView

6− , createOrReplaceView

76 )

87where

109-- base

10+import Control.Exception ( throwIO )

11+import Control.Monad ( (>=>) )

12+import Data.Foldable ( fold )

13+import Data.Maybe ( fromMaybe )

1114import Prelude

1215

1316-- hasql

17+import Hasql.Connection ( Connection )

1418import qualified Hasql.Decoders as Hasql

1519import qualified Hasql.Encoders as Hasql

20+import qualified Hasql.Session as Hasql

1621import qualified Hasql.Statement as Hasql

1722

1823-- rel8

1924import Rel8.Query ( Query )

25+import Rel8.Query.SQL ( sqlForQueryWithNames )

2026import Rel8.Schema.Name ( Selects )

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 )

27+import Rel8.Schema.Table ( TableSchema( TableSchema ) )

28+import Rel8.Table.Alternative ( emptyTable )

2729

2830-- text

2931import qualified Data.Text as Text

3032import Data.Text.Encoding ( encodeUtf8 )

3133

3234

33−data CreateView = Create | CreateOrReplace

34−

35−

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

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

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

3938createView :: Selects names exprs

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

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

40+createView (TableSchema name mschema names) query =

41+ Hasql.run session >=> either throwIO pure

6042 where

43+ session = Hasql.statement () statement

44+ statement = Hasql.Statement bytes params decode prepare

6145 bytes = encodeUtf8 (Text.pack sql)

6246 params = Hasql.noParams

6347 decode = Hasql.noResult

6448 prepare = False

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

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 <> "\""

7661 where

77− createOrReplace Create = text "CREATE VIEW"

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

62+ go '"' = "\"\""

63+ go c = [c]

src/Rel8/Statement/Where.hsdeleted−31

@@ -1,31 +0,0 @@

1−{-# language MonoLocalBinds #-}

2−

3−module Rel8.Statement.Where

4− ( ppWhere

5− )

6−where

7−

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+37−36

@@ -17,31 +17,28 @@ module Rel8.Table

1717 , Transpose

1818 )

1919 , Congruent

20− , TTable, TColumns, TContext, TFromExprs, TTranspose

21− , TSerialize

20+ , TTable, TColumns, TContext, TFromExprs

2221 )

2322where

2423

2524-- base

26−import Data.Functor.Identity ( Identity( Identity ) )

2725import Data.Kind ( Constraint, Type )

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

2927import Prelude hiding ( null )

3028

3129-- rel8

3230import Rel8.FCF ( Eval, Exp )

33−import Rel8.Generic.Map ( Map )

31+import Rel8.Generic.Map ( GMap, Map )

3432import Rel8.Generic.Table.Record

35− ( GTable, GColumns, GContext, gfromColumns, gtoColumns

36− , GSerialize, gfromResult, gtoResult

33+ ( GTable, GColumns, GContext

34+ , gfromColumns, gtoColumns, gfromResult, gtoResult

3735 )

3836import Rel8.Generic.Record ( Record(..) )

3937import Rel8.Schema.HTable ( HTable )

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

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

4139import qualified Rel8.Schema.Kind as K

42−import Rel8.Schema.Null ( Sql )

4340import Rel8.Schema.Result ( Result )

44−import Rel8.Type ( DBType )

41+import Rel8.Schema.Spec ( KnownSpec )

4542

4643

4744-- | @Table@s are one of the foundational elements of Rel8, and describe data

@@ -89,71 +86,69 @@ class

8986

9087 default toColumns ::

9188 ( Generic (Record a)

92− , GTable (TTable context) TColumns (Rep (Record a))

89+ , GTable (TTable context) TColumns TFromExprs (Rep (Record a))

9390 , Columns a ~ GColumns TColumns (Rep (Record a))

9491 )

9592 => a -> Columns a context

9693 toColumns =

97− gtoColumns @(TTable context) @TColumns toColumns .

94+ gtoColumns

95+ @(TTable context)

96+ @TColumns

97+ @TFromExprs

98+ toColumns .

9899 from .

99100 Record

100101

101102 default fromColumns ::

102103 ( Generic (Record a)

103− , GTable (TTable context) TColumns (Rep (Record a))

104+ , GTable (TTable context) TColumns TFromExprs (Rep (Record a))

104105 , Columns a ~ GColumns TColumns (Rep (Record a))

105106 )

106107 => Columns a context -> a

107108 fromColumns =

108109 unrecord .

109110 to .

110− gfromColumns @(TTable context) @TColumns fromColumns

111+ gfromColumns

112+ @(TTable context)

113+ @TColumns

114+ @TFromExprs

115+ fromColumns

111116

112117 default toResult ::

113118 ( Generic (Record (FromExprs a))

114− , GSerialize TSerialize TColumns (Rep (Record a)) (Rep (Record (FromExprs a)))

119+ , GTable (TTable context) TColumns TFromExprs (Rep (Record a))

115120 , Columns a ~ GColumns TColumns (Rep (Record a))

121+ , Rep (Record (FromExprs a)) ~ GMap TFromExprs (Rep (Record a))

116122 )

117123 => FromExprs a -> Columns a Result

118124 toResult =

119125 gtoResult

120− @TSerialize

126+ @(TTable context)

121127 @TColumns

128+ @TFromExprs

122129 @(Rep (Record a))

123− @(Rep (Record (FromExprs a)))

124130 (\(_ :: proxy x) -> toResult @(Context x) @x) .

125131 from .

126132 Record

127133

128134 default fromResult ::

129135 ( Generic (Record (FromExprs a))

130− , GSerialize TSerialize TColumns (Rep (Record a)) (Rep (Record (FromExprs a)))

136+ , GTable (TTable context) TColumns TFromExprs (Rep (Record a))

131137 , Columns a ~ GColumns TColumns (Rep (Record a))

138+ , Rep (Record (FromExprs a)) ~ GMap TFromExprs (Rep (Record a))

132139 )

133140 => Columns a Result -> FromExprs a

134141 fromResult =

135142 unrecord .

136143 to .

137144 gfromResult

138− @TSerialize

145+ @(TTable context)

139146 @TColumns

147+ @TFromExprs

140148 @(Rep (Record a))

141− @(Rep (Record (FromExprs a)))

142149 (\(_ :: proxy x) -> fromResult @(Context x) @x)

143150

144151

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

155−

156−

157152data TTable :: K.Context -> Type -> Exp Constraint

158153type instance Eval (TTable context a) = Table context a

159154

@@ -174,11 +169,17 @@ data TTranspose :: K.Context -> Type -> Exp Type

174169type instance Eval (TTranspose context a) = Transpose context a

175170

176171

177−data TSerialize :: Type -> Type -> Exp Constraint

178−type instance Eval (TSerialize expr a) =

179− ( Table (Context expr) expr

180− , a ~ FromExprs expr

181− )

172+-- | Any context is trivially a table.

173+instance KnownSpec spec => Table context (context spec) where

174+ type Columns (context spec) = HIdentity spec

175+ type Context (context spec) = context

176+ type FromExprs (context spec) = Result spec

177+ type Transpose to (context spec) = to spec

178+

179+ toColumns = HIdentity

180+ fromColumns = unHIdentity

181+ toResult = HIdentity

182+ fromResult = unHIdentity

182183

183184

184185instance (Table context a, Table context b) => Table context (a, b)

src/Rel8/Table/ADT.hs+25−13

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

77{-# language ScopedTypeVariables #-}

88{-# language StandaloneKindSignatures #-}

99{-# language TypeApplications #-}

10+{-# language TypeFamilies #-}

1011{-# language TypeFamilyDependencies #-}

1112{-# language UndecidableInstances #-}

1213{-# language UndecidableSuperClasses #-}

@@ -27,7 +28,7 @@ where

2728

2829-- base

2930import Data.Kind ( Constraint, Type )

30−import GHC.Generics ( Generic, from, to )

31+import GHC.Generics ( Generic, Rep, from, to )

3132import GHC.TypeLits ( Symbol )

3233import Prelude

3334

@@ -44,20 +45,24 @@ import Rel8.Generic.Construction

4445 , GGName, ggname

4546 , GGAggregate, ggaggregate

4647 )

48+import Rel8.Generic.Map ( GMap )

4749import Rel8.Generic.Record ( Record( Record ), unrecord )

4850import Rel8.Generic.Rel8able

4951 ( Rel8able

5052 , GRep, GColumns, gfromColumns, gtoColumns

5153 , GFromExprs, gfromResult, gtoResult

52− , TSerialize, deserialize, serialize

5354 )

5455import qualified Rel8.Generic.Table.ADT as G

5556import qualified Rel8.Kind.Algebra as K

57+import Rel8.Schema.Context.Virtual

5658import Rel8.Schema.HTable ( HTable )

5759import qualified Rel8.Schema.Kind as K

5860import Rel8.Schema.Name ( Name )

5961import Rel8.Schema.Result ( Result )

60−import Rel8.Table ( Table, TColumns )

62+import Rel8.Table

63+ ( Table, fromResult, toResult

64+ , TTable, TColumns, TFromExprs

65+ )

6166

6267

6368type ADT :: K.Rel8able -> K.Rel8able

@@ -68,26 +73,31 @@ instance ADTable t => Rel8able (ADT t) where

6873 type GColumns (ADT t) = GColumnsADT t

6974 type GFromExprs (ADT t) = t Result

7075

71− gfromColumns _ = ADT

72− gtoColumns _ (ADT a) = a

76+ gfromColumns VAggregate = ADT

77+ gfromColumns VExpr = ADT

78+ gfromColumns VName = ADT

79+

80+ gtoColumns VAggregate (ADT a) = a

81+ gtoColumns VExpr (ADT a) = a

82+ gtoColumns VName (ADT a) = a

7383

7484 gfromResult =

7585 unrecord .

7686 to .

7787 G.gfromResultADT

78− @TSerialize

88+ @(TTable Expr)

7989 @TColumns

90+ @TFromExprs

8091 @(Eval (ADTRep t Expr))

81− @(Eval (ADTRep t Result))

82− (\(_ :: proxy x) -> deserialize @_ @x)

92+ (\(_ :: proxy x) -> fromResult @_ @x)

8393

8494 gtoResult =

8595 G.gtoResultADT

86− @TSerialize

96+ @(TTable Expr)

8797 @TColumns

98+ @TFromExprs

8899 @(Eval (ADTRep t Expr))

89− @(Eval (ADTRep t Result))

90− (\(_ :: proxy x) -> serialize @_ @x) .

100+ (\(_ :: proxy x) -> toResult @_ @x) .

91101 from .

92102 Record

93103

@@ -96,13 +106,15 @@ type ADTable :: K.Rel8able -> Constraint

96106class

97107 ( Generic (Record (t Result))

98108 , HTable (GColumnsADT t)

99− , G.GSerializeADT TSerialize TColumns (Eval (ADTRep t Expr)) (Eval (ADTRep t Result))

109+ , G.GTableADT (TTable Expr) TColumns TFromExprs (Eval (ADTRep t Expr))

110+ , GMap TFromExprs (Rep (Record (t Expr))) ~ Rep (Record (t Result))

100111 )

101112 => ADTable t

102113instance

103114 ( Generic (Record (t Result))

104115 , HTable (GColumnsADT t)

105− , G.GSerializeADT TSerialize TColumns (Eval (ADTRep t Expr)) (Eval (ADTRep t Result))

116+ , G.GTableADT (TTable Expr) TColumns TFromExprs (Eval (ADTRep t Expr))

117+ , GMap TFromExprs (Rep (Record (t Expr))) ~ Rep (Record (t Result))

106118 )

107119 => ADTable t

108120

src/Rel8/Table/Aggregate.hs+9−19

@@ -16,8 +16,8 @@ import Data.Functor.Identity ( Identity( Identity ) )

1616import Prelude

1717

1818-- rel8

19−import Rel8.Aggregate ( Aggregate, Aggregates )

20−import Rel8.Expr ( Expr )

19+import Rel8.Aggregate ( Aggregate( A ), Aggregates )

20+import Rel8.Expr ( Expr( E ) )

2121import Rel8.Expr.Aggregate

2222 ( groupByExpr

2323 , slistAggExpr

@@ -27,7 +27,8 @@ 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 ( Spec( Spec, info ) )

30+import Rel8.Schema.Spec ( SSpec( SSpec, info ) )

31+import Rel8.Schema.Spec.Constrain ( ConstrainSpec )

3132import Rel8.Table ( toColumns, fromColumns )

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

3334import Rel8.Table.List ( ListTable )

@@ -37,28 +38,17 @@ import Rel8.Type.Eq ( DBEq )

3738

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

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

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

5342 => exprs -> aggregates

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

5544

5645

57−hgroupBy :: HTable t => t (Dict (Sql DBEq)) -> t Expr -> t Aggregate

46+hgroupBy :: HTable t

47+ => t (Dict (ConstrainSpec (Sql DBEq))) -> t Expr -> t Aggregate

5848hgroupBy eqs exprs = htabulate $ \field ->

5949 case hfield eqs field of

6050 Dict -> case hfield exprs field of

61− expr -> groupByExpr expr

51+ E expr -> A $ groupByExpr expr

6252

6353

6454-- | Aggregate rows into a single row containing an array of all aggregated

@@ -80,7 +70,7 @@ hgroupBy eqs exprs = htabulate $ \field ->

8070listAgg :: Aggregates aggregates exprs => exprs -> ListTable Aggregate aggregates

8171listAgg (toColumns -> exprs) = fromColumns $

8272 hvectorize

83− (\Spec {info} (Identity a) -> slistAggExpr info a)

73+ (\SSpec {info} (Identity (E a)) -> A $ slistAggExpr info a)

8474 (pure exprs)

8575

8676

@@ -88,5 +78,5 @@ listAgg (toColumns -> exprs) = fromColumns $

8878nonEmptyAgg :: Aggregates aggregates exprs => exprs -> NonEmptyTable Aggregate aggregates

8979nonEmptyAgg (toColumns -> exprs) = fromColumns $

9080 hvectorize

91− (\Spec {info} (Identity a) -> snonEmptyAggExpr info a)

81+ (\SSpec {info} (Identity (E a)) -> A $ snonEmptyAggExpr info a)

9282 (pure exprs)

src/Rel8/Table/Bool.hs+6−5

@@ -13,7 +13,7 @@ where

1313import Prelude

1414

1515-- rel8

16−import Rel8.Expr ( Expr )

16+import Rel8.Expr ( Expr( E, unE ) )

1717import Rel8.Expr.Bool ( boolExpr, caseExpr )

1818import Rel8.Expr.Null ( isNull, unsafeUnnullify )

1919import Rel8.Schema.HTable ( htabulate, hfield )

@@ -28,7 +28,8 @@ 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− (falseExpr, trueExpr) -> boolExpr falseExpr trueExpr condition

31+ (E falseExpr, E trueExpr) ->

32+ E (boolExpr falseExpr trueExpr condition)

3233{-# INLINABLE bool #-}

3334

3435

@@ -38,9 +39,9 @@ bool (toColumns -> false) (toColumns -> true) condition =

3839case_ :: Table Expr a => [(Expr Bool, a)] -> a -> a

3940case_ (map (fmap toColumns) -> branches) (toColumns -> fallback) =

4041 fromColumns $ htabulate $ \field -> case hfield fallback field of

41− fallbackExpr ->

42− case map (fmap (`hfield` field)) branches of

43− branchExprs -> caseExpr branchExprs fallbackExpr

42+ E fallbackExpr ->

43+ case map (fmap (unE . (`hfield` field))) branches of

44+ branchExprs -> E (caseExpr branchExprs fallbackExpr)

4445

4546

4647-- | Like 'maybe', but to eliminate @null@.

src/Rel8/Table/Either.hs+25−34

@@ -25,7 +25,6 @@ where

2525

2626-- base

2727import Data.Bifunctor ( Bifunctor, bimap )

28−import Data.Functor.Identity ( Identity( Identity ) )

2928import Data.Kind ( Type )

3029import Prelude hiding ( undefined )

3130

@@ -33,8 +32,8 @@ import Prelude hiding ( undefined )

3332import Control.Comonad ( extract )

3433

3534-- rel8

36−import Rel8.Aggregate ( Aggregate )

37−import Rel8.Expr ( Expr )

35+import Rel8.Aggregate ( Aggregate( A ) )

36+import Rel8.Expr ( Expr( E ) )

3837import Rel8.Expr.Aggregate ( groupByExpr )

3938import Rel8.Expr.Serialize ( litExpr )

4039import Rel8.Kind.Context ( Reifiable )

@@ -44,7 +43,9 @@ import Rel8.Schema.HTable.Either ( HEitherTable(..) )

4443import Rel8.Schema.HTable.Identity ( HIdentity(..) )

4544import Rel8.Schema.HTable.Label ( hlabel, hunlabel )

4645import qualified Rel8.Schema.Kind as K

47−import Rel8.Schema.Name ( Name )

46+import Rel8.Schema.Name ( Name( N ) )

47+import Rel8.Schema.Result ( Result( R ) )

48+import Rel8.Schema.Spec ( Spec( Spec ) )

4849import Rel8.Table

4950 ( Table, Columns, Context, fromColumns, toColumns

5051 , FromExprs, fromResult, toResult

@@ -54,7 +55,6 @@ import Rel8.Table.Bool ( bool )

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

5556import Rel8.Table.Nullify ( Nullify, aggregateNullify, guard )

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

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,29 +72,20 @@ 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 :: context EitherTag

75+ { tag :: context ('Spec 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−

8782instance Nullifiable context => Bifunctor (EitherTable context) where

8883 bimap f g (EitherTable tag a b) = EitherTable tag (fmap f a) (fmap g b)

8984

9085

91−instance Projectable (EitherTable context a) where

92− project f (EitherTable tag a b) = EitherTable tag a (project f b)

93−

94−

9586instance (context ~ Expr, Table Expr a) => Apply (EitherTable context a) where

96− EitherTable tag l1 f <.> EitherTable tag' l2 a =

97− EitherTable (tag <> tag') (bool l1 l2 (isLeft tag)) (f <.> a)

87+ EitherTable (E tag) l1 f <.> EitherTable (E tag') l2 a =

88+ EitherTable (E (tag <> tag')) (bool l1 l2 (isLeft tag)) (f <.> a)

9889

9990

10091instance (context ~ Expr, Table Expr a) => Applicative (EitherTable context a) where

@@ -103,9 +94,9 @@ instance (context ~ Expr, Table Expr a) => Applicative (EitherTable context a) w

10394

10495

10596instance (context ~ Expr, Table Expr a) => Bind (EitherTable context a) where

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

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

109100

110101

111102instance (context ~ Expr, Table Expr a) => Monad (EitherTable context a) where

@@ -131,7 +122,7 @@ instance

131122 EitherTable to (Transpose to a) (Transpose to b)

132123

133124 toColumns EitherTable {tag, left, right} = HEitherTable

134− { htag = hlabel $ HIdentity tag

125+ { htag = hlabel $ HType tag

135126 , hleft = hlabel $ guard tag (== IsLeft) isLeft $ toColumns left

136127 , hright = hlabel $ guard tag (== IsRight) isRight $ toColumns right

137128 }

@@ -144,18 +135,18 @@ instance

144135

145136 toResult = \case

146137 Left table -> HEitherTable

147− { htag = hlabel (HIdentity (Identity IsLeft))

138+ { htag = hlabel (HType (R IsLeft))

148139 , hleft = hlabel (toResult @_ @(Nullify context a) (Just table))

149140 , hright = hlabel (toResult @_ @(Nullify context b) Nothing)

150141 }

151142 Right table -> HEitherTable

152− { htag = hlabel (HIdentity (Identity IsRight))

143+ { htag = hlabel (HType (R IsRight))

153144 , hleft = hlabel (toResult @_ @(Nullify context a) Nothing)

154145 , hright = hlabel (toResult @_ @(Nullify context b) (Just table))

155146 }

156147

157148 fromResult HEitherTable {htag, hleft, hright} = case hunlabel htag of

158− HIdentity (Identity tag) -> case tag of

149+ HType (R tag) -> case tag of

159150 IsLeft -> maybe err Left $ fromResult @_ @(Nullify context a) (hunlabel hleft)

160151 IsRight -> maybe err Right $ fromResult @_ @(Nullify context b) (hunlabel hright)

161152 where

@@ -166,7 +157,7 @@ instance (EqTable a, EqTable b, context ~ Expr) =>

166157 EqTable (EitherTable context a b)

167158 where

168159 eqTable = HEitherTable

169− { htag = hlabel (HIdentity Dict)

160+ { htag = hlabel (HType Dict)

170161 , hleft = hlabel (eqTable @(Nullify context a))

171162 , hright = hlabel (eqTable @(Nullify context b))

172163 }

@@ -176,7 +167,7 @@ instance (OrdTable a, OrdTable b, context ~ Expr) =>

176167 OrdTable (EitherTable context a b)

177168 where

178169 ordTable = HEitherTable

179− { htag = hlabel (HIdentity Dict)

170+ { htag = hlabel (HType Dict)

180171 , hleft = hlabel (ordTable @(Nullify context a))

181172 , hright = hlabel (ordTable @(Nullify context b))

182173 }

@@ -188,30 +179,30 @@ instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ EitherTable Expr exprs1 exprs2

188179

189180-- | Test if an 'EitherTable' is a 'leftTable'.

190181isLeftTable :: EitherTable Expr a b -> Expr Bool

191−isLeftTable EitherTable {tag} = isLeft tag

182+isLeftTable EitherTable {tag = E tag} = isLeft tag

192183

193184

194185-- | Test if an 'EitherTable' is a 'rightTable'.

195186isRightTable :: EitherTable Expr a b -> Expr Bool

196−isRightTable EitherTable {tag} = isRight tag

187+isRightTable EitherTable {tag = E tag} = isRight tag

197188

198189

199190-- | Pattern match/eliminate an 'EitherTable', by providing mappings from a

200191-- 'leftTable' and 'rightTable'.

201192eitherTable :: Table Expr c

202193 => (a -> c) -> (b -> c) -> EitherTable Expr a b -> c

203−eitherTable f g EitherTable {tag, left, right} =

194+eitherTable f g EitherTable {tag = E tag, left, right} =

204195 bool (f (extract left)) (g (extract right)) (isRight tag)

205196

206197

207198-- | Construct a left 'EitherTable'. Like 'Left'.

208199leftTable :: Table Expr b => a -> EitherTable Expr a b

209−leftTable a = EitherTable (litExpr IsLeft) (pure a) undefined

200+leftTable a = EitherTable (E (litExpr IsLeft)) (pure a) undefined

210201

211202

212203-- | Construct a right 'EitherTable'. Like 'Right'.

213204rightTable :: Table Expr a => b -> EitherTable Expr a b

214−rightTable = EitherTable (litExpr IsRight) undefined . pure

205+rightTable = EitherTable (E (litExpr IsRight)) undefined . pure

215206

216207

217208-- | Lift a pair of aggregating functions to operate on an 'EitherTable'.

@@ -221,8 +212,8 @@ aggregateEitherTable :: ()

221212 -> (exprs' -> aggregates')

222213 -> EitherTable Expr exprs exprs'

223214 -> EitherTable Aggregate aggregates aggregates'

224−aggregateEitherTable f g (EitherTable tag a b) = EitherTable

225− { tag = groupByExpr tag

215+aggregateEitherTable f g (EitherTable (E tag) a b) = EitherTable

216+ { tag = A (groupByExpr tag)

226217 , left = aggregateNullify f a

227218 , right = aggregateNullify g b

228219 }

@@ -240,4 +231,4 @@ nameEitherTable

240231 -> b

241232 -- ^ Names of the columns in the @b@ table.

242233 -> EitherTable Name a b

243−nameEitherTable tag left right = EitherTable tag (pure left) (pure right)

234+nameEitherTable tag left right = EitherTable (N tag) (pure left) (pure right)

src/Rel8/Table/Eq.hs+17−10

@@ -27,7 +27,7 @@ import GHC.Generics ( Rep )

2727import Prelude

2828

2929-- rel8

30−import Rel8.Expr ( Expr )

30+import Rel8.Expr ( Expr( E ) )

3131import Rel8.Expr.Bool ( (||.), (&&.) )

3232import Rel8.Expr.Eq ( (==.), (/=.) )

3333import Rel8.FCF ( Eval, Exp )

@@ -35,9 +35,10 @@ import Rel8.Generic.Record ( Record )

3535import Rel8.Generic.Table.Record ( GTable, GColumns, gtable )

3636import Rel8.Schema.Dict ( Dict( Dict ) )

3737import Rel8.Schema.HTable ( htabulateA, hfield )

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

38+import Rel8.Schema.HTable.Identity ( HIdentity( HType ) )

3939import Rel8.Schema.Null ( Sql )

40−import Rel8.Table ( Table, Columns, toColumns, TColumns )

40+import Rel8.Schema.Spec.Constrain ( ConstrainSpec )

41+import Rel8.Table ( Table, Columns, toColumns, TColumns, TFromExprs )

4142import Rel8.Type.Eq ( DBEq )

4243

4344

@@ -46,14 +47,20 @@ import Rel8.Type.Eq ( DBEq )

4647-- means "all columns in a 'Table' have an instance of 'DBEq'".

4748type EqTable :: Type -> Constraint

4849class Table Expr a => EqTable a where

49− eqTable :: Columns a (Dict (Sql DBEq))

50+ eqTable :: Columns a (Dict (ConstrainSpec (Sql DBEq)))

5051

5152 default eqTable ::

52− ( GTable TEqTable TColumns (Rep (Record a))

53+ ( GTable TEqTable TColumns TFromExprs (Rep (Record a))

5354 , Columns a ~ GColumns TColumns (Rep (Record a))

5455 )

55− => Columns a (Dict (Sql DBEq))

56− eqTable = gtable @TEqTable @TColumns @(Rep (Record a)) table

56+ => Columns a (Dict (ConstrainSpec (Sql DBEq)))

57+ eqTable =

58+ gtable

59+ @TEqTable

60+ @TColumns

61+ @TFromExprs

62+ @(Rep (Record a))

63+ table

5764 where

5865 table (_ :: proxy x) = eqTable @x

5966

@@ -63,7 +70,7 @@ type instance Eval (TEqTable a) = EqTable a

6370

6471

6572instance Sql DBEq a => EqTable (Expr a) where

66− eqTable = HIdentity Dict

73+ eqTable = HType Dict

6774

6875

6976instance (EqTable a, EqTable b) => EqTable (a, b)

@@ -97,7 +104,7 @@ instance

97104(toColumns -> as) ==: (toColumns -> bs) =

98105 foldl1' (&&.) $ getConst $ htabulateA $ \field ->

99106 case (hfield as field, hfield bs field) of

100− (a, b) -> case hfield (eqTable @a) field of

107+ (E a, E b) -> case hfield (eqTable @a) field of

101108 Dict -> Const (pure (a ==. b))

102109infix 4 ==:

103110

@@ -109,7 +116,7 @@ infix 4 ==:

109116(toColumns -> as) /=: (toColumns -> bs) =

110117 foldl1' (||.) $ getConst $ htabulateA $ \field ->

111118 case (hfield as field, hfield bs field) of

112− (a, b) -> case hfield (eqTable @a) field of

119+ (E a, E b) -> case hfield (eqTable @a) field of

113120 Dict -> Const (pure (a /=. b))

114121infix 4 /=:

115122

src/Rel8/Table/HKD.hs+13−14

@@ -57,18 +57,16 @@ import Rel8.Generic.Rel8able

5757 , GFromExprs, gfromResult, gtoResult

5858 )

5959import Rel8.Generic.Table

60− ( GGSerialize, GGColumns, GAlgebra, ggfromResult, ggtoResult

60+ ( GGTable, GGColumns, GAlgebra, ggfromResult, ggtoResult

6161 )

6262import Rel8.Generic.Table.Record ( GTable, GContext )

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

6464import qualified Rel8.Schema.Kind as K

6565import Rel8.Schema.HTable ( HTable )

6666import Rel8.Schema.Name ( Name )

67−import Rel8.Schema.Result ( Result )

6867import Rel8.Table

6968 ( Table, fromColumns, toColumns, fromResult, toResult

70− , TTable, TColumns, TContext

71− , TSerialize

69+ , TTable, TColumns, TContext, TFromExprs

7270 )

7371

7472

@@ -93,26 +91,26 @@ instance HKDable a => Rel8able (HKD a) where

9391 to .

9492 ggfromResult

9593 @(GAlgebra (Rep a))

96− @TSerialize

94+ @(TTable Expr)

9795 @TColumns

96+ @TFromExprs

9897 @(Eval (HKDRep a Expr))

99− @(Eval (HKDRep a Result))

10098 (\(_ :: proxy x) -> fromResult @_ @x)

10199

102100 gtoResult =

103101 ggtoResult

104102 @(GAlgebra (Rep a))

105− @TSerialize

103+ @(TTable Expr)

106104 @TColumns

105+ @TFromExprs

107106 @(Eval (HKDRep a Expr))

108− @(Eval (HKDRep a Result))

109107 (\(_ :: proxy x) -> toResult @_ @x) .

110108 from .

111109 Record

112110

113111

114112instance

115− ( GTable (TTable f) TColumns (GRecord (GMap (TColumn f) (Rep a)))

113+ ( GTable (TTable f) TColumns TFromExprs (GRecord (GMap (TColumn f) (Rep a)))

116114 , G.GColumns TColumns (GRecord (GMap (TColumn f) (Rep a))) ~ GColumnsHKD a

117115 , GContext TContext (GRecord (GMap (TColumn f) (Rep a))) ~ f

118116 , GRecordable (GMap (TColumn f) (Rep a))

@@ -126,6 +124,7 @@ instance

126124 G.gfromColumns

127125 @(TTable f)

128126 @TColumns

127+ @TFromExprs

129128 fromColumns .

130129 (\(HKD a) -> a)

131130

@@ -134,6 +133,7 @@ instance

134133 G.gtoColumns

135134 @(TTable f)

136135 @TColumns

136+ @TFromExprs

137137 toColumns .

138138 grecord @(GMap (TColumn f) (Rep a))

139139

@@ -143,21 +143,20 @@ class

143143 ( Generic (Record a)

144144 , HTable (GColumns (HKD a))

145145 , KnownAlgebra (GAlgebra (Rep 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)

146+ , Eval (GGTable (GAlgebra (Rep a)) (TTable Expr) TColumns TFromExprs (Eval (HKDRep a Expr)))

147+ , GMap TFromExprs (GRecord (GMap (TColumn Expr) (Rep a))) ~ Rep (Record a)

148148 )

149149 => HKDable a

150150instance

151151 ( Generic (Record a)

152152 , HTable (GColumns (HKD a))

153153 , KnownAlgebra (GAlgebra (Rep 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)

154+ , Eval (GGTable (GAlgebra (Rep a)) (TTable Expr) TColumns TFromExprs (Eval (HKDRep a Expr)))

155+ , GMap TFromExprs (GRecord (GMap (TColumn Expr) (Rep a))) ~ Rep (Record a)

156156 )

157157 => HKDable a

158158

159159

160−type Top_ :: Constraint

161160class Top_

162161instance Top_

163162

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

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

1111

1212module Rel8.Table.List

1313 ( ListTable(..)

14− , ($*)

15− , listTable

16− , nameListTable

14+ , listTable, nameListTable

1715 )

1816where

1917

@@ -23,20 +21,16 @@ import Data.Kind ( Type )

2321import Prelude

2422

2523-- rel8

26−import Rel8.Expr ( Expr )

24+import Rel8.Expr ( Expr( E, unE ) )

2725import Rel8.Expr.Array ( sappend, sempty, slistOf )

2826import Rel8.Schema.Dict ( Dict( Dict ) )

2927import Rel8.Schema.HTable.List ( HListTable )

30−import Rel8.Schema.HTable.Vectorize

31− ( hvectorize, hunvectorize

32− , happend, hempty

33− , hproject, hcolumn

34− )

28+import Rel8.Schema.HTable.Vectorize ( happend, hempty, hvectorize, hunvectorize )

3529import qualified Rel8.Schema.Kind as K

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

30+import Rel8.Schema.Name ( Name( N, Name ) )

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

3832import Rel8.Schema.Result ( vectorizer, unvectorizer )

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

33+import Rel8.Schema.Spec ( SSpec(..) )

4034import Rel8.Table

4135 ( Table, Context, Columns, fromColumns, toColumns

4236 , FromExprs, fromResult, toResult

@@ -48,9 +42,6 @@ import Rel8.Table.Alternative

4842 )

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

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

51−import Rel8.Table.Projection

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

53− )

5445import Rel8.Table.Serialize ( ToExprs )

5546

5647

@@ -61,10 +52,6 @@ newtype ListTable context a =

6152 ListTable (HListTable (Columns a) (Context a))

6253

6354

64−instance Projectable (ListTable context) where

65− project f (ListTable a) = ListTable (hproject (apply f) a)

66−

67−

6855instance (Table context a, context ~ context') =>

6956 Table context' (ListTable context a)

7057 where

@@ -82,7 +69,7 @@ instance (Table context a, context ~ context') =>

8269instance (EqTable a, context ~ Expr) => EqTable (ListTable context a) where

8370 eqTable =

8471 hvectorize

85− (\Spec {nullity} (Identity Dict) -> case nullity of

72+ (\SSpec {nullity} (Identity Dict) -> case nullity of

8673 Null -> Dict

8774 NotNull -> Dict)

8875 (Identity (eqTable @a))

@@ -91,7 +78,7 @@ instance (EqTable a, context ~ Expr) => EqTable (ListTable context a) where

9178instance (OrdTable a, context ~ Expr) => OrdTable (ListTable context a) where

9279 ordTable =

9380 hvectorize

94− (\Spec {nullity} (Identity Dict) -> case nullity of

81+ (\SSpec {nullity} (Identity Dict) -> case nullity of

9582 Null -> Dict

9683 NotNull -> Dict)

9784 (Identity (ordTable @a))

@@ -109,29 +96,24 @@ instance context ~ Expr => AlternativeTable (ListTable context) where

10996 emptyTable = mempty

11097

11198

112−instance (context ~ Expr, Table Expr a) => Semigroup (ListTable context a)

99+instance (context ~ Expr, Table Expr a) =>

100+ Semigroup (ListTable context a)

113101 where

114− ListTable as <> ListTable bs = ListTable $ happend (const sappend) as bs

102+ ListTable as <> ListTable bs = ListTable $

103+ happend (\_ _ (E a) (E b) -> E (sappend a b)) as bs

115104

116105

117106instance (context ~ Expr, Table Expr a) =>

118107 Monoid (ListTable context a)

119108 where

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

109+ mempty = ListTable $ hempty $ \_ -> E . sempty

128110

129111

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

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

132114listTable =

133115 ListTable .

134− hvectorize (\Spec {info} -> slistOf info) .

116+ hvectorize (\SSpec {info} -> E . slistOf info . fmap unE) .

135117 fmap toColumns

136118

137119

@@ -144,6 +126,6 @@ nameListTable

144126 -> ListTable Name a

145127nameListTable =

146128 ListTable .

147− hvectorize (\_ (Identity (Name a)) -> Name a) .

129+ hvectorize (\_ (Identity (N (Name a))) -> N (Name a)) .

148130 pure .

149131 toColumns

src/Rel8/Table/Maybe.hs+21−30

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

1515 ( MaybeTable(..)

1616 , maybeTable, nothingTable, justTable

1717 , isNothingTable, isJustTable

18− , fromMaybeTable

1918 , ($?)

2019 , aggregateMaybeTable

2120 , nameMaybeTable

@@ -24,7 +23,6 @@ where

2423

2524-- base

2625import Data.Functor ( ($>) )

27−import Data.Functor.Identity ( Identity( Identity ) )

2826import Data.Kind ( Type )

2927import Data.Maybe ( fromMaybe, isJust )

3028import Prelude hiding ( null, undefined )

@@ -33,8 +31,8 @@ import Prelude hiding ( null, undefined )

3331import Control.Comonad ( extract )

3432

3533-- rel8

36−import Rel8.Aggregate ( Aggregate )

37−import Rel8.Expr ( Expr )

34+import Rel8.Aggregate ( Aggregate( A ) )

35+import Rel8.Expr ( Expr(E ) )

3836import Rel8.Expr.Aggregate ( groupByExpr )

3937import Rel8.Expr.Bool ( boolExpr )

4038import Rel8.Expr.Null ( isNull, isNonNull, null, nullify )

@@ -44,9 +42,11 @@ import qualified Rel8.Schema.Kind as K

4442import Rel8.Schema.HTable.Identity ( HIdentity(..) )

4543import Rel8.Schema.HTable.Label ( hlabel, hunlabel )

4644import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )

47−import Rel8.Schema.Name ( Name )

45+import Rel8.Schema.Name ( Name( N ) )

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

4947import qualified Rel8.Schema.Null as N

48+import Rel8.Schema.Result ( Result( R ) )

49+import Rel8.Schema.Spec ( Spec( Spec ) )

5050import Rel8.Table

5151 ( Table, Columns, Context, fromColumns, toColumns

5252 , FromExprs, fromResult, toResult

@@ -59,7 +59,6 @@ import Rel8.Table.Alternative

5959import Rel8.Table.Bool ( bool )

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

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

62−import Rel8.Table.Projection ( Projectable, project )

6362import Rel8.Table.Nullify ( Nullify, aggregateNullify, guard )

6463import Rel8.Table.Serialize ( ToExprs )

6564import Rel8.Table.Undefined ( undefined )

@@ -81,18 +80,15 @@ import Data.Functor.Bind ( Bind, (>>-) )

8180-- a "nullTag" - to track whether or not the outer join produced any rows.

8281type MaybeTable :: K.Context -> Type -> Type

8382data MaybeTable context a = MaybeTable

84− { tag :: context (Maybe MaybeTag)

83+ { tag :: context ('Spec (Maybe MaybeTag))

8584 , just :: Nullify context a

8685 }

8786 deriving stock Functor

8887

8988

90−instance Projectable (MaybeTable context) where

91− project f (MaybeTable tag a) = MaybeTable tag (project f a)

92−

93−

9489instance context ~ Expr => Apply (MaybeTable context) where

95− MaybeTable tag f <.> MaybeTable tag' a = MaybeTable (tag <> tag') (f <.> a)

90+ MaybeTable (E tag) f <.> MaybeTable (E tag') a =

91+ MaybeTable (E (tag <> tag')) (f <.> a)

9692

9793

9894-- | Has the same behavior as the @Applicative@ instance for @Maybe@. See also:

@@ -103,8 +99,8 @@ instance context ~ Expr => Applicative (MaybeTable context) where

10399

104100

105101instance context ~ Expr => Bind (MaybeTable context) where

106− MaybeTable tag a >>- f = case f (extract a) of

107− MaybeTable tag' b -> MaybeTable (tag <> tag') b

102+ MaybeTable (E tag) a >>- f = case f (extract a) of

103+ MaybeTable (E tag') b -> MaybeTable (E (tag <> tag')) b

108104

109105

110106-- | Has the same behavior as the @Monad@ instance for @Maybe@.

@@ -151,12 +147,12 @@ instance (Table context a, Reifiable context, context ~ context') =>

151147 }

152148

153149 toResult ma = HMaybeTable

154− { htag = hlabel (HIdentity (Identity (IsJust <$ ma)))

150+ { htag = hlabel (HIdentity (R (IsJust <$ ma)))

155151 , hjust = hlabel (toResult @_ @(Nullify context a) ma)

156152 }

157153

158154 fromResult HMaybeTable {htag, hjust} = case hunlabel htag of

159− HIdentity (Identity tag) -> tag $>

155+ HType (R tag) -> tag $>

160156 fromMaybe err (fromResult @_ @(Nullify context a) (hunlabel hjust))

161157 where

162158 err = error "Maybe.fromColumns: mismatch between tag and data"

@@ -164,14 +160,14 @@ instance (Table context a, Reifiable context, context ~ context') =>

164160

165161instance (EqTable a, context ~ Expr) => EqTable (MaybeTable context a) where

166162 eqTable = HMaybeTable

167− { htag = hlabel (HIdentity Dict)

163+ { htag = hlabel (HType Dict)

168164 , hjust = hlabel (eqTable @(Nullify context a))

169165 }

170166

171167

172168instance (OrdTable a, context ~ Expr) => OrdTable (MaybeTable context a) where

173169 ordTable = HMaybeTable

174− { htag = hlabel (HIdentity Dict)

170+ { htag = hlabel (HType Dict)

175171 , hjust = hlabel (ordTable @(Nullify context a))

176172 }

177173

@@ -182,12 +178,12 @@ instance (ToExprs exprs a, context ~ Expr) =>

182178

183179-- | Check if a @MaybeTable@ is absent of any row. Like 'Data.Maybe.isNothing'.

184180isNothingTable :: MaybeTable Expr a -> Expr Bool

185−isNothingTable (MaybeTable tag _) = isNull tag

181+isNothingTable (MaybeTable (E tag) _) = isNull tag

186182

187183

188184-- | Check if a @MaybeTable@ contains a row. Like 'Data.Maybe.isJust'.

189185isJustTable :: MaybeTable Expr a -> Expr Bool

190−isJustTable (MaybeTable tag _) = isNonNull tag

186+isJustTable (MaybeTable (E tag) _) = isNonNull tag

191187

192188

193189-- | Perform case analysis on a 'MaybeTable'. Like 'maybe'.

@@ -198,18 +194,13 @@ maybeTable b f ma@(MaybeTable _ a) = bool (f (extract a)) b (isNothingTable ma)

198194

199195-- | The null table. Like 'Nothing'.

200196nothingTable :: Table Expr a => MaybeTable Expr a

201−nothingTable = MaybeTable null (pure undefined)

197+nothingTable = MaybeTable (E null) (pure undefined)

202198

203199

204200-- | Lift any table into 'MaybeTable'. Like 'Just'. Note you can also use

205201-- 'pure'.

206202justTable :: a -> MaybeTable Expr a

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

203+justTable = MaybeTable (E mempty) . pure

213204

214205

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

@@ -229,8 +220,8 @@ aggregateMaybeTable :: ()

229220 => (exprs -> aggregates)

230221 -> MaybeTable Expr exprs

231222 -> MaybeTable Aggregate aggregates

232−aggregateMaybeTable f (MaybeTable tag a) =

233− MaybeTable (groupByExpr tag) (aggregateNullify f a)

223+aggregateMaybeTable f (MaybeTable (E tag) a) =

224+ MaybeTable (A (groupByExpr tag)) (aggregateNullify f a)

234225

235226

236227-- | Construct a 'MaybeTable' in the 'Name' context. This can be useful if you

@@ -243,4 +234,4 @@ nameMaybeTable

243234 -> a

244235 -- ^ Names of the columns in @a@.

245236 -> MaybeTable Name a

246−nameMaybeTable tag = MaybeTable tag . pure

237+nameMaybeTable tag = MaybeTable (N tag) . pure

src/Rel8/Table/Name.hs+20−6

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

1212module Rel8.Table.Name

1313 ( namesFromLabels

1414 , namesFromLabelsWith

15+ , showExprs

1516 , showLabels

1617 , showNames

1718 )

@@ -24,11 +25,17 @@ import Data.List.NonEmpty ( NonEmpty, intersperse, nonEmpty )

2425import Data.Maybe ( fromMaybe )

2526import Prelude

2627

28+-- opaleye

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

30+

2731-- rel8

32+import Rel8.Expr ( Expr( E ) )

33+import Rel8.Expr.Opaleye ( toPrimExpr )

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

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

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

35+import Rel8.Schema.Name ( Name( N, Name ) )

36+import Rel8.Schema.Spec ( SSpec(..) )

3137import Rel8.Table ( Table(..) )

38+import Rel8.Table.Cols ( Cols( Cols ) )

3239

3340

3441-- | Construct a table in the 'Name' context containing the names of all

@@ -60,19 +67,26 @@ namesFromLabelsWith :: Table Name a

6067 => (NonEmpty String -> String) -> a

6168namesFromLabelsWith f = fromColumns $ htabulate $ \field ->

6269 case hfield hspecs field of

63− Spec {labels} -> Name (f (renderLabels labels))

70+ SSpec {labels} -> N (Name (f (renderLabels labels)))

71+

72+

73+showExprs :: Table Expr a => a -> [(String, Opaleye.PrimExpr)]

74+showExprs as = case (namesFromLabels, toColumns as) of

75+ (Cols names, exprs) -> getConst $ htabulateA $ \field ->

76+ case (hfield names field, hfield exprs field) of

77+ (N (Name name), E expr) -> Const [(name, toPrimExpr expr)]

6478

6579

6680showLabels :: forall a. Table (Context a) a => a -> [NonEmpty String]

6781showLabels _ = getConst $

6882 htabulateA @(Columns a) $ \field -> case hfield hspecs field of

69− Spec {labels} -> Const (pure (renderLabels labels))

83+ SSpec {labels} -> Const [renderLabels labels]

7084

7185

72−showNames :: forall a. Table Name a => a -> NonEmpty String

86+showNames :: forall a. Table Name a => a -> [String]

7387showNames (toColumns -> names) = getConst $

7488 htabulateA @(Columns a) $ \field -> case hfield names field of

75− Name name -> Const (pure name)

89+ N (Name name) -> Const [name]

7690

7791

7892renderLabels :: [String] -> NonEmpty String

src/Rel8/Table/NonEmpty.hs+12−31

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

1111

1212module Rel8.Table.NonEmpty

1313 ( NonEmptyTable(..)

14− , ($+)

15− , nonEmptyTable

16− , nameNonEmptyTable

14+ , nonEmptyTable, nameNonEmptyTable

1715 )

1816where

1917

@@ -24,20 +22,16 @@ import Data.List.NonEmpty ( NonEmpty )

2422import Prelude hiding ( id )

2523

2624-- rel8

27−import Rel8.Expr ( Expr )

25+import Rel8.Expr ( Expr( E, unE ) )

2826import Rel8.Expr.Array ( sappend1, snonEmptyOf )

2927import Rel8.Schema.Dict ( Dict( Dict ) )

3028import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable )

31−import Rel8.Schema.HTable.Vectorize

32− ( hvectorize, hunvectorize

33− , happend

34− , hproject, hcolumn

35− )

29+import Rel8.Schema.HTable.Vectorize ( happend, hvectorize, hunvectorize )

3630import qualified Rel8.Schema.Kind as K

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

31+import Rel8.Schema.Name ( Name( N, Name ) )

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

3933import Rel8.Schema.Result ( vectorizer, unvectorizer )

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

34+import Rel8.Schema.Spec ( SSpec(..) )

4135import Rel8.Table

4236 ( Table, Context, Columns, fromColumns, toColumns

4337 , FromExprs, fromResult, toResult

@@ -46,9 +40,6 @@ import Rel8.Table

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

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

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

49−import Rel8.Table.Projection

50− ( Projectable, Projecting, Projection, project, apply

51− )

5243import Rel8.Table.Serialize ( ToExprs )

5344

5445

@@ -59,10 +50,6 @@ newtype NonEmptyTable context a =

5950 NonEmptyTable (HNonEmptyTable (Columns a) (Context a))

6051

6152

62−instance Projectable (NonEmptyTable context) where

63− project f (NonEmptyTable a) = NonEmptyTable (hproject (apply f) a)

64−

65−

6653instance (Table context a, context ~ context') =>

6754 Table context' (NonEmptyTable context a)

6855 where

@@ -83,7 +70,7 @@ instance (EqTable a, context ~ Expr) =>

8370 where

8471 eqTable =

8572 hvectorize

86− (\Spec {nullity} (Identity Dict) -> case nullity of

73+ (\SSpec {nullity} (Identity Dict) -> case nullity of

8774 Null -> Dict

8875 NotNull -> Dict)

8976 (Identity (eqTable @a))

@@ -94,7 +81,7 @@ instance (OrdTable a, context ~ Expr) =>

9481 where

9582 ordTable =

9683 hvectorize

97− (\Spec {nullity} (Identity Dict) -> case nullity of

84+ (\SSpec {nullity} (Identity Dict) -> case nullity of

9885 Null -> Dict

9986 NotNull -> Dict)

10087 (Identity (ordTable @a))

@@ -108,24 +95,18 @@ instance context ~ Expr => AltTable (NonEmptyTable context) where

10895 (<|>:) = (<>)

10996

11097

111−instance (Table Expr a, context ~ Expr) => Semigroup (NonEmptyTable context a)

98+instance (Table Expr a, context ~ Expr) =>

99+ Semigroup (NonEmptyTable context a)

112100 where

113101 NonEmptyTable as <> NonEmptyTable bs = NonEmptyTable $

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 $+

102+ happend (\_ _ (E a) (E b) -> E (sappend1 a b)) as bs

122103

123104

124105-- | Construct a @NonEmptyTable@ from a non-empty list of expressions.

125106nonEmptyTable :: Table Expr a => NonEmpty a -> NonEmptyTable Expr a

126107nonEmptyTable =

127108 NonEmptyTable .

128− hvectorize (\Spec {info} -> snonEmptyOf info) .

109+ hvectorize (\SSpec {info} -> E . snonEmptyOf info . fmap unE) .

129110 fmap toColumns

130111

131112

@@ -138,6 +119,6 @@ nameNonEmptyTable

138119 -> NonEmptyTable Name a

139120nameNonEmptyTable =

140121 NonEmptyTable .

141− hvectorize (\_ (Identity (Name a)) -> Name a) .

122+ hvectorize (\_ (Identity (N (Name a))) -> N (Name a)) .

142123 pure .

143124 toColumns

src/Rel8/Table/Null.hsdeleted−147

@@ -1,147 +0,0 @@

1−{-# language DataKinds #-}

2−{-# language FlexibleContexts #-}

3−{-# language FlexibleInstances #-}

4−{-# language MultiParamTypeClasses #-}

5−{-# language ScopedTypeVariables #-}

6−{-# language StandaloneKindSignatures #-}

7−{-# language TypeApplications #-}

8−{-# language TypeFamilies #-}

9−{-# language UndecidableInstances #-}

10−

11−module Rel8.Table.Null

12− ( NullTable(..)

13− , nullableTable, nullTable, nullifyTable, unsafeUnnullifyTable

14− , isNullTable, isNonNullTable

15− , nameNullTable

16− , toMaybeTable, toNullTable

17− )

18−where

19−

20−-- base

21−import Data.Kind ( Type )

22−import Prelude hiding ( null, undefined )

23−

24−-- comonad

25−import Control.Comonad ( extract )

26−

27−-- rel8

28−import Rel8.Expr ( Expr )

29−import Rel8.Expr.Bool ( not_ )

30−import Rel8.Kind.Context ( Reifiable )

31−import qualified Rel8.Schema.Kind as K

32−import Rel8.Schema.Name ( Name )

33−import Rel8.Table

34− ( Table, Columns, Context, fromColumns, toColumns

35− , FromExprs, fromResult, toResult

36− , Transpose

37− )

38−import Rel8.Table.Alternative

39− ( AltTable, (<|>:)

40− , AlternativeTable, emptyTable

41− )

42−import Rel8.Table.Bool ( bool )

43−import Rel8.Table.Eq ( EqTable, eqTable )

44−import Rel8.Table.Maybe ( MaybeTable, justTable, maybeTable, nothingTable )

45−import Rel8.Table.Nullify ( Nullify, isNull )

46−import Rel8.Table.Ord ( OrdTable, ordTable )

47−import Rel8.Table.Projection ( Projectable, project )

48−import Rel8.Table.Serialize ( ToExprs )

49−import Rel8.Table.Undefined ( undefined )

50−

51−

52−-- | @NullTable t@ is the table @t@, but where all the columns in @t@ have the

53−-- possibility of being 'Rel8.null'. This is very similar to

54−-- 'Rel8.MaybeTable', except that it does not use an extra tag field, so it

55−-- cannot distinguish between @Nothing@ and @Just Nothing@ if nested. In other

56−-- words, if all of the columns of the @t@ passed to @NullTable@ are already

57−-- nullable, then @NullTable@ has no effect.

58−type NullTable :: K.Context -> Type -> Type

59−newtype NullTable context a = NullTable (Nullify context a)

60−

61−

62−instance Projectable (NullTable context) where

63− project f (NullTable a) = NullTable (project f a)

64−

65−

66−instance context ~ Expr => AltTable (NullTable context) where

67− ma <|>: mb = bool ma mb (isNullTable ma)

68−

69−

70−instance context ~ Expr => AlternativeTable (NullTable context) where

71− emptyTable = nullTable

72−

73−

74−instance (Table context a, Reifiable context, context ~ context') =>

75− Table context' (NullTable context a)

76− where

77− type Columns (NullTable context a) = Columns (Nullify context a)

78− type Context (NullTable context a) = Context (Nullify context a)

79− type FromExprs (NullTable context a) = FromExprs (Nullify context a)

80− type Transpose to (NullTable context a) = NullTable to (Transpose to a)

81−

82− toColumns (NullTable a) = toColumns a

83− fromColumns = NullTable . fromColumns

84−

85− toResult = toResult @_ @(Nullify context a)

86− fromResult = fromResult @_ @(Nullify context a)

87−

88−

89−instance (EqTable a, context ~ Expr) => EqTable (NullTable context a) where

90− eqTable = eqTable @(Nullify context a)

91−

92−

93−instance (OrdTable a, context ~ Expr) => OrdTable (NullTable context a) where

94− ordTable = ordTable @(Nullify context a)

95−

96−

97−instance (ToExprs exprs a, context ~ Expr) =>

98− ToExprs (NullTable context exprs) (Maybe a)

99−

100−

101−-- | Check if any of the non-nullable fields of @a@ are 'Rel8.null' under the

102−-- 'NullTable'. Returns 'Rel8.false' if @a@ has no non-nullable fields.

103−isNullTable :: Table Expr a => NullTable Expr a -> Expr Bool

104−isNullTable (NullTable a) = isNull a

105−

106−

107−-- | The inverse of 'isNullTable'.

108−isNonNullTable :: Table Expr a => NullTable Expr a -> Expr Bool

109−isNonNullTable = not_ . isNullTable

110−

111−

112−-- | Like 'Rel8.nullable'.

113−nullableTable :: (Table Expr a, Table Expr b)

114− => b -> (a -> b) -> NullTable Expr a -> b

115−nullableTable b f ma@(NullTable a) = bool (f (extract a)) b (isNullTable ma)

116−

117−

118−-- | The null table. Like 'Rel8.null'.

119−nullTable :: Table Expr a => NullTable Expr a

120−nullTable = NullTable (pure undefined)

121−

122−

123−-- | Lift any table into 'NullTable'. Like 'Rel8.nullify'.

124−nullifyTable :: a -> NullTable Expr a

125−nullifyTable = NullTable . pure

126−

127−

128−unsafeUnnullifyTable :: NullTable Expr a -> a

129−unsafeUnnullifyTable (NullTable a) = extract a

130−

131−

132−-- | Construct a 'NullTable' in the 'Name' context. This can be useful if you

133−-- have a 'NullTable' that you are storing in a table and need to construct a

134−-- 'TableSchema'.

135−nameNullTable :: a -> NullTable Name a

136−nameNullTable = NullTable . pure

137−

138−

139−-- | Convert a 'NullTable' to a 'MaybeTable'.

140−toMaybeTable :: Table Expr a => NullTable Expr a -> MaybeTable Expr a

141−toMaybeTable = nullableTable nothingTable justTable

142−

143−

144−-- | Convert a 'MaybeTable' to a 'NullTable'. Note that if the underlying @a@

145−-- has no non-nullable fields, this is a lossy conversion.

146−toNullTable :: Table Expr a => MaybeTable Expr a -> NullTable Expr a

147−toNullTable = maybeTable nullTable nullifyTable

src/Rel8/Table/Nullify.hs+3−40

@@ -1,9 +1,7 @@

11{-# language DataKinds #-}

2−{-# language FlexibleContexts #-}

32{-# language FlexibleInstances #-}

43{-# language LambdaCase #-}

54{-# language MultiParamTypeClasses #-}

6−{-# language NamedFieldPuns #-}

75{-# language ScopedTypeVariables #-}

86{-# language StandaloneKindSignatures #-}

97{-# language TypeApplications #-}

@@ -14,13 +12,11 @@ module Rel8.Table.Nullify

1412 ( Nullify

1513 , aggregateNullify

1614 , guard

17− , isNull

1815 )

1916where

2017

2118-- base

2219import Control.Applicative ( liftA2 )

23−import Data.Functor.Const ( Const( Const ), getConst )

2420import Data.Functor.Identity ( runIdentity )

2521import Data.Kind ( Type )

2622import Prelude

@@ -31,8 +27,6 @@ import Control.Comonad ( Comonad, duplicate, extract, ComonadApply, (<@>) )

3127-- rel8

3228import Rel8.Aggregate ( Aggregate )

3329import Rel8.Expr ( Expr )

34−import Rel8.Expr.Bool ( (||.), false )

35−import qualified Rel8.Expr.Null as Expr

3630import Rel8.Kind.Context ( Reifiable, contextSing )

3731import Rel8.Schema.Context.Nullify

3832 ( Nullifiability( NAggregate, NExpr )

@@ -45,23 +39,17 @@ import Rel8.Schema.Context.Nullify

4539 )

4640import Rel8.Schema.Dict ( Dict( Dict ) )

4741import Rel8.Schema.HTable ( HTable )

48−import Rel8.Schema.HTable.Nullify

49− ( HNullify, hnulls, hnullify, hunnullify

50− , hguard

51− , hproject

52− )

42+import Rel8.Schema.HTable.Nullify ( HNullify, hnulls, hnullify, hunnullify, hguard )

5343import qualified Rel8.Schema.Kind as K

54−import Rel8.Schema.Null ( Nullity( NotNull, Null ) )

5544import qualified Rel8.Schema.Result as R

45+import Rel8.Schema.Spec ( Spec( Spec ) )

5646import Rel8.Table

5747 ( Table, Columns, Context, toColumns, fromColumns

5848 , FromExprs, fromResult, toResult

5949 , Transpose

6050 )

61−import Rel8.Schema.Spec ( Spec( Spec, nullity ) )

6251import Rel8.Table.Eq ( EqTable, eqTable )

6352import Rel8.Table.Ord ( OrdTable, ordTable )

64−import Rel8.Table.Projection ( Projectable, apply, project )

6553

6654-- semigroupoids

6755import Data.Functor.Apply ( Apply, (<.>), liftF2 )

@@ -75,12 +63,6 @@ data Nullify context a

7563 | Fields (NonNullifiability context) (HNullify (Columns a) (Context a))

7664

7765

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)

82−

83−

8466instance Nullifiable context => Functor (Nullify context) where

8567 fmap f = \case

8668 Table nullifiable a -> Table nullifiable (f a)

@@ -183,29 +165,10 @@ aggregateNullify f = \case

183165

184166

185167guard :: (Reifiable context, HTable t)

186− => context tag

168+ => context ('Spec tag)

187169 -> (tag -> Bool)

188170 -> (Expr tag -> Expr Bool)

189171 -> HNullify t context

190172 -> HNullify t context

191173guard tag isNonNull isNonNullExpr =

192174 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+63−75

@@ -2,112 +2,92 @@

22{-# language DataKinds #-}

33{-# language DisambiguateRecordFields #-}

44{-# language FlexibleContexts #-}

5+{-# language LambdaCase #-}

56{-# language NamedFieldPuns #-}

67{-# language RankNTypes #-}

78{-# language TypeFamilies #-}

89{-# language ViewPatterns #-}

910

10−{-# options_ghc -Wno-deprecations #-}

11−

1211module Rel8.Table.Opaleye

1312 ( aggregator

14− , attributes

1513 , binaryspec

1614 , distinctspec

17− , exprs

18− , exprsWithNames

1915 , table

2016 , tableFields

2117 , unpackspec

2218 , valuesspec

23− , view

2419 , castTable

2520 )

2621where

2722

2823-- base

29−import Data.Functor.Const ( Const( Const ), getConst )

30−import Data.List.NonEmpty ( NonEmpty )

31−import Prelude

24+import Prelude hiding ( undefined )

3225

3326-- opaleye

34−import qualified Opaleye.Adaptors as Opaleye

35−import qualified Opaleye.Field as Opaleye ( Field_ )

3627import qualified Opaleye.Internal.Aggregate as Opaleye

28+import qualified Opaleye.Internal.Binary as Opaleye

29+import qualified Opaleye.Internal.Distinct as Opaleye

3730import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye

31+import qualified Opaleye.Internal.PackMap as Opaleye

32+import qualified Opaleye.Internal.Unpackspec as Opaleye

3833import qualified Opaleye.Internal.Values as Opaleye

39−import qualified Opaleye.Table as Opaleye

34+import qualified Opaleye.Internal.Table as Opaleye

4035

4136-- profunctors

4237import Data.Profunctor ( dimap, lmap )

4338

4439-- rel8

45−import Rel8.Aggregate ( Aggregate( Aggregate ), Aggregates )

46−import Rel8.Expr ( Expr )

40+import Rel8.Aggregate ( Aggregate( A, Aggregate ), Aggregates )

41+import Rel8.Expr ( Expr(..) )

4742import Rel8.Expr.Opaleye

4843 ( fromPrimExpr, toPrimExpr

49− , scastExpr, traverseFieldP

44+ , traversePrimExpr

45+ , fromColumn, toColumn

46+ , scastExpr

5047 )

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 )

48+import Rel8.Schema.HTable ( htabulateA, hfield, htraverse, hspecs, htabulate )

49+import Rel8.Schema.Name ( Name( N, Name ), Selects )

50+import Rel8.Schema.Spec ( Spec, SSpec(..) )

51+import Rel8.Schema.Table ( TableSchema(..) )

5652import Rel8.Table ( Table, fromColumns, toColumns )

57−import Rel8.Type.Information ( typeName )

53+import Rel8.Table.Undefined ( undefined )

5854

5955-- semigroupoids

6056import Data.Functor.Apply ( WrappedApplicative(..) )

61−import Data.Profunctor.Product ( ProductProfunctor )

6257

6358

6459aggregator :: Aggregates aggregates exprs => Opaleye.Aggregator aggregates exprs

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))

60+aggregator = Opaleye.Aggregator $ Opaleye.PackMap $ \f aggregates ->

61+ fmap fromColumns $ unwrapApplicative $ htabulateA $ \field ->

62+ WrapApplicative $ case hfield (toColumns aggregates) field of

63+ A (Aggregate (Opaleye.Aggregator (Opaleye.PackMap inner))) ->

64+ E <$> inner f ()

8365

8466

8567binaryspec :: Table Expr a => Opaleye.Binaryspec a a

86−binaryspec = fromOpaleyespec Opaleye.binaryspecField

68+binaryspec = Opaleye.Binaryspec $ Opaleye.PackMap $ \f (as, bs) ->

69+ fmap fromColumns $ unwrapApplicative $ htabulateA $ \field ->

70+ WrapApplicative $

71+ case (hfield (toColumns as) field, hfield (toColumns bs) field) of

72+ (E a, E b) -> E . fromPrimExpr <$> f (toPrimExpr a, toPrimExpr b)

8773

8874

8975distinctspec :: Table Expr a => Opaleye.Distinctspec a a

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))

76+distinctspec =

77+ Opaleye.Distinctspec $ Opaleye.Aggregator $ Opaleye.PackMap $ \f ->

78+ fmap fromColumns .

79+ unwrapApplicative .

80+ htraverse

81+ (\(E a) ->

82+ WrapApplicative $ E . fromPrimExpr <$> f (Nothing, toPrimExpr a)) .

83+ toColumns

10484

10585

106−table :: Selects names exprs => TableSchema names -> Opaleye.Table exprs exprs

86+table ::Selects names exprs => TableSchema names -> Opaleye.Table exprs exprs

10787table (TableSchema name schema columns) =

10888 case schema of

109− Nothing -> Opaleye.table name (tableFields columns)

110− Just schemaName -> Opaleye.tableWithSchema schemaName name (tableFields columns)

89+ Nothing -> Opaleye.Table name (tableFields columns)

90+ Just schemaName -> Opaleye.TableWithSchema schemaName name (tableFields columns)

11191

11292

11393tableFields :: Selects names exprs

@@ -117,34 +97,42 @@ tableFields (toColumns -> names) = dimap toColumns fromColumns $

11797 case hfield names field of

11898 name -> lmap (`hfield` field) (go name)

11999 where

120− go :: Name a -> Opaleye.TableFields (Expr a) (Expr a)

121− go (Name name) =

122− traverseFieldP $

123− Opaleye.requiredTableField name

100+ go :: forall (spec :: Spec). Name spec -> Opaleye.TableFields (Expr spec) (Expr spec)

101+ go (N (Name name)) =

102+ lmap (\(E a) -> toColumn $ toPrimExpr a) $

103+ E . fromPrimExpr . fromColumn <$>

104+ Opaleye.requiredTableField name

124105

125106

126107unpackspec :: Table Expr a => Opaleye.Unpackspec a a

127−unpackspec = fromOpaleyespec Opaleye.unpackspecField

108+unpackspec = Opaleye.Unpackspec $ Opaleye.PackMap $ \f ->

109+ fmap fromColumns .

110+ unwrapApplicative .

111+ htraverse (\(E a) -> WrapApplicative $ E <$> traversePrimExpr f a) .

112+ toColumns

128113{-# INLINABLE unpackspec #-}

129114

130115

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

116+valuesspec :: Table Expr a => Opaleye.ValuesspecSafe a a

117+valuesspec = Opaleye.ValuesspecSafe (toPackMap undefined) unpackspec

135118

136119

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

120+toPackMap :: Table Expr a

121+ => a -> Opaleye.PackMap Opaleye.PrimExpr Opaleye.PrimExpr () a

122+toPackMap as = Opaleye.PackMap $ \f () ->

123+ fmap fromColumns $

124+ unwrapApplicative .

125+ htraverse (\(E a) -> WrapApplicative $ E <$> traversePrimExpr f a) $

126+ toColumns as

141127

142128

143129-- | Transform a table by adding 'CAST' to all columns. This is most useful for

144130-- finalising a SELECT or RETURNING statement, guaranteed that the output

145131-- matches what is encoded in each columns TypeInformation.

146132castTable :: Table Expr a => a -> a

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

133+castTable (toColumns -> as) = fromColumns $ htabulate \i ->

134+ case hfield hspecs i of

135+ SSpec{info} ->

136+ case hfield as i of

137+ E expr ->

138+ E (scastExpr info expr)

src/Rel8/Table/Ord.hs+21−14

@@ -24,7 +24,7 @@ import GHC.Generics ( Rep )

2424import Prelude hiding ( seq )

2525

2626-- rel8

27−import Rel8.Expr ( Expr )

27+import Rel8.Expr ( Expr( E ) )

2828import Rel8.Expr.Bool ( (||.), (&&.), false, true )

2929import Rel8.Expr.Eq ( (==.) )

3030import Rel8.Expr.Ord ( (<.), (>.) )

@@ -33,9 +33,10 @@ import Rel8.Generic.Record ( Record )

3333import Rel8.Generic.Table.Record ( GTable, GColumns, gtable )

3434import Rel8.Schema.Dict ( Dict( Dict ) )

3535import Rel8.Schema.HTable ( htabulateA, hfield )

36−import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )

36+import Rel8.Schema.HTable.Identity ( HIdentity( HType ) )

3737import Rel8.Schema.Null (Sql)

38−import Rel8.Table ( Columns, toColumns, TColumns )

38+import Rel8.Schema.Spec.Constrain ( ConstrainSpec )

39+import Rel8.Table ( Columns, toColumns, TColumns, TFromExprs )

3940import Rel8.Table.Bool ( bool )

4041import Rel8.Table.Eq ( EqTable )

4142import Rel8.Type.Ord ( DBOrd )

@@ -46,14 +47,20 @@ import Rel8.Type.Ord ( DBOrd )

4647-- columns in a 'Table' have an instance of 'DBOrd'".

4748type OrdTable :: Type -> Constraint

4849class EqTable a => OrdTable a where

49− ordTable :: Columns a (Dict (Sql DBOrd))

50+ ordTable :: Columns a (Dict (ConstrainSpec (Sql DBOrd)))

5051

5152 default ordTable ::

52− ( GTable TOrdTable TColumns (Rep (Record a))

53+ ( GTable TOrdTable TColumns TFromExprs (Rep (Record a))

5354 , Columns a ~ GColumns TColumns (Rep (Record a))

5455 )

55− => Columns a (Dict (Sql DBOrd))

56− ordTable = gtable @TOrdTable @TColumns @(Rep (Record a)) table

56+ => Columns a (Dict (ConstrainSpec (Sql DBOrd)))

57+ ordTable =

58+ gtable

59+ @TOrdTable

60+ @TColumns

61+ @TFromExprs

62+ @(Rep (Record a))

63+ table

5764 where

5865 table (_ :: proxy x) = ordTable @x

5966

@@ -63,7 +70,7 @@ type instance Eval (TOrdTable a) = OrdTable a

6370

6471

6572instance Sql DBOrd a => OrdTable (Expr a) where

66− ordTable = HIdentity Dict

73+ ordTable = HType Dict

6774

6875

6976instance (OrdTable a, OrdTable b) => OrdTable (a, b)

@@ -98,7 +105,7 @@ instance

98105(toColumns -> as) <: (toColumns -> bs) =

99106 foldr @[] go false $ getConst $ htabulateA $ \field ->

100107 case (hfield as field, hfield bs field) of

101− (a, b) -> case hfield (ordTable @a) field of

108+ (E a, E b) -> case hfield (ordTable @a) field of

102109 Dict -> Const [(a <. b, a ==. b)]

103110 where

104111 go (lt, eq) a = lt ||. (eq &&. a)

@@ -111,7 +118,7 @@ infix 4 <:

111118(toColumns -> as) <=: (toColumns -> bs) =

112119 foldr @[] go true $ getConst $ htabulateA $ \field ->

113120 case (hfield as field, hfield bs field) of

114− (a, b) -> case hfield (ordTable @a) field of

121+ (E a, E b) -> case hfield (ordTable @a) field of

115122 Dict -> Const [(a <. b, a ==. b)]

116123 where

117124 go (lt, eq) a = lt ||. (eq &&. a)

@@ -124,7 +131,7 @@ infix 4 <=:

124131(toColumns -> as) >: (toColumns -> bs) =

125132 foldr @[] go false $ getConst $ htabulateA $ \field ->

126133 case (hfield as field, hfield bs field) of

127− (a, b) -> case hfield (ordTable @a) field of

134+ (E a, E b) -> case hfield (ordTable @a) field of

128135 Dict -> Const [(a >. b, a ==. b)]

129136 where

130137 go (gt, eq) a = gt ||. (eq &&. a)

@@ -137,7 +144,7 @@ infix 4 >:

137144(toColumns -> as) >=: (toColumns -> bs) =

138145 foldr @[] go true $ getConst $ htabulateA $ \field ->

139146 case (hfield as field, hfield bs field) of

140− (a, b) -> case hfield (ordTable @a) field of

147+ (E a, E b) -> case hfield (ordTable @a) field of

141148 Dict -> Const [(a >. b, a ==. b)]

142149 where

143150 go (gt, eq) a = gt ||. (eq &&. a)

@@ -146,9 +153,9 @@ infix 4 >=:

146153

147154-- | Given two 'Table's, return the table that sorts before the other.

148155least :: OrdTable a => a -> a -> a

149−least a b = bool b a (a <: b)

156+least a b = bool a b (a <: b)

150157

151158

152159-- | Given two 'Table's, return the table that sorts after the other.

153160greatest :: OrdTable a => a -> a -> a

154−greatest a b = bool b a (a >: b)

161+greatest a b = bool a b (a >: b)

src/Rel8/Table/Order.hs+6−5

@@ -16,12 +16,13 @@ import Data.Functor.Contravariant ( (>$<), contramap )

1616import Prelude

1717

1818-- rel8

19+import Rel8.Expr ( unE )

1920import Rel8.Expr.Order ( asc, desc, nullsFirst, nullsLast )

2021import Rel8.Order ( Order )

2122import Rel8.Schema.Dict ( Dict( Dict ) )

2223import Rel8.Schema.HTable (htabulateA, hfield, hspecs)

2324import Rel8.Schema.Null ( Nullity( Null, NotNull ) )

24−import Rel8.Schema.Spec ( Spec( Spec, nullity ) )

25+import Rel8.Schema.Spec ( SSpec( SSpec, nullity ) )

2526import Rel8.Table ( Columns, toColumns )

2627import Rel8.Table.Ord ( OrdTable, ordTable )

2728

@@ -31,8 +32,8 @@ import Rel8.Table.Ord ( OrdTable, ordTable )

3132ascTable :: forall a. OrdTable a => Order a

3233ascTable = contramap toColumns $ getConst $

3334 htabulateA @(Columns a) $ \field -> case hfield hspecs field of

34− Spec {nullity} -> case hfield (ordTable @a) field of

35− Dict -> Const $ (`hfield` field) >$<

35+ SSpec {nullity} -> case hfield (ordTable @a) field of

36+ Dict -> Const $ unE . (`hfield` field) >$<

3637 case nullity of

3738 Null -> nullsFirst asc

3839 NotNull -> asc

@@ -43,8 +44,8 @@ ascTable = contramap toColumns $ getConst $

4344descTable :: forall a. OrdTable a => Order a

4445descTable = contramap toColumns $ getConst $

4546 htabulateA @(Columns a) $ \field -> case hfield hspecs field of

46− Spec {nullity} -> case hfield (ordTable @a) field of

47− Dict -> Const $ (`hfield` field) >$<

47+ SSpec {nullity} -> case hfield (ordTable @a) field of

48+ Dict -> Const $ unE . (`hfield` field) >$<

4849 case nullity of

4950 Null -> nullsLast desc

5051 NotNull -> desc

src/Rel8/Table/Projection.hsdeleted−73

@@ -1,73 +0,0 @@

1−{-# language FlexibleContexts #-}

2−{-# language FlexibleInstances #-}

3−{-# language MonoLocalBinds #-}

4−{-# language MultiParamTypeClasses #-}

5−{-# language StandaloneKindSignatures #-}

6−{-# language UndecidableInstances #-}

7−

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/Rel8able.hs+10−9

@@ -20,12 +20,12 @@ import Prelude ()

2020-- rel8

2121import Rel8.Expr ( Expr )

2222import qualified Rel8.Kind.Algebra as K

23−import Rel8.Kind.Context ( Reifiable, contextSing )

2423import Rel8.Generic.Rel8able

2524 ( Rel8able, Algebra

2625 , GColumns, gfromColumns, gtoColumns

2726 , GFromExprs, gfromResult, gtoResult

2827 )

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 )

@@ -35,6 +35,7 @@ import Rel8.Table

3535 , FromExprs, fromResult, toResult

3636 , Transpose

3737 )

38+import Rel8.Schema.Spec.Constrain ( ConstrainSpec )

3839import Rel8.Table.ADT ( ADT )

3940import Rel8.Table.Eq ( EqTable, eqTable )

4041import Rel8.Table.Ord ( OrdTable, ordTable )

@@ -43,7 +44,7 @@ import Rel8.Type.Eq ( DBEq )

4344import Rel8.Type.Ord ( DBOrd )

4445

4546

46−instance (Rel8able t, Reifiable context, context ~ context') =>

47+instance (Rel8able t, Virtual context, context ~ context') =>

4748 Table context' (t context)

4849 where

4950 type Columns (t context) = GColumns t

@@ -51,8 +52,8 @@ instance (Rel8able t, Reifiable context, context ~ context') =>

5152 type FromExprs (t context) = GFromExprs t

5253 type Transpose to (t context) = t to

5354

54− fromColumns = gfromColumns contextSing

55− toColumns = gtoColumns contextSing

55+ fromColumns = gfromColumns virtual

56+ toColumns = gtoColumns virtual

5657 fromResult = gfromResult @t

5758 toResult = gtoResult @t

5859

@@ -60,22 +61,22 @@ instance (Rel8able t, Reifiable context, context ~ context') =>

6061instance

6162 ( context ~ Expr

6263 , Rel8able t

63− , HConstrainTable (Columns (t context)) (Sql DBEq)

64+ , HConstrainTable (Columns (t context)) (ConstrainSpec (Sql DBEq))

6465 )

6566 => EqTable (t context)

6667 where

67− eqTable = hdicts @(Columns (t context)) @(Sql DBEq)

68+ eqTable = hdicts @(Columns (t context)) @(ConstrainSpec (Sql DBEq))

6869

6970

7071instance

7172 ( context ~ Expr

7273 , Rel8able t

73− , HConstrainTable (Columns (t context)) (Sql DBEq)

74− , HConstrainTable (Columns (t context)) (Sql DBOrd)

74+ , HConstrainTable (Columns (t context)) (ConstrainSpec (Sql DBEq))

75+ , HConstrainTable (Columns (t context)) (ConstrainSpec (Sql DBOrd))

7576 )

7677 => OrdTable (t context)

7778 where

78− ordTable = hdicts @(Columns (t context)) @(Sql DBOrd)

79+ ordTable = hdicts @(Columns (t context)) @(ConstrainSpec (Sql DBOrd))

7980

8081

8182instance

src/Rel8/Table/Serialize.hs+10−7

@@ -16,7 +16,6 @@ module Rel8.Table.Serialize

1616where

1717

1818-- base

19−import Data.Functor.Identity ( Identity( Identity ) )

2019import Data.Kind ( Constraint, Type )

2120import Data.List.NonEmpty ( NonEmpty )

2221import Prelude

@@ -25,12 +24,12 @@ import Prelude

2524import qualified Hasql.Decoders as Hasql

2625

2726-- rel8

28−import Rel8.Expr ( Expr )

27+import Rel8.Expr ( Expr( E ) )

2928import Rel8.Expr.Serialize ( slitExpr, sparseValue )

3029import Rel8.Schema.HTable ( HTable, htabulate, htabulateA, hfield, hspecs )

3130import Rel8.Schema.Null ( NotNull, Sql )

32−import Rel8.Schema.Result ( Result )

33−import Rel8.Schema.Spec ( Spec(..) )

31+import Rel8.Schema.Result ( Result( R ) )

32+import Rel8.Schema.Spec ( SSpec(..), KnownSpec )

3433import Rel8.Table ( Table, fromColumns, FromExprs, fromResult, toResult )

3534import Rel8.Type ( DBType )

3635

@@ -116,6 +115,10 @@ instance

116115 => ToExprs x (a, b, c, d, e, f, g)

117116

118117

118+instance (KnownSpec spec, x ~ Expr spec) =>

119+ ToExprs x (Result spec)

120+

121+

119122-- | @Serializable@ witnesses the one-to-one correspondence between the type

120123-- @sql@, which contains SQL expressions, and the type @haskell@, which

121124-- contains the Haskell decoding of rows containing @sql@ SQL expressions.

@@ -138,11 +141,11 @@ parse = fromResult @_ @exprs <$> parseHTable

138141litHTable :: HTable t => t Result -> t Expr

139142litHTable as = htabulate $ \field ->

140143 case hfield hspecs field of

141− Spec {nullity, info} -> case hfield as field of

142− Identity value -> slitExpr nullity info value

144+ SSpec {nullity, info} -> case hfield as field of

145+ R value -> E (slitExpr nullity info value)

143146

144147

145148parseHTable :: HTable t => Hasql.Row (t Result)

146149parseHTable = unwrapApplicative $ htabulateA $ \field ->

147150 WrapApplicative $ case hfield hspecs field of

148− Spec {nullity, info} -> Identity <$> sparseValue nullity info

151+ SSpec {nullity, info} -> R <$> sparseValue nullity info

src/Rel8/Table/These.hs+7−27

@@ -20,7 +20,6 @@ module Rel8.Table.These

2020 , isThisTable, isThatTable, isThoseTable

2121 , hasHereTable, hasThereTable

2222 , justHereTable, justThereTable

23− , alignMaybeTable

2423 , aggregateTheseTable

2524 , nameTheseTable

2625 )

@@ -30,13 +29,13 @@ where

3029import Data.Bifunctor ( Bifunctor, bimap )

3130import Data.Kind ( Type )

3231import Data.Maybe ( isJust )

33−import Prelude hiding ( null, undefined )

32+import Prelude hiding ( undefined )

3433

3534-- rel8

3635import Rel8.Aggregate ( Aggregate )

3736import Rel8.Expr ( Expr )

38−import Rel8.Expr.Bool ( (&&.), (||.), boolExpr, not_ )

39−import Rel8.Expr.Null ( null, isNonNull )

37+import Rel8.Expr.Bool ( (&&.), not_ )

38+import Rel8.Expr.Null ( isNonNull )

4039import Rel8.Kind.Context ( Reifiable )

4140import Rel8.Schema.Context.Nullify ( Nullifiable )

4241import Rel8.Schema.Dict ( Dict( Dict ) )

@@ -61,7 +60,6 @@ import Rel8.Table.Maybe

6160 )

6261import Rel8.Table.Nullify ( Nullify, guard )

6362import Rel8.Table.Ord ( OrdTable, ordTable )

64−import Rel8.Table.Projection ( Biprojectable, Projectable, biproject, project )

6563import Rel8.Table.Serialize ( ToExprs )

6664import Rel8.Table.Undefined ( undefined )

6765import Rel8.Type.Tag ( MaybeTag )

@@ -90,18 +88,10 @@ data TheseTable context a b = TheseTable

9088 deriving stock Functor

9189

9290

93−instance Biprojectable (TheseTable context) where

94− biproject f g (TheseTable a b) = TheseTable (project f a) (project g b)

95−

96−

9791instance Nullifiable context => Bifunctor (TheseTable context) where

9892 bimap f g (TheseTable a b) = TheseTable (fmap f a) (fmap g b)

9993

10094

101−instance Projectable (TheseTable context a) where

102− project f (TheseTable a b) = TheseTable a (project f b)

103−

104−

10595instance (context ~ Expr, Table Expr a, Semigroup a) =>

10696 Apply (TheseTable context a)

10797 where

@@ -218,9 +208,9 @@ instance (EqTable a, EqTable b, context ~ Expr) =>

218208 EqTable (TheseTable context a b)

219209 where

220210 eqTable = HTheseTable

221− { hhereTag = hlabel (HIdentity Dict)

211+ { hhereTag = hlabel (HType Dict)

222212 , hhere = hlabel (eqTable @(Nullify context a))

223− , hthereTag = hlabel (HIdentity Dict)

213+ , hthereTag = hlabel (HType Dict)

224214 , hthere = hlabel (eqTable @(Nullify context b))

225215 }

226216

@@ -229,9 +219,9 @@ instance (OrdTable a, OrdTable b, context ~ Expr) =>

229219 OrdTable (TheseTable context a b)

230220 where

231221 ordTable = HTheseTable

232− { hhereTag = hlabel (HIdentity Dict)

222+ { hhereTag = hlabel (HType Dict)

233223 , hhere = hlabel (ordTable @(Nullify context a))

234− , hthereTag = hlabel (HIdentity Dict)

224+ , hthereTag = hlabel (HType Dict)

235225 , hthere = hlabel (ordTable @(Nullify context b))

236226 }

237227

@@ -289,16 +279,6 @@ justThereTable :: TheseTable context a b -> MaybeTable context b

289279justThereTable = there

290280

291281

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−

302282-- | Construct a @TheseTable@. Corresponds to 'This'.

303283thisTable :: Table Expr b => a -> TheseTable Expr a b

304284thisTable a = TheseTable (justTable a) nothingTable

src/Rel8/Table/Undefined.hs+5−5

@@ -11,16 +11,16 @@ where

1111import Prelude hiding ( undefined )

1212

1313-- rel8

14−import Rel8.Expr ( Expr )

14+import Rel8.Expr ( Expr( E ) )

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 ( Spec(..) )

18+import Rel8.Schema.Spec ( SSpec(..) )

1919import Rel8.Table ( Table, fromColumns )

2020

2121

2222undefined :: Table Expr a => a

2323undefined = fromColumns $ htabulate $ \field -> case hfield hspecs field of

24− Spec {nullity, info} -> case nullity of

25− Null -> snull info

26− NotNull -> unsafeUnnullify (snull info)

24+ SSpec {nullity, info} -> case nullity of

25+ Null -> E (snull info)

26+ NotNull -> E (unsafeUnnullify (snull info))

src/Rel8/Table/Window.hsdeleted−43

@@ -1,43 +0,0 @@

1−{-# language MonoLocalBinds #-}

2−

3−module Rel8.Table.Window

4− ( cumulative

5− , cumulative_

6− , currentRow

7− )

8−where

9−

10−-- base

11−import Prelude

12−

13−-- opaleye

14−import qualified Opaleye.Window as Opaleye

15−

16−-- rel8

17−import Rel8.Aggregate ( Aggregates )

18−import qualified Rel8.Expr.Window as Expr

19−import Rel8.Schema.HTable ( hfield, htabulateA )

20−import Rel8.Table ( fromColumns, toColumns )

21−import Rel8.Window ( Window( Window ) )

22−

23−

24−-- | 'cumulative' allows the use of aggregation functions in 'Window'

25−-- expressions. In particular, @'cumulative' 'Rel8.sum'@

26−-- (when combined with 'Rel8.Window.orderPartitionBy') gives a running total,

27−-- also known as a \"cumulative sum\", hence the name @cumulative@.

28−cumulative :: Aggregates aggregates exprs => (a -> aggregates) -> Window a exprs

29−cumulative f =

30− fmap fromColumns $

31− htabulateA $ \field ->

32− Expr.cumulative ((`hfield` field) . toColumns . f)

33−

34−

35−-- | A version of 'cumulative' for use with nullary aggregators like

36−-- 'Rel8.Expr.Aggregate.countStar'.

37−cumulative_ :: Aggregates aggregates exprs => aggregates -> Window a exprs

38−cumulative_ = cumulative . const

39−

40−

41−-- | Return every column of the current row of a window query.

42−currentRow :: Window a a

43−currentRow = Window $ Opaleye.over (Opaleye.noWindowFunction id) mempty mempty

src/Rel8/Tabulate.hsdeleted−640

@@ -1,640 +0,0 @@

1−{-# language FlexibleContexts #-}

2−{-# language MonoLocalBinds #-}

3−{-# language ScopedTypeVariables #-}

4−{-# language StandaloneKindSignatures #-}

5−{-# language TypeApplications #-}

6−{-# language TupleSections #-}

7−{-# language UndecidableInstances #-}

8−

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+8−9

@@ -1,4 +1,3 @@

1−{-# language FlexibleContexts #-}

21{-# language FlexibleInstances #-}

32{-# language MonoLocalBinds #-}

43{-# language MultiWayIf #-}

@@ -128,10 +127,10 @@ instance DBType Int64 where

128127instance DBType Float where

129128 typeInformation = TypeInformation

130129 { encode = \x -> Opaleye.ConstExpr

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

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

135134 , decode = Hasql.float4

136135 , typeName = "float4"

137136 }

@@ -141,10 +140,10 @@ instance DBType Float where

141140instance DBType Double where

142141 typeInformation = TypeInformation

143142 { encode = \x -> Opaleye.ConstExpr

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

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

148147 , decode = Hasql.float8

149148 , typeName = "float8"

150149 }

src/Rel8/Type/Composite.hs+8−9

@@ -20,7 +20,6 @@ where

2020

2121-- base

2222import Data.Functor.Const ( Const( Const ), getConst )

23−import Data.Functor.Identity ( Identity( Identity ) )

2423import Data.Kind ( Constraint, Type )

2524import Prelude

2625

@@ -31,13 +30,13 @@ import qualified Hasql.Decoders as Hasql

3130import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye

3231

3332-- rel8

34−import Rel8.Expr ( Expr )

33+import Rel8.Expr ( Expr( E ) )

3534import Rel8.Expr.Opaleye ( castExpr, fromPrimExpr, toPrimExpr )

3635import Rel8.Schema.HTable ( HTable, hfield, hspecs, htabulate, htabulateA )

37−import Rel8.Schema.Name ( Name( Name ) )

36+import Rel8.Schema.Name ( Name( N, Name ) )

3837import Rel8.Schema.Null ( Nullity( Null, NotNull ) )

39−import Rel8.Schema.Result ( Result )

40−import Rel8.Schema.Spec ( Spec( Spec, nullity, info ) )

38+import Rel8.Schema.Result ( Result( R ) )

39+import Rel8.Schema.Spec ( SSpec( SSpec, nullity, info ) )

4140import Rel8.Table ( fromColumns, toColumns, fromResult, toResult )

4241import Rel8.Table.Eq ( EqTable )

4342import Rel8.Table.HKD ( HKD, HKDable )

@@ -113,8 +112,8 @@ compose = castExpr . fromPrimExpr . encoder . toColumns

113112decompose :: forall a. DBComposite a => Expr a -> HKD a Expr

114113decompose (toPrimExpr -> a) = fromColumns $ htabulate \field ->

115114 case hfield names field of

116− Name name -> case hfield hspecs field of

117− Spec {} -> fromPrimExpr $ Opaleye.CompositeExpr a name

115+ N (Name name) -> case hfield hspecs field of

116+ SSpec {} -> E $ fromPrimExpr $ Opaleye.CompositeExpr a name

118117 where

119118 names = toColumns (compositeFields @a)

120119

@@ -122,7 +121,7 @@ decompose (toPrimExpr -> a) = fromColumns $ htabulate \field ->

122121decoder :: HTable t => Hasql.Composite (t Result)

123122decoder = unwrapApplicative $ htabulateA \field ->

124123 case hfield hspecs field of

125− Spec {nullity, info} -> WrapApplicative $ Identity <$>

124+ SSpec {nullity, info} -> WrapApplicative $ R <$>

126125 case nullity of

127126 Null -> Hasql.field $ Hasql.nullable $ decode info

128127 NotNull -> Hasql.field $ Hasql.nonNullable $ decode info

@@ -132,4 +131,4 @@ encoder :: HTable t => t Expr -> Opaleye.PrimExpr

132131encoder a = Opaleye.FunExpr "ROW" exprs

133132 where

134133 exprs = getConst $ htabulateA \field -> case hfield a field of

135− expr -> Const [toPrimExpr expr]

134+ E (toPrimExpr -> expr) -> Const [expr]

src/Rel8/Type/Enum.hs−1

@@ -106,7 +106,6 @@ 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

110109class (Generic a, GEnumable (Rep a)) => Enumable a

111110instance (Generic a, GEnumable (Rep a)) => Enumable a

112111

src/Rel8/Type/JSONBEncoded.hs−4

@@ -1,5 +1,3 @@

1−{-# language StandaloneKindSignatures #-}

2−

31module Rel8.Type.JSONBEncoded ( JSONBEncoded(..) ) where

53-- aeson

@@ -8,7 +6,6 @@ import Data.Aeson.Types ( parseEither )

97-- base

108import Data.Bifunctor ( first )

11−import Data.Kind ( Type )

129import Prelude

1310

1411-- hasql

@@ -23,7 +20,6 @@ import Data.Text ( pack )

2320

2421

2522-- | Like 'Rel8.JSONEncoded', but works for @jsonb@ columns.

26−type JSONBEncoded :: Type -> Type

2723newtype JSONBEncoded a = JSONBEncoded { fromJSONBEncoded :: a }

2824

2925

src/Rel8/Type/JSONEncoded.hs−4

@@ -1,5 +1,3 @@

1−{-# language StandaloneKindSignatures #-}

2−

31module Rel8.Type.JSONEncoded ( JSONEncoded(..) ) where

53-- aeson

@@ -7,7 +5,6 @@ import Data.Aeson ( FromJSON, ToJSON, parseJSON, toJSON )

75import Data.Aeson.Types ( parseEither )

97-- base

10−import Data.Kind ( Type )

118import Prelude

129

1310-- rel8

@@ -18,7 +15,6 @@ import Rel8.Type.Information ( parseTypeInformation )

1815-- | A deriving-via helper type for column types that store a Haskell value

1916-- using a JSON encoding described by @aeson@'s 'ToJSON' and 'FromJSON' type

2017-- classes.

21−type JSONEncoded :: Type -> Type

2218newtype JSONEncoded a = JSONEncoded { fromJSONEncoded :: a }

2319

2420

src/Rel8/Type/Num.hs+1−4

@@ -18,7 +18,6 @@ import Prelude

1818

1919-- rel8

2020import Rel8.Type ( DBType )

21−import Rel8.Type.Ord ( DBOrd )

2221

2322-- scientific

2423import Data.Scientific ( Scientific )

@@ -40,14 +39,13 @@ instance DBNum Scientific

4039-- expressions. This is a Rel8 concept, and allows us to provide

4140-- 'fromIntegral'.

4241type DBIntegral :: Type -> Constraint

43−class (DBNum a, DBOrd a) => DBIntegral a

42+class DBNum a => DBIntegral a

4443instance DBIntegral Int16

4544instance DBIntegral Int32

4645instance DBIntegral Int64

4746

4847

4948-- | The class of database types that support the @/@ operator.

50−type DBFractional :: Type -> Constraint

5149class DBNum a => DBFractional a

5250instance DBFractional Float

5351instance DBFractional Double

@@ -55,7 +53,6 @@ instance DBFractional Scientific

5553

5654

5755-- | The class of database types that support the @/@ operator.

58−type DBFloating :: Type -> Constraint

5956class DBFractional a => DBFloating a

6057instance DBFloating Float

6158instance DBFloating Double

src/Rel8/Type/Ord.hs+2

@@ -75,6 +75,7 @@ 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

7879instance DBMax Char

7980instance DBMax Int16

8081instance DBMax Int32

@@ -100,6 +101,7 @@ instance Sql DBMax a => DBMax (NonEmpty a)

100101-- | The class of database types that support the @min@ aggregation function.

101102type DBMin :: Type -> Constraint

102103class DBOrd a => DBMin a

104+instance DBMin Bool

103105instance DBMin Char

104106instance DBMin Int16

105107instance DBMin Int32

src/Rel8/Type/ReadShow.hs−3

@@ -1,12 +1,10 @@

11{-# language ScopedTypeVariables #-}

2−{-# language StandaloneKindSignatures #-}

32{-# language TypeApplications #-}

43{-# language ViewPatterns #-}

65module Rel8.Type.ReadShow ( ReadShow(..) ) where

87-- base

9−import Data.Kind ( Type )

108import Data.Proxy ( Proxy( Proxy ) )

119import Data.Typeable ( Typeable, typeRep )

1210import Prelude

@@ -22,7 +20,6 @@ import qualified Data.Text as Text

2220

2321-- | A deriving-via helper type for column types that store a Haskell value

2422-- using a Haskell's 'Read' and 'Show' type classes.

25−type ReadShow :: Type -> Type

2623newtype ReadShow a = ReadShow { fromReadShow :: a }

2724

2825

src/Rel8/Type/Tag.hs−1

@@ -90,7 +90,6 @@ instance DBMonoid MaybeTag where

9090 memptyExpr = litExpr mempty

9191

9292

93−type Tag :: Type

9493newtype Tag = Tag Text

9594 deriving newtype

9695 ( Eq, Ord, Read, Show

src/Rel8/Window.hsdeleted−97

@@ -1,97 +0,0 @@

1−{-# language DerivingVia #-}

2−{-# language FlexibleContexts #-}

3−{-# language GeneralizedNewtypeDeriving #-}

4−{-# language ScopedTypeVariables #-}

5−{-# language StandaloneKindSignatures #-}

6−{-# language TypeApplications #-}

7−

8−module Rel8.Window

9− ( Window(..)

10− , Partition

11− , over

12− , partitionBy

13− , orderPartitionBy

14− )

15−where

16−

17−-- base

18−import Data.Functor.Const ( Const( Const ), getConst )

19−import Data.Functor.Contravariant ( Contravariant, contramap )

20−import Data.Kind ( Type )

21−import Prelude

22−

23−-- opaleye

24−import qualified Opaleye.Internal.Window as Opaleye

25−import qualified Opaleye.Internal.PackMap as Opaleye

26−

27−-- profunctors

28−import Data.Profunctor ( Profunctor )

29−

30−-- product-profunctors

31−import Data.Profunctor.Product ( ProductProfunctor, (****), purePP )

32−

33−-- rel8

34−import Rel8.Expr.Opaleye ( toColumn, toPrimExpr )

35−import Rel8.Order( Order( Order ) )

36−import Rel8.Schema.HTable ( hfield, htabulateA )

37−import Rel8.Table ( Columns, toColumns )

38−import Rel8.Table.Eq ( EqTable )

39−

40−-- semigroupoids

41−import Data.Functor.Apply ( Apply, WrappedApplicative(..) )

42−

43−

44−-- | 'Window' is an applicative functor that represents expressions that

45−-- contain

46−-- [window functions](https://www.postgresql.org/docs/current/tutorial-window.html).

47−-- 'Rel8.Query.Window.window' can be used to

48−-- evaluate these expressions over a particular query.

49−type Window :: Type -> Type -> Type

50−newtype Window a b = Window (Opaleye.Windows a b)

51− deriving newtype (Profunctor)

52− deriving newtype (Functor, Applicative)

53− deriving (Apply) via (WrappedApplicative (Window a))

54−

55−

56−instance ProductProfunctor Window where

57− purePP = pure

58− (****) = (<*>)

59−

60−

61−-- | In PostgreSQL, window functions must specify the \"window\" or

62−-- \"partition\" over which they operate. The syntax for this looks like:

63−-- @SUM(salary) OVER (PARTITION BY department)@. The Rel8 type 'Partition'

64−-- represents everything that comes after @OVER@.

65−--

66−-- 'Partition' is a 'Monoid', so 'Window's created with 'partitionBy' and

67−-- 'orderWindowBy' can be combined using '<>'.

68−type Partition :: Type -> Type

69−newtype Partition a = Partition (Opaleye.Window a)

70− deriving newtype (Contravariant, Semigroup, Monoid)

71−

72−

73−-- | 'over' adds a 'Partition' to a 'Window' expression.

74−--

75−-- @@@

76−-- 'Rel8.Table.Window.cumulative' ('Rel8.Expr.Aggregate.sum' . salary) `over` 'partitionBy' department <> 'orderPartitionBy' (salary >$< 'Rel8.desc')

77−-- @@@

78−over :: Window a b -> Partition a -> Window a b

79−over (Window (Opaleye.Windows (Opaleye.PackMap w))) (Partition p) =

80− Window $ Opaleye.Windows $ Opaleye.PackMap $ \f ->

81− w (\(o, p') -> f (o, p' <> p))

82−infixl 1 `over`

83−

84−

85−-- | Restricts a window function to operate only the group of rows that share

86−-- the same value(s) for the given expression(s).

87−partitionBy :: forall b a. EqTable b => (a -> b) -> Partition a

88−partitionBy f =

89− Partition $ contramap (toColumns . f) $ getConst $

90− htabulateA @(Columns b) $ \field ->

91− Const $ Opaleye.partitionBy (toColumn . toPrimExpr . (`hfield` field))

92−

93−

94−-- | Controls the order in which rows are processed by window functions. This

95−-- does not need to match the ordering of the overall query.

96−orderPartitionBy :: Order a -> Partition a

97−orderPartitionBy (Order ordering) = Partition $ Opaleye.orderPartitionBy ordering

tests/Main.hs+178−288

@@ -1,11 +1,12 @@

1−{-# language BangPatterns #-}

21{-# language BlockArguments #-}

2+{-# language DataKinds #-}

33{-# language DeriveAnyClass #-}

44{-# language DeriveGeneric #-}

55{-# language DerivingStrategies #-}

6+{-# language DisambiguateRecordFields #-}

67{-# language FlexibleContexts #-}

78{-# language FlexibleInstances #-}

8−{-# language MonoLocalBinds #-}

9+{-# language GADTs #-}

910{-# language NamedFieldPuns #-}

1011{-# language OverloadedStrings #-}

1112{-# language RecordWildCards #-}

@@ -13,15 +14,17 @@

1314{-# language StandaloneDeriving #-}

1415{-# language TypeApplications #-}

1516

17+{-# options_ghc -fno-warn-redundant-constraints #-}

18+

1619module Main

1720 ( main

1821 )

1922where

2023

2124-- base

22−import Control.Applicative ( empty, liftA2, liftA3 )

23−import Control.Exception ( bracket, throwIO )

24−import Control.Monad ( (>=>), void )

25+import Control.Applicative ( liftA2, liftA3 )

26+import Control.Monad (void)

27+import Control.Monad.IO.Class ( MonadIO, liftIO )

2528import Data.Bifunctor ( bimap )

2629import Data.Foldable ( for_ )

2730import Data.Int ( Int32, Int64 )

@@ -35,27 +38,25 @@ import GHC.Generics ( Generic )

3538import qualified Data.ByteString.Lazy

3639

3740-- case-insensitive

38−import Data.CaseInsensitive ( mk )

41+import Data.CaseInsensitive (mk)

3942

4043-- containers

41−import Data.Containers.ListUtils ( nubOrdOn )

4244import qualified Data.Map.Strict as Map

4345

4446-- hasql

45−import Hasql.Connection ( Connection, acquire, release )

47+import Hasql.Connection ( Connection, acquire, release )

4648import Hasql.Session ( sql, run )

4749

48−-- hasql-transaction

49−import Hasql.Transaction ( Transaction, condemn, statement )

50−import qualified Hasql.Transaction.Sessions as Hasql

51−

5250-- hedgehog

5351import Hedgehog ( property, (===), forAll, cover, diff, evalM, PropertyT, TestT, test, Gen )

5452import qualified Hedgehog.Gen as Gen

5553import qualified Hedgehog.Range as Range

5654

57−-- mmorph

58−import Control.Monad.Morph ( hoist )

55+-- lifted-base

56+import Control.Exception.Lifted ( bracket, throwIO, bracket_ )

57+

58+-- monad-control

59+import Control.Monad.Trans.Control ( MonadBaseControl )

5960

6061-- rel8

6162import Rel8 ( Result )

@@ -71,16 +72,12 @@ import Test.Tasty

7172import Test.Tasty.Hedgehog ( testProperty )

7273

7374-- text

74−import Data.Text ( Text, pack, unpack )

75+import Data.Text (Text, pack)

7576import 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−

8481-- tmp-postgres

8582import qualified Database.Postgres.Temp as TmpPostgres

8683

@@ -116,13 +113,11 @@ tests =

116113 , testCatMaybeTable getTestDatabase

117114 , testCatMaybe getTestDatabase

118115 , testMaybeTable getTestDatabase

119− , testAggregateMaybeTable getTestDatabase

120116 , testNestedTables getTestDatabase

121117 , testMaybeTableApplicative getTestDatabase

122118 , testLogicalFixities getTestDatabase

123119 , testUpdate getTestDatabase

124120 , testDelete getTestDatabase

125− , testUpsert getTestDatabase

126121 , testSelectNestedPairs getTestDatabase

127122 , testSelectArray getTestDatabase

128123 , testNestedMaybeTable getTestDatabase

@@ -138,7 +133,6 @@ tests =

138133 flip run conn do

139134 sql "CREATE EXTENSION citext"

140135 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 )"

142136 sql "CREATE SEQUENCE test_seq"

143137

144138 return db

@@ -146,21 +140,19 @@ tests =

146140 stopTestDatabase = TmpPostgres.stop

147141

148142

149−connect :: TmpPostgres.DB -> IO Connection

150−connect = acquire . TmpPostgres.toConnectionString >=> either (maybe empty (fail . unpack . decodeUtf8)) pure

151−

152−

153143databasePropertyTest

154144 :: TestName

155− -> ((TestT Transaction () -> PropertyT IO ()) -> PropertyT IO ())

145+ -> (((Connection -> TestT IO ()) -> PropertyT IO ()) -> PropertyT IO ())

156146 -> IO TmpPostgres.DB -> TestTree

157147databasePropertyTest testName f getTestDatabase =

158− withResource (connect =<< getTestDatabase) release $ \c ->

148+ withResource connect release $ \c ->

159149 testProperty testName $ property do

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

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

164156

165157

166158data TestTable f = TestTable

@@ -192,17 +184,18 @@ testSelectTestTable :: IO TmpPostgres.DB -> TestTree

192184testSelectTestTable = databasePropertyTest "Can SELECT TestTable" \transaction -> do

193185 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable

194186

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− }

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+ }

203196

204− statement () $ Rel8.select do

205− Rel8.each testTableSchema

197+ selected <- liftIO $ Rel8.select connection do

198+ Rel8.each testTableSchema

206199

207200 sort selected === sort rows

208201

@@ -219,12 +212,11 @@ testWhere_ = databasePropertyTest "WHERE (Rel8.where_)" \transaction -> do

219212

220213 let expected = filter (\t -> testTableColumn2 t == magicBool) rows

221214

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

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

228220

229221 sort selected === sort expected

230222

@@ -237,12 +229,11 @@ testFilter :: IO TmpPostgres.DB -> TestTree

237229testFilter = databasePropertyTest "filter" \transaction -> do

238230 rows <- forAll $ Gen.list (Range.linear 1 10) genTestTable

239231

240− transaction do

232+ transaction \connection -> do

241233 let expected = filter testTableColumn2 rows

242234

243− selected <- lift do

244− statement () $ Rel8.select do

245− Rel8.filter testTableColumn2 =<< Rel8.values (Rel8.lit <$> rows)

235+ selected <- liftIO $ Rel8.select connection

236+ $ Rel8.filter testTableColumn2 =<< Rel8.values (Rel8.lit <$> rows)

246237

247238 sort selected === sort expected

248239

@@ -257,10 +248,9 @@ testLimit = databasePropertyTest "LIMIT (Rel8.limit)" \transaction -> do

257248

258249 n <- forAll $ Gen.integral (Range.linear 0 10)

259250

260− transaction do

261− selected <- lift do

262− statement () $ Rel8.select do

263− Rel8.limit n $ Rel8.values (Rel8.lit <$> rows)

251+ transaction \connection -> do

252+ selected <- liftIO $ Rel8.select connection do

253+ Rel8.limit n $ Rel8.values (Rel8.lit <$> rows)

264254

265255 diff (length selected) (<=) (fromIntegral n)

266256

@@ -278,10 +268,9 @@ testUnion = databasePropertyTest "UNION (Rel8.union)" \transaction -> evalM do

278268 left <- forAll $ Gen.list (Range.linear 0 10) genTestTable

279269 right <- forAll $ Gen.list (Range.linear 0 10) genTestTable

280270

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)

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)

285274

286275 sort selected === sort (nub (left ++ right))

287276

@@ -290,11 +279,9 @@ testDistinct :: IO TmpPostgres.DB -> TestTree

290279testDistinct = databasePropertyTest "DISTINCT (Rel8.distinct)" \transaction -> do

291280 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable

292281

293− transaction do

294− selected <- lift do

295− statement () $ Rel8.select do

296− Rel8.distinct do

297− Rel8.values (Rel8.lit <$> rows)

282+ transaction \connection -> do

283+ selected <- liftIO $ Rel8.select connection $ Rel8.distinct do

284+ Rel8.values (Rel8.lit <$> rows)

298285

299286 sort selected === nub (sort rows)

300287

@@ -307,10 +294,8 @@ testExists :: IO TmpPostgres.DB -> TestTree

307294testExists = databasePropertyTest "EXISTS (Rel8.exists)" \transaction -> do

308295 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable

309296

310− transaction do

311− exists <- lift do

312− statement () $ Rel8.select do

313− Rel8.exists $ Rel8.values $ Rel8.lit <$> rows

297+ transaction \connection -> do

298+ exists <- liftIO $ Rel8.select connection $ Rel8.exists $ Rel8.values $ Rel8.lit <$> rows

314299

315300 case rows of

316301 [] -> exists === [False]

@@ -321,10 +306,9 @@ testOptional :: IO TmpPostgres.DB -> TestTree

321306testOptional = databasePropertyTest "Rel8.optional" \transaction -> do

322307 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable

323308

324− transaction do

325− selected <- lift do

326− statement () $ Rel8.select do

327− Rel8.optional $ Rel8.values (Rel8.lit <$> rows)

309+ transaction \connection -> do

310+ selected <- liftIO $ Rel8.select connection do

311+ Rel8.optional $ Rel8.values (Rel8.lit <$> rows)

328312

329313 case rows of

330314 [] -> selected === [Nothing]

@@ -335,10 +319,9 @@ testAnd :: IO TmpPostgres.DB -> TestTree

335319testAnd = databasePropertyTest "AND (&&.)" \transaction -> do

336320 (x, y) <- forAll $ liftA2 (,) Gen.bool Gen.bool

337321

338− transaction do

339− [result] <- lift do

340− statement () $ Rel8.select do

341− pure $ Rel8.lit x Rel8.&&. Rel8.lit y

322+ transaction \connection -> do

323+ [result] <- liftIO $ Rel8.select connection $ pure $

324+ Rel8.lit x Rel8.&&. Rel8.lit y

342325

343326 result === (x && y)

344327

@@ -347,10 +330,9 @@ testOr :: IO TmpPostgres.DB -> TestTree

347330testOr = databasePropertyTest "OR (||.)" \transaction -> do

348331 (x, y) <- forAll $ liftA2 (,) Gen.bool Gen.bool

349332

350− transaction do

351− [result] <- lift do

352− statement () $ Rel8.select $ pure $

353− Rel8.lit x Rel8.||. Rel8.lit y

333+ transaction \connection -> do

334+ [result] <- liftIO $ Rel8.select connection $ pure $

335+ Rel8.lit x Rel8.||. Rel8.lit y

354336

355337 result === (x || y)

356338

@@ -359,10 +341,9 @@ testLogicalFixities :: IO TmpPostgres.DB -> TestTree

359341testLogicalFixities = databasePropertyTest "Logical operator fixities" \transaction -> do

360342 (u, v, w, x) <- forAll $ (,,,) <$> Gen.bool <*> Gen.bool <*> Gen.bool <*> Gen.bool

361343

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

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

366347

367348 result === (u || v && w == x)

368349

@@ -371,10 +352,9 @@ testNot :: IO TmpPostgres.DB -> TestTree

371352testNot = databasePropertyTest "NOT (not_)" \transaction -> do

372353 x <- forAll Gen.bool

373354

374− transaction do

375− [result] <- lift do

376− statement () $ Rel8.select do

377− pure $ Rel8.not_ $ Rel8.lit x

355+ transaction \connection -> do

356+ [result] <- liftIO $ Rel8.select connection $ pure $

357+ Rel8.not_ $ Rel8.lit x

378358

379359 result === not x

380360

@@ -383,10 +363,9 @@ testBool :: IO TmpPostgres.DB -> TestTree

383363testBool = databasePropertyTest "ifThenElse_" \transaction -> do

384364 (x, y, z) <- forAll $ liftA3 (,,) Gen.bool Gen.bool Gen.bool

385365

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)

366+ transaction \connection -> do

367+ [result] <- liftIO $ Rel8.select connection $ pure $

368+ Rel8.bool (Rel8.lit z) (Rel8.lit y) (Rel8.lit x)

390369

391370 result === if x then y else z

392371

@@ -398,10 +377,9 @@ testAp = databasePropertyTest "Cartesian product (<*>)" \transaction -> do

398377 (Gen.list (Range.linear 1 10) genTestTable)

399378 (Gen.list (Range.linear 1 10) genTestTable)

400379

401− transaction do

402− result <- lift do

403− statement () $ Rel8.select do

404− liftA2 (,) (Rel8.values (Rel8.lit <$> rows1)) (Rel8.values (Rel8.lit <$> rows2))

380+ transaction \connection -> do

381+ result <- liftIO $ Rel8.select connection $ do

382+ liftA2 (,) (Rel8.values (Rel8.lit <$> rows1)) (Rel8.values (Rel8.lit <$> rows2))

405383

406384 sort result === sort (liftA2 (,) rows1 rows2)

407385

@@ -430,22 +408,21 @@ testDBType getTestDatabase = testGroup "DBType instances"

430408 where

431409 dbTypeTest :: (Eq a, Show a, Rel8.DBType a) => TestName -> Gen a -> TestTree

432410 dbTypeTest name generator = testGroup name

433− [ databasePropertyTest name (t generator) getTestDatabase

434− , databasePropertyTest ("Maybe " <> name) (t (Gen.maybe generator)) getTestDatabase

411+ [ databasePropertyTest name (t (==) generator) getTestDatabase

412+ , databasePropertyTest ("Maybe " <> name) (t (==) (Gen.maybe generator)) getTestDatabase

435413 ]

436414

437− t :: forall a b. (Eq a, Show a, Rel8.Sql Rel8.DBType a)

438− => Gen a

439− -> (TestT Transaction () -> PropertyT IO b)

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)

440419 -> PropertyT IO b

441− t generator transaction = do

420+ t eq generator transaction = do

442421 x <- forAll generator

443422

444− transaction do

445− [res] <- lift do

446− statement () $ Rel8.select do

447− pure (Rel8.litExpr x)

448− diff res (==) x

423+ transaction \connection -> do

424+ [res] <- liftIO $ Rel8.select connection $ pure (Rel8.litExpr x)

425+ diff res eq x

449426

450427 genDay :: Gen Day

451428 genDay = do

@@ -487,15 +464,13 @@ testDBEq getTestDatabase = testGroup "DBEq instances"

487464

488465 t :: forall a. (Eq a, Show a, Rel8.Sql Rel8.DBEq a)

489466 => Gen a

490− -> (TestT Transaction () -> PropertyT IO ())

467+ -> ((Connection -> TestT IO ()) -> PropertyT IO ())

491468 -> PropertyT IO ()

492469 t generator transaction = do

493470 (x, y) <- forAll (liftA2 (,) generator generator)

494471

495− transaction do

496− [res] <- lift do

497− statement () $ Rel8.select do

498− pure $ Rel8.litExpr x Rel8.==. Rel8.litExpr y

472+ transaction \connection -> do

473+ [res] <- liftIO $ Rel8.select connection $ pure $ Rel8.litExpr x Rel8.==. Rel8.litExpr y

499474 res === (x == y)

500475

501476

@@ -503,10 +478,9 @@ testTableEquality :: IO TmpPostgres.DB -> TestTree

503478testTableEquality = databasePropertyTest "TestTable equality" \transaction -> do

504479 (x, y) <- forAll $ liftA2 (,) genTestTable genTestTable

505480

506− transaction do

507− [eq] <- lift do

508− statement () $ Rel8.select do

509− pure $ Rel8.lit x Rel8.==: Rel8.lit y

481+ transaction \connection -> do

482+ [eq] <- liftIO $ Rel8.select connection do

483+ pure $ Rel8.lit x Rel8.==: Rel8.lit y

510484

511485 eq === (x == y)

512486

@@ -515,10 +489,8 @@ testFromString :: IO TmpPostgres.DB -> TestTree

515489testFromString = databasePropertyTest "FromString" \transaction -> do

516490 str <- forAll $ Gen.list (Range.linear 0 10) Gen.unicode

517491

518− transaction do

519− [result] <- lift do

520− statement () $ Rel8.select do

521− pure $ fromString str

492+ transaction \connection -> do

493+ [result] <- liftIO $ Rel8.select connection $ pure $ fromString str

522494 result === pack str

523495

524496

@@ -526,11 +498,10 @@ testCatMaybeTable :: IO TmpPostgres.DB -> TestTree

526498testCatMaybeTable = databasePropertyTest "catMaybeTable" \transaction -> do

527499 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable

528500

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)

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)

534505

535506 sort selected === sort (filter testTableColumn2 rows)

536507

@@ -539,10 +510,9 @@ testCatMaybe :: IO TmpPostgres.DB -> TestTree

539510testCatMaybe = databasePropertyTest "catMaybe" \transaction -> evalM do

540511 rows <- forAll $ Gen.list (Range.linear 0 10) $ Gen.maybe Gen.bool

541512

542− transaction do

543− selected <- lift do

544− statement () $ Rel8.select do

545− Rel8.catNull =<< Rel8.values (map Rel8.lit rows)

513+ transaction \connection -> do

514+ selected <- evalM $ liftIO $ Rel8.select connection do

515+ Rel8.catNull =<< Rel8.values (map Rel8.lit rows)

546516

547517 sort selected === sort (catMaybes rows)

548518

@@ -551,38 +521,15 @@ testMaybeTable :: IO TmpPostgres.DB -> TestTree

551521testMaybeTable = databasePropertyTest "maybeTable" \transaction -> evalM do

552522 (rows, def) <- forAll $ liftA2 (,) (Gen.list (Range.linear 0 10) genTestTable) genTestTable

553523

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))

524+ transaction \connection -> do

525+ selected <- liftIO $ Rel8.select connection $

526+ Rel8.maybeTable (Rel8.lit def) id <$> Rel8.optional (Rel8.values (Rel8.lit <$> rows))

558527

559528 case rows of

560529 [] -> selected === [def]

561530 _ -> sort selected === sort rows

562531

563532

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−

586533data TwoTestTables f =

587534 TwoTestTables

588535 { testTable1 :: TestTable f

@@ -603,10 +550,9 @@ testNestedTables = databasePropertyTest "Nested TestTables" \transaction -> eval

603550 Gen.list (Range.linear 0 10) $

604551 liftA2 TwoTestTables genTestTable genTestTable

605552

606− transaction do

607− selected <- lift do

608− statement () $ Rel8.select do

609− Rel8.values (Rel8.lit <$> rows)

553+ transaction \connection -> do

554+ selected <- liftIO $ Rel8.select connection do

555+ Rel8.values (Rel8.lit <$> rows)

610556

611557 sort selected === sort rows

612558

@@ -616,12 +562,11 @@ testMaybeTableApplicative = databasePropertyTest "MaybeTable (<*>)" \transaction

616562 rows1 <- genRows

617563 rows2 <- genRows

618564

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

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

625570

626571 case (rows1, rows2) of

627572 ([], []) -> selected === [Nothing]

@@ -633,6 +578,14 @@ testMaybeTableApplicative = databasePropertyTest "MaybeTable (<*>)" \transaction

633578 genRows = forAll do

634579 Gen.list (Range.linear 0 10) $ liftA2 TestTable (Gen.text (Range.linear 0 10) Gen.unicode) (pure True)

635580

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+

636589

637590genTestTable :: Gen (TestTable Result)

638591genTestTable = do

@@ -645,19 +598,19 @@ testUpdate :: IO TmpPostgres.DB -> TestTree

645598testUpdate = databasePropertyTest "Can UPDATE TestTable" \transaction -> do

646599 rows <- forAll $ Gen.map (Range.linear 0 5) $ liftA2 (,) genTestTable genTestTable

647600

648− transaction do

649− selected <- lift do

650− statement () $ Rel8.insert Rel8.Insert

601+ transaction \connection -> do

602+ void $ liftIO $ Rel8.insert connection

603+ Rel8.Insert

651604 { into = testTableSchema

652− , rows = Rel8.values $ map Rel8.lit $ Map.keys rows

605+ , rows = map Rel8.lit $ Map.keys rows

653606 , onConflict = Rel8.DoNothing

654− , returning = pure ()

607+ , returning = Rel8.NumberOfRowsAffected

655608 }

656609

657− statement () $ Rel8.update Rel8.Update

610+ void $ liftIO $ Rel8.update connection

611+ Rel8.Update

658612 { target = testTableSchema

659− , from = pure ()

660− , set = \_ r ->

613+ , set = \r ->

661614 let updates = map (bimap Rel8.lit Rel8.lit) $ Map.toList rows

662615 in

663616 foldl

@@ -671,12 +624,12 @@ testUpdate = databasePropertyTest "Can UPDATE TestTable" \transaction -> do

671624 )

672625 r

673626 updates

674− , updateWhere = \_ _ -> Rel8.lit True

675− , returning = pure ()

627+ , updateWhere = \_ -> Rel8.lit True

628+ , returning = Rel8.NumberOfRowsAffected

676629 }

677630

678− statement () $ Rel8.select do

679− Rel8.each testTableSchema

631+ selected <- liftIO $ Rel8.select connection do

632+ Rel8.each testTableSchema

680633

681634 sort selected === sort (Map.elems rows)

682635

@@ -689,96 +642,29 @@ testDelete :: IO TmpPostgres.DB -> TestTree

689642testDelete = databasePropertyTest "Can DELETE TestTable" \transaction -> do

690643 rows <- forAll $ Gen.list (Range.linear 0 5) genTestTable

691644

692− transaction do

693− (deleted, selected) <- lift do

694− statement () $ Rel8.insert Rel8.Insert

645+ transaction \connection -> do

646+ void $ liftIO $ Rel8.insert connection

647+ Rel8.Insert

695648 { into = testTableSchema

696− , rows = Rel8.values $ map Rel8.lit rows

649+ , rows = map Rel8.lit rows

697650 , onConflict = Rel8.DoNothing

698− , returning = pure ()

651+ , returning = Rel8.NumberOfRowsAffected

699652 }

700653

701− deleted <- statement () $ Rel8.delete Rel8.Delete

654+ deleted <-

655+ liftIO $ Rel8.delete connection

656+ Rel8.Delete

702657 { from = testTableSchema

703− , using = pure ()

704− , deleteWhere = const testTableColumn2

658+ , deleteWhere = testTableColumn2

705659 , returning = Rel8.Projection id

706660 }

707661

708− selected <- statement () $ Rel8.select do

709− Rel8.each testTableSchema

710−

711− pure (deleted, selected)

662+ selected <- liftIO $ Rel8.select connection do

663+ Rel8.each testTableSchema

712664

713665 sort (deleted <> selected) === sort rows

714666

715667

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−

782668newtype HKNestedPair f = HKNestedPair { pairOne :: (TestTable f, TestTable f) }

783669 deriving stock Generic

784670 deriving anyclass Rel8.Rel8able

@@ -792,10 +678,9 @@ testSelectNestedPairs :: IO TmpPostgres.DB -> TestTree

792678testSelectNestedPairs = databasePropertyTest "Can SELECT nested pairs" \transaction -> do

793679 rows <- forAll $ Gen.list (Range.linear 0 10) $ HKNestedPair <$> liftA2 (,) genTestTable genTestTable

794680

795− transaction do

796− selected <- lift do

797− statement () $ Rel8.select do

798− Rel8.values $ map Rel8.lit rows

681+ transaction \connection -> do

682+ selected <- liftIO $ Rel8.select connection do

683+ Rel8.values $ map Rel8.lit rows

799684

800685 sort selected === sort rows

801686

@@ -804,20 +689,18 @@ testSelectArray :: IO TmpPostgres.DB -> TestTree

804689testSelectArray = databasePropertyTest "Can SELECT Arrays (with aggregation)" \transaction -> do

805690 rows <- forAll $ Gen.list (Range.linear 1 10) Gen.bool

806691

807− transaction do

808− selected <- lift do

809− statement () $ Rel8.select do

810− Rel8.many $ Rel8.values (map Rel8.lit rows)

692+ transaction \connection -> do

693+ selected <- liftIO $ Rel8.select connection do

694+ Rel8.many $ Rel8.values (map Rel8.lit rows)

811695

812696 selected === [foldMap pure rows]

813697

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)

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)

821704

822705 selected' === liftA2 (,) rows rows

823706

@@ -839,11 +722,10 @@ testNestedMaybeTable :: IO TmpPostgres.DB -> TestTree

839722testNestedMaybeTable = databasePropertyTest "Can nest MaybeTable within other tables" \transaction -> do

840723 let example = NestedMaybeTable { nmt1 = True, nmt2 = Just (TestTable "Hi" True) }

841724

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)

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)

847729

848730 selected === [True]

849731

@@ -851,12 +733,11 @@ testNestedMaybeTable = databasePropertyTest "Can nest MaybeTable within other ta

851733testEvaluate :: IO TmpPostgres.DB -> TestTree

852734testEvaluate = databasePropertyTest "evaluate has the evaluation order we expect" \transaction -> do

853735

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))

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))

860741

861742 normalize selected ===

862743 [ ('a', (0, 0))

@@ -864,12 +745,11 @@ testEvaluate = databasePropertyTest "evaluate has the evaluation order we expect

864745 , ('c', (2, 2))

865746 ]

866747

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))

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))

873753

874754 normalize selected' ===

875755 [ (('a', 'd'), (0, 0))

@@ -887,3 +767,13 @@ testEvaluate = databasePropertyTest "evaluate has the evaluation order we expect

887767 normalize :: [(x, (Int64, Int64))] -> [(x, (Int64, Int64))]

888768 normalize [] = []

889769 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+1−44

@@ -5,9 +5,7 @@

55{-# language DuplicateRecordFields #-}

66{-# language FlexibleInstances #-}

77{-# language MultiParamTypeClasses #-}

8−{-# language StandaloneKindSignatures #-}

98{-# language TypeFamilies #-}

10−{-# language UndecidableInstances #-}

119

1210{-# options_ghc -O0 #-}

1311

@@ -138,51 +136,10 @@ data TableSum f

138136 deriving stock Generic

139137

140138

141−data BarbieSum f

142− = BarbieSumA (f Bool) (f Text)

143− | BarbieSumB

144− | BarbieSumC (f Text)

145− deriving stock Generic

146−

147−

148139data TableProduct f = TableProduct

149− { sum :: HADT f BarbieSum

140+ { sum :: HADT f TableSum

150141 , list :: TableList f

151142 , foos :: HList f (HADT f TableSum, Lift f HKDSum, HKDTest f)

152143 }

153144 deriving stock Generic

154145 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